]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/frontend-passes.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
PR fortran/95090 - ICE: identifier overflow
[thirdparty/gcc.git] / gcc / fortran / frontend-passes.c
CommitLineData
601d98be 1/* Pass manager for Fortran front end.
8d9254fc 2 Copyright (C) 2010-2020 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 *);
15e23330
TK		 42static int do_intent (gfc_expr **);
43static int do_subscript (gfc_expr **);
e81e4b43
TK		 44static void optimize_reduction (gfc_namespace *);
45static int callback_reduction (gfc_expr **, int *, void *);
8b7cec58 46static void realloc_strings (gfc_namespace *);
f1abbf69 47static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
0f6ed121
TK		 48static int matmul_to_var_expr (gfc_expr **, int *, void *);
49static int matmul_to_var_code (gfc_code **, int *, void *);
f1abbf69
TK		 50static int inline_matmul_assign (gfc_code **, int *, void *);
51static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
7474dcc1 52 locus *, gfc_namespace *,
f1abbf69 53 char *vname=NULL);
bbe3927b
TK		 54static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *,
55 bool *);
998511a6 56static int call_external_blas (gfc_code **, int *, void *);
bbe3927b 57static int matmul_temp_args (gfc_code **, int *,void *data);
d88412fc 58static int index_interchange (gfc_code **, int*, void *);
9658d116
TK		 59static bool is_fe_temp (gfc_expr *e);
60
be841e11
TK		 61#ifdef CHECKING_P
62static void check_locus (gfc_namespace *);
63#endif
64
4afeb65c
TK		 65/* How deep we are inside an argument list. */
66
67static int count_arglist;
601d98be 68
6c7069d6 69/* Vector of gfc_expr ** we operate on. */
2757d5ec 70
6c7069d6 71static vec<gfc_expr **> expr_array;
2757d5ec
TK		 72
73/* Pointer to the gfc_code we currently work on - to be able to insert
5a87ca71 74 a block before the statement. */
2757d5ec
TK		 75
76static gfc_code **current_code;
77
5a87ca71
TK		 78/* Pointer to the block to be inserted, and the statement we are
79 changing within the block. */
80
81static gfc_code *inserted_block, **changed_statement;
82
2757d5ec
TK		 83/* The namespace we are currently dealing with. */
84
930d4d4e 85static gfc_namespace *current_ns;
2757d5ec 86
2855325f
TK		 87/* If we are within any forall loop. */
88
89static int forall_level;
90
e07e39f6
TK		 91/* Keep track of whether we are within an OMP workshare. */
92
93static bool in_omp_workshare;
94
a7a09efa
JJ		 95/* Keep track of whether we are within an OMP atomic. */
96
97static bool in_omp_atomic;
98
fd42eed8
TK		 99/* Keep track of whether we are within a WHERE statement. */
100
101static bool in_where;
102
8144d290
TK		 103/* Keep track of iterators for array constructors. */
104
105static int iterator_level;
106
305a35da
TK		 107/* Keep track of DO loop levels. */
108
15e23330
TK		 109typedef struct {
110 gfc_code *c;
111 int branch_level;
112 bool seen_goto;
113} do_t;
6c7069d6 114
15e23330 115static vec<do_t> doloop_list;
6c7069d6 116static int doloop_level;
305a35da 117
15e23330
TK		 118/* Keep track of if and select case levels. */
119
120static int if_level;
121static int select_level;
122
305a35da
TK		 123/* Vector of gfc_expr * to keep track of DO loops. */
124
125struct my_struct *evec;
126
e3f9e757
TK		 127/* Keep track of association lists. */
128
129static bool in_assoc_list;
130
f1abbf69
TK		 131/* Counter for temporary variables. */
132
133static int var_num = 1;
134
135/* What sort of matrix we are dealing with when inlining MATMUL. */
136
998511a6 137enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T };
f1abbf69 138
7474dcc1 139/* Keep track of the number of expressions we have inserted so far
f1abbf69
TK		 140 using create_var. */
141
142int n_vars;
143
1cc0e193 144/* Entry point - run all passes for a namespace. */
601d98be
TK		 145
146void
2bfec368 147gfc_run_passes (gfc_namespace *ns)
601d98be 148{
305a35da
TK		 149
150 /* Warn about dubious DO loops where the index might
151 change. */
152
305a35da 153 doloop_level = 0;
15e23330
TK		 154 if_level = 0;
155 select_level = 0;
305a35da 156 doloop_warn (ns);
6c7069d6 157 doloop_list.release ();
a23404c9 158 int w, e;
305a35da 159
be841e11
TK		 160#ifdef CHECKING_P
161 check_locus (ns);
162#endif
163
ef22816c
TK		 164 gfc_get_errors (&w, &e);
165 if (e > 0)
166 return;
167
d88412fc
TK		 168 if (flag_frontend_optimize || flag_frontend_loop_interchange)
169 optimize_namespace (ns);
170
203c7ebf 171 if (flag_frontend_optimize)
1607a827 172 {
e81e4b43 173 optimize_reduction (ns);
c61819ff 174 if (flag_dump_fortran_optimized)
1607a827 175 gfc_dump_parse_tree (ns, stdout);
2757d5ec 176
6c7069d6 177 expr_array.release ();
1607a827 178 }
8b7cec58
TK		 179
180 if (flag_realloc_lhs)
181 realloc_strings (ns);
182}
183
be841e11
TK		 184#ifdef CHECKING_P
185
186/* Callback function: Warn if there is no location information in a
187 statement. */
188
189static int
190check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
191 void *data ATTRIBUTE_UNUSED)
192{
193 current_code = c;
194 if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL)))
e146ea17
TK		 195 gfc_warning_internal (0, "Inconsistent internal state: "
196 "No location in statement");
be841e11
TK		 197
198 return 0;
199}
200
201
202/* Callback function: Warn if there is no location information in an
203 expression. */
204
205static int
206check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
207 void *data ATTRIBUTE_UNUSED)
208{
209
210 if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL)))
e146ea17
TK		 211 gfc_warning_internal (0, "Inconsistent internal state: "
212 "No location in expression near %L",
be841e11
TK		 213 &((*current_code)->loc));
214 return 0;
215}
216
217/* Run check for missing location information. */
218
219static void
220check_locus (gfc_namespace *ns)
221{
222 gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL);
223
224 for (ns = ns->contained; ns; ns = ns->sibling)
225 {
226 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
227 check_locus (ns);
228 }
229}
230
231#endif
232
8b7cec58
TK		 233/* Callback for each gfc_code node invoked from check_realloc_strings.
234 For an allocatable LHS string which also appears as a variable on
7474dcc1 235 the RHS, replace
8b7cec58
TK		 236
237 a = a(x:y)
238
239 with
240
241 tmp = a(x:y)
242 a = tmp
243 */
244
245static int
7b201a88 246realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
8b7cec58
TK		 247 void *data ATTRIBUTE_UNUSED)
248{
249 gfc_expr *expr1, *expr2;
250 gfc_code *co = *c;
251 gfc_expr *n;
d6598cf7
TK		 252 gfc_ref *ref;
253 bool found_substr;
8b7cec58 254
8b7cec58
TK		 255 if (co->op != EXEC_ASSIGN)
256 return 0;
257
258 expr1 = co->expr1;
852f7e6f 259 if (expr1->ts.type != BT_CHARACTER
d6598cf7
TK		 260 || !gfc_expr_attr(expr1).allocatable
261 || !expr1->ts.deferred)
8b7cec58
TK		 262 return 0;
263
9658d116
TK		 264 if (is_fe_temp (expr1))
265 return 0;
266
8b7cec58 267 expr2 = gfc_discard_nops (co->expr2);
8b7cec58 268
b68a9f34 269 if (expr2->expr_type == EXPR_VARIABLE)
d6598cf7 270 {
b68a9f34
TK		 271 found_substr = false;
272 for (ref = expr2->ref; ref; ref = ref->next)
d6598cf7 273 {
b68a9f34
TK		 274 if (ref->type == REF_SUBSTRING)
275 {
276 found_substr = true;
277 break;
278 }
d6598cf7 279 }
b68a9f34
TK		 280 if (!found_substr)
281 return 0;
d6598cf7 282 }
852f7e6f
TK		 283 else if (expr2->expr_type != EXPR_ARRAY
284 && (expr2->expr_type != EXPR_OP
285 || expr2->value.op.op != INTRINSIC_CONCAT))
d6598cf7 286 return 0;
2efade53 287
8b7cec58
TK		 288 if (!gfc_check_dependency (expr1, expr2, true))
289 return 0;
4f028369 290
7474dcc1
PT		 291 /* gfc_check_dependency doesn't always pick up identical expressions.
292 However, eliminating the above sends the compiler into an infinite
293 loop on valid expressions. Without this check, the gimplifier emits
294 an ICE for a = a, where a is deferred character length. */
295 if (!gfc_dep_compare_expr (expr1, expr2))
296 return 0;
297
8b7cec58 298 current_code = c;
4f028369
JJ		 299 inserted_block = NULL;
300 changed_statement = NULL;
d6598cf7 301 n = create_var (expr2, "realloc_string");
8b7cec58
TK		 302 co->expr2 = n;
303 return 0;
2bfec368
TK		 304}
305
4d42b5cd
JJ		 306/* Callback for each gfc_code node invoked through gfc_code_walker
307 from optimize_namespace. */
2bfec368 308
4d42b5cd
JJ		 309static int
310optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
311 void *data ATTRIBUTE_UNUSED)
2bfec368 312{
4afeb65c
TK		 313
314 gfc_exec_op op;
315
316 op = (*c)->op;
317
318 if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
319 || op == EXEC_CALL_PPC)
320 count_arglist = 1;
321 else
322 count_arglist = 0;
323
4099436d
TK		 324 current_code = c;
325 inserted_block = NULL;
326 changed_statement = NULL;
327
4afeb65c 328 if (op == EXEC_ASSIGN)
4d42b5cd
JJ		 329 optimize_assignment (*c);
330 return 0;
601d98be
TK		 331}
332
4d42b5cd
JJ		 333/* Callback for each gfc_expr node invoked through gfc_code_walker
334 from optimize_namespace. */
335
336static int
337optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
338 void *data ATTRIBUTE_UNUSED)
601d98be 339{
4afeb65c
TK		 340 bool function_expr;
341
342 if ((*e)->expr_type == EXPR_FUNCTION)
343 {
344 count_arglist ++;
345 function_expr = true;
346 }
347 else
348 function_expr = false;
349
350 if (optimize_trim (*e))
351 gfc_simplify_expr (*e, 0);
352
9046a4dc
TK		 353 if (optimize_lexical_comparison (*e))
354 gfc_simplify_expr (*e, 0);
355
4d42b5cd
JJ		 356 if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
357 gfc_simplify_expr (*e, 0);
4afeb65c 358
d2663912
JJ		 359 if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
360 switch ((*e)->value.function.isym->id)
361 {
362 case GFC_ISYM_MINLOC:
363 case GFC_ISYM_MAXLOC:
364 optimize_minmaxloc (e);
365 break;
366 default:
367 break;
368 }
369
4afeb65c
TK		 370 if (function_expr)
371 count_arglist --;
372
4d42b5cd 373 return 0;
601d98be
TK		 374}
375
e81e4b43
TK		 376/* Auxiliary function to handle the arguments to reduction intrnisics. If the
377 function is a scalar, just copy it; otherwise returns the new element, the
378 old one can be freed. */
379
380static gfc_expr *
b91a551f 381copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
e81e4b43 382{
b91a551f 383 gfc_expr *fcn, *e = c->expr;
e81e4b43 384
b91a551f
TK		 385 fcn = gfc_copy_expr (e);
386 if (c->iterator)
387 {
388 gfc_constructor_base newbase;
389 gfc_expr *new_expr;
390 gfc_constructor *new_c;
391
392 newbase = NULL;
393 new_expr = gfc_get_expr ();
394 new_expr->expr_type = EXPR_ARRAY;
395 new_expr->ts = e->ts;
396 new_expr->where = e->where;
397 new_expr->rank = 1;
398 new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
399 new_c->iterator = c->iterator;
400 new_expr->value.constructor = newbase;
401 c->iterator = NULL;
402
403 fcn = new_expr;
404 }
405
406 if (fcn->rank != 0)
e81e4b43 407 {
b91a551f 408 gfc_isym_id id = fn->value.function.isym->id;
e81e4b43
TK		 409
410 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
b91a551f 411 fcn = gfc_build_intrinsic_call (current_ns, id,
e81e4b43 412 fn->value.function.isym->name,
b91a551f 413 fn->where, 3, fcn, NULL, NULL);
e81e4b43 414 else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
b91a551f 415 fcn = gfc_build_intrinsic_call (current_ns, id,
e81e4b43 416 fn->value.function.isym->name,
b91a551f 417 fn->where, 2, fcn, NULL);
e81e4b43
TK		 418 else
419 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
420
421 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
422 }
423
e81e4b43
TK		 424 return fcn;
425}
426
427/* Callback function for optimzation of reductions to scalars. Transform ANY
428 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
429 correspondingly. Handly only the simple cases without MASK and DIM. */
430
431static int
432callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
433 void *data ATTRIBUTE_UNUSED)
434{
435 gfc_expr *fn, *arg;
436 gfc_intrinsic_op op;
437 gfc_isym_id id;
438 gfc_actual_arglist *a;
439 gfc_actual_arglist *dim;
440 gfc_constructor *c;
441 gfc_expr *res, *new_expr;
442 gfc_actual_arglist *mask;
443
444 fn = *e;
445
446 if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
447 || fn->value.function.isym == NULL)
448 return 0;
449
450 id = fn->value.function.isym->id;
451
452 if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
453 && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
454 return 0;
455
456 a = fn->value.function.actual;
457
458 /* Don't handle MASK or DIM. */
459
460 dim = a->next;
461
462 if (dim->expr != NULL)
463 return 0;
464
465 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
466 {
467 mask = dim->next;
468 if ( mask->expr != NULL)
469 return 0;
470 }
471
472 arg = a->expr;
473
474 if (arg->expr_type != EXPR_ARRAY)
475 return 0;
476
477 switch (id)
478 {
479 case GFC_ISYM_SUM:
480 op = INTRINSIC_PLUS;
481 break;
482
483 case GFC_ISYM_PRODUCT:
484 op = INTRINSIC_TIMES;
485 break;
486
487 case GFC_ISYM_ANY:
488 op = INTRINSIC_OR;
489 break;
490
491 case GFC_ISYM_ALL:
492 op = INTRINSIC_AND;
493 break;
494
495 default:
496 return 0;
497 }
498
499 c = gfc_constructor_first (arg->value.constructor);
500
a2d0800a
TK		 501 /* Don't do any simplififcation if we have
502 - no element in the constructor or
503 - only have a single element in the array which contains an
504 iterator. */
505
b91a551f 506 if (c == NULL)
e81e4b43
TK		 507 return 0;
508
b91a551f 509 res = copy_walk_reduction_arg (c, fn);
e81e4b43
TK		 510
511 c = gfc_constructor_next (c);
512 while (c)
513 {
514 new_expr = gfc_get_expr ();
515 new_expr->ts = fn->ts;
516 new_expr->expr_type = EXPR_OP;
517 new_expr->rank = fn->rank;
518 new_expr->where = fn->where;
519 new_expr->value.op.op = op;
520 new_expr->value.op.op1 = res;
b91a551f 521 new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
e81e4b43
TK		 522 res = new_expr;
523 c = gfc_constructor_next (c);
524 }
525
526 gfc_simplify_expr (res, 0);
527 *e = res;
528 gfc_free_expr (fn);
529
530 return 0;
531}
2757d5ec
TK		 532
533/* Callback function for common function elimination, called from cfe_expr_0.
42a2717c 534 Put all eligible function expressions into expr_array. */
2757d5ec
TK		 535
536static int
537cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
538 void *data ATTRIBUTE_UNUSED)
539{
6e98bce4 540
2757d5ec
TK		 541 if ((*e)->expr_type != EXPR_FUNCTION)
542 return 0;
543
42a2717c 544 /* We don't do character functions with unknown charlens. */
7474dcc1 545 if ((*e)->ts.type == BT_CHARACTER
42a2717c
TK		 546 && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
547 || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
2757d5ec
TK		 548 return 0;
549
2855325f
TK		 550 /* We don't do function elimination within FORALL statements, it can
551 lead to wrong-code in certain circumstances. */
552
553 if (forall_level > 0)
554 return 0;
555
8144d290
TK		 556 /* Function elimination inside an iterator could lead to functions which
557 depend on iterator variables being moved outside. FIXME: We should check
558 if the functions do indeed depend on the iterator variable. */
559
560 if (iterator_level > 0)
561 return 0;
562
222c2a63
TK		 563 /* If we don't know the shape at compile time, we create an allocatable
564 temporary variable to hold the intermediate result, but only if
565 allocation on assignment is active. */
2757d5ec 566
203c7ebf 567 if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
2757d5ec 568 return 0;
7474dcc1 569
2757d5ec
TK		 570 /* Skip the test for pure functions if -faggressive-function-elimination
571 is specified. */
572 if ((*e)->value.function.esym)
573 {
2757d5ec
TK		 574 /* Don't create an array temporary for elemental functions. */
575 if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
576 return 0;
577
578 /* Only eliminate potentially impure functions if the
579 user specifically requested it. */
c61819ff 580 if (!flag_aggressive_function_elimination
2757d5ec
TK		 581 && !(*e)->value.function.esym->attr.pure
582 && !(*e)->value.function.esym->attr.implicit_pure)
583 return 0;
584 }
585
586 if ((*e)->value.function.isym)
587 {
588 /* Conversions are handled on the fly by the middle end,
42a2717c 589 transpose during trans-* stages and TRANSFER by the middle end. */
2757d5ec 590 if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
93ee6382
MM		 591 || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
592 || gfc_inline_intrinsic_function_p (*e))
2757d5ec
TK		 593 return 0;
594
595 /* Don't create an array temporary for elemental functions,
596 as this would be wasteful of memory.
597 FIXME: Create a scalar temporary during scalarization. */
598 if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
599 return 0;
600
601 if (!(*e)->value.function.isym->pure)
602 return 0;
603 }
604
6c7069d6 605 expr_array.safe_push (e);
2757d5ec
TK		 606 return 0;
607}
608
ba8aa6fc
TK		 609/* Auxiliary function to check if an expression is a temporary created by
610 create var. */
611
612static bool
613is_fe_temp (gfc_expr *e)
614{
615 if (e->expr_type != EXPR_VARIABLE)
616 return false;
617
618 return e->symtree->n.sym->attr.fe_temp;
619}
620
8b7cec58
TK		 621/* Determine the length of a string, if it can be evaluated as a constant
622 expression. Return a newly allocated gfc_expr or NULL on failure.
623 If the user specified a substring which is potentially longer than
624 the string itself, the string will be padded with spaces, which
625 is harmless. */
626
627static gfc_expr *
628constant_string_length (gfc_expr *e)
629{
630
631 gfc_expr *length;
632 gfc_ref *ref;
633 gfc_expr *res;
634 mpz_t value;
635
636 if (e->ts.u.cl)
637 {
638 length = e->ts.u.cl->length;
639 if (length && length->expr_type == EXPR_CONSTANT)
640 return gfc_copy_expr(length);
641 }
642
437725af
TK		 643 /* See if there is a substring. If it has a constant length, return
644 that and NULL otherwise. */
8b7cec58
TK		 645 for (ref = e->ref; ref; ref = ref->next)
646 {
437725af 647 if (ref->type == REF_SUBSTRING)
8b7cec58 648 {
437725af
TK		 649 if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
650 {
651 res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
652 &e->where);
7474dcc1 653
437725af
TK		 654 mpz_add_ui (res->value.integer, value, 1);
655 mpz_clear (value);
656 return res;
657 }
658 else
659 return NULL;
8b7cec58
TK		 660 }
661 }
662
663 /* Return length of char symbol, if constant. */
b68a9f34
TK		 664 if (e->symtree && e->symtree->n.sym->ts.u.cl
665 && e->symtree->n.sym->ts.u.cl->length
8b7cec58
TK		 666 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
667 return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
668
669 return NULL;
670
671}
ba8aa6fc 672
f1abbf69
TK		 673/* Insert a block at the current position unless it has already
674 been inserted; in this case use the one already there. */
2757d5ec 675
f1abbf69
TK		 676static gfc_namespace*
677insert_block ()
2757d5ec 678{
5a87ca71 679 gfc_namespace *ns;
ba8aa6fc 680
5a87ca71
TK		 681 /* If the block hasn't already been created, do so. */
682 if (inserted_block == NULL)
683 {
684 inserted_block = XCNEW (gfc_code);
685 inserted_block->op = EXEC_BLOCK;
686 inserted_block->loc = (*current_code)->loc;
687 ns = gfc_build_block_ns (current_ns);
688 inserted_block->ext.block.ns = ns;
689 inserted_block->ext.block.assoc = NULL;
690
691 ns->code = *current_code;
3d3b8193
TK		 692
693 /* If the statement has a label, make sure it is transferred to
694 the newly created block. */
695
7474dcc1 696 if ((*current_code)->here)
3d3b8193
TK		 697 {
698 inserted_block->here = (*current_code)->here;
699 (*current_code)->here = NULL;
700 }
701
5a87ca71
TK		 702 inserted_block->next = (*current_code)->next;
703 changed_statement = &(inserted_block->ext.block.ns->code);
704 (*current_code)->next = NULL;
705 /* Insert the BLOCK at the right position. */
706 *current_code = inserted_block;
930d4d4e 707 ns->parent = current_ns;
5a87ca71
TK		 708 }
709 else
710 ns = inserted_block->ext.block.ns;
711
f1abbf69
TK		 712 return ns;
713}
714
2efade53
PT		 715
716/* Insert a call to the intrinsic len. Use a different name for
717 the symbol tree so we don't run into trouble when the user has
718 renamed len for some reason. */
719
720static gfc_expr*
721get_len_call (gfc_expr *str)
722{
723 gfc_expr *fcn;
724 gfc_actual_arglist *actual_arglist;
725
726 fcn = gfc_get_expr ();
727 fcn->expr_type = EXPR_FUNCTION;
728 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
729 actual_arglist = gfc_get_actual_arglist ();
730 actual_arglist->expr = str;
731
732 fcn->value.function.actual = actual_arglist;
733 fcn->where = str->where;
734 fcn->ts.type = BT_INTEGER;
735 fcn->ts.kind = gfc_charlen_int_kind;
736
737 gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
738 fcn->symtree->n.sym->ts = fcn->ts;
739 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
740 fcn->symtree->n.sym->attr.function = 1;
741 fcn->symtree->n.sym->attr.elemental = 1;
742 fcn->symtree->n.sym->attr.referenced = 1;
743 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
744 gfc_commit_symbol (fcn->symtree->n.sym);
745
746 return fcn;
747}
748
749
f1abbf69
TK		 750/* Returns a new expression (a variable) to be used in place of the old one,
751 with an optional assignment statement before the current statement to set
752 the value of the variable. Creates a new BLOCK for the statement if that
753 hasn't already been done and puts the statement, plus the newly created
754 variables, in that block. Special cases: If the expression is constant or
755 a temporary which has already been created, just copy it. */
756
757static gfc_expr*
758create_var (gfc_expr * e, const char *vname)
759{
760 char name[GFC_MAX_SYMBOL_LEN +1];
761 gfc_symtree *symtree;
762 gfc_symbol *symbol;
763 gfc_expr *result;
764 gfc_code *n;
765 gfc_namespace *ns;
766 int i;
874be74a 767 bool deferred;
f1abbf69
TK		 768
769 if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
770 return gfc_copy_expr (e);
771
62227a69
TK		 772 /* Creation of an array of unknown size requires realloc on assignment.
773 If that is not possible, just return NULL. */
774 if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL)
775 return NULL;
776
f1abbf69
TK		 777 ns = insert_block ();
778
779 if (vname)
780 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
781 else
782 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);
783
5a87ca71 784 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
2757d5ec
TK		 785 gcc_unreachable ();
786
787 symbol = symtree->n.sym;
788 symbol->ts = e->ts;
222c2a63
TK		 789
790 if (e->rank > 0)
2757d5ec 791 {
222c2a63
TK		 792 symbol->as = gfc_get_array_spec ();
793 symbol->as->rank = e->rank;
794
795 if (e->shape == NULL)
796 {
797 /* We don't know the shape at compile time, so we use an
1cc0e193 798 allocatable. */
222c2a63
TK		 799 symbol->as->type = AS_DEFERRED;
800 symbol->attr.allocatable = 1;
801 }
802 else
803 {
804 symbol->as->type = AS_EXPLICIT;
805 /* Copy the shape. */
806 for (i=0; i<e->rank; i++)
807 {
808 gfc_expr *p, *q;
7474dcc1 809
222c2a63
TK		 810 p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
811 &(e->where));
812 mpz_set_si (p->value.integer, 1);
813 symbol->as->lower[i] = p;
7474dcc1 814
222c2a63
TK		 815 q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
816 &(e->where));
817 mpz_set (q->value.integer, e->shape[i]);
818 symbol->as->upper[i] = q;
819 }
820 }
2757d5ec
TK		 821 }
822
874be74a 823 deferred = 0;
1cde289f 824 if (e->ts.type == BT_CHARACTER)
8b7cec58
TK		 825 {
826 gfc_expr *length;
827
36b54ce0 828 symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
8b7cec58
TK		 829 length = constant_string_length (e);
830 if (length)
36b54ce0 831 symbol->ts.u.cl->length = length;
2efade53
PT		 832 else if (e->expr_type == EXPR_VARIABLE
833 && e->symtree->n.sym->ts.type == BT_CHARACTER
834 && e->ts.u.cl->length)
835 symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
8b7cec58 836 else
874be74a
TK		 837 {
838 symbol->attr.allocatable = 1;
1cde289f
TK		 839 symbol->ts.u.cl->length = NULL;
840 symbol->ts.deferred = 1;
874be74a
TK		 841 deferred = 1;
842 }
8b7cec58
TK		 843 }
844
2757d5ec
TK		 845 symbol->attr.flavor = FL_VARIABLE;
846 symbol->attr.referenced = 1;
847 symbol->attr.dimension = e->rank > 0;
ba8aa6fc 848 symbol->attr.fe_temp = 1;
2757d5ec
TK		 849 gfc_commit_symbol (symbol);
850
851 result = gfc_get_expr ();
852 result->expr_type = EXPR_VARIABLE;
1cde289f 853 result->ts = symbol->ts;
874be74a 854 result->ts.deferred = deferred;
2757d5ec
TK		 855 result->rank = e->rank;
856 result->shape = gfc_copy_shape (e->shape, e->rank);
857 result->symtree = symtree;
858 result->where = e->where;
859 if (e->rank > 0)
860 {
861 result->ref = gfc_get_ref ();
862 result->ref->type = REF_ARRAY;
863 result->ref->u.ar.type = AR_FULL;
864 result->ref->u.ar.where = e->where;
f1abbf69 865 result->ref->u.ar.dimen = e->rank;
102344e2
TB		 866 result->ref->u.ar.as = symbol->ts.type == BT_CLASS
867 ? CLASS_DATA (symbol)->as : symbol->as;
73e42eef 868 if (warn_array_temporaries)
48749dbc
MLI		 869 gfc_warning (OPT_Warray_temporaries,
870 "Creating array temporary at %L", &(e->where));
2757d5ec
TK		 871 }
872
873 /* Generate the new assignment. */
874 n = XCNEW (gfc_code);
875 n->op = EXEC_ASSIGN;
876 n->loc = (*current_code)->loc;
5a87ca71 877 n->next = *changed_statement;
2757d5ec
TK		 878 n->expr1 = gfc_copy_expr (result);
879 n->expr2 = e;
5a87ca71 880 *changed_statement = n;
f1abbf69 881 n_vars ++;
2757d5ec
TK		 882
883 return result;
884}
885
51a30b32
TK		 886/* Warn about function elimination. */
887
888static void
73e42eef 889do_warn_function_elimination (gfc_expr *e)
51a30b32 890{
6457b1f0
JW		 891 const char *name;
892 if (e->expr_type == EXPR_FUNCTION
893 && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e))
894 {
895 if (name)
896 gfc_warning (OPT_Wfunction_elimination,
897 "Removing call to impure function %qs at %L", name,
898 &(e->where));
899 else
900 gfc_warning (OPT_Wfunction_elimination,
901 "Removing call to impure function at %L",
902 &(e->where));
903 }
51a30b32 904}
6457b1f0
JW		 905
906
2757d5ec
TK		 907/* Callback function for the code walker for doing common function
908 elimination. This builds up the list of functions in the expression
909 and goes through them to detect duplicates, which it then replaces
910 by variables. */
911
912static int
913cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
914 void *data ATTRIBUTE_UNUSED)
915{
916 int i,j;
917 gfc_expr *newvar;
6c7069d6 918 gfc_expr **ei, **ej;
2757d5ec 919
a7a09efa 920 /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */
e07e39f6 921
a7a09efa 922 if (in_omp_workshare || in_omp_atomic || in_assoc_list)
e07e39f6
TK		 923 {
924 *walk_subtrees = 0;
925 return 0;
926 }
927
6c7069d6 928 expr_array.release ();
2757d5ec
TK		 929
930 gfc_expr_walker (e, cfe_register_funcs, NULL);
931
128e09f9
TK		 932 /* Walk through all the functions. */
933
6c7069d6 934 FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
2757d5ec
TK		 935 {
936 /* Skip if the function has been replaced by a variable already. */
6c7069d6 937 if ((*ei)->expr_type == EXPR_VARIABLE)
2757d5ec
TK		 938 continue;
939
940 newvar = NULL;
128e09f9 941 for (j=0; j<i; j++)
2757d5ec 942 {
6c7069d6
TK		 943 ej = expr_array[j];
944 if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
2757d5ec
TK		 945 {
946 if (newvar == NULL)
f1abbf69 947 newvar = create_var (*ei, "fcn");
51a30b32 948
73e42eef
TB		 949 if (warn_function_elimination)
950 do_warn_function_elimination (*ej);
51a30b32 951
6c7069d6
TK		 952 free (*ej);
953 *ej = gfc_copy_expr (newvar);
2757d5ec
TK		 954 }
955 }
956 if (newvar)
6c7069d6 957 *ei = newvar;
2757d5ec
TK		 958 }
959
960 /* We did all the necessary walking in this function. */
961 *walk_subtrees = 0;
962 return 0;
963}
964
965/* Callback function for common function elimination, called from
966 gfc_code_walker. This keeps track of the current code, in order
967 to insert statements as needed. */
968
969static int
4f83d583 970cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
2757d5ec
TK		 971{
972 current_code = c;
5a87ca71
TK		 973 inserted_block = NULL;
974 changed_statement = NULL;
4f83d583
TK		 975
976 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
977 and allocation on assigment are prohibited inside WHERE, and finally
978 masking an expression would lead to wrong-code when replacing
979
980 WHERE (a>0)
981 b = sum(foo(a) + foo(a))
982 END WHERE
983
984 with
985
986 WHERE (a > 0)
987 tmp = foo(a)
988 b = sum(tmp + tmp)
989 END WHERE
990*/
991
992 if ((*c)->op == EXEC_WHERE)
993 {
994 *walk_subtrees = 0;
995 return 0;
996 }
7474dcc1 997
4f83d583 998
2757d5ec
TK		 999 return 0;
1000}
1001
fa11ae6c
TK		 1002/* Dummy function for expression call back, for use when we
1003 really don't want to do any walking. */
1004
1005static int
1006dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
1007 void *data ATTRIBUTE_UNUSED)
1008{
1009 *walk_subtrees = 0;
1010 return 0;
1011}
1012
e81e4b43
TK		 1013/* Dummy function for code callback, for use when we really
1014 don't want to do anything. */
5f23671d
JJ		 1015int
1016gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
1017 int *walk_subtrees ATTRIBUTE_UNUSED,
1018 void *data ATTRIBUTE_UNUSED)
e81e4b43
TK		 1019{
1020 return 0;
1021}
1022
fa11ae6c
TK		 1023/* Code callback function for converting
1024 do while(a)
1025 end do
1026 into the equivalent
1027 do
1028 if (.not. a) exit
1029 end do
1030 This is because common function elimination would otherwise place the
1031 temporary variables outside the loop. */
1032
1033static int
1034convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1035 void *data ATTRIBUTE_UNUSED)
1036{
1037 gfc_code *co = *c;
1038 gfc_code *c_if1, *c_if2, *c_exit;
1039 gfc_code *loopblock;
1040 gfc_expr *e_not, *e_cond;
1041
1042 if (co->op != EXEC_DO_WHILE)
1043 return 0;
1044
1045 if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
1046 return 0;
1047
1048 e_cond = co->expr1;
1049
1050 /* Generate the condition of the if statement, which is .not. the original
1051 statement. */
1052 e_not = gfc_get_expr ();
1053 e_not->ts = e_cond->ts;
1054 e_not->where = e_cond->where;
1055 e_not->expr_type = EXPR_OP;
1056 e_not->value.op.op = INTRINSIC_NOT;
1057 e_not->value.op.op1 = e_cond;
1058
1059 /* Generate the EXIT statement. */
1060 c_exit = XCNEW (gfc_code);
1061 c_exit->op = EXEC_EXIT;
1062 c_exit->ext.which_construct = co;
1063 c_exit->loc = co->loc;
1064
1065 /* Generate the IF statement. */
1066 c_if2 = XCNEW (gfc_code);
1067 c_if2->op = EXEC_IF;
1068 c_if2->expr1 = e_not;
1069 c_if2->next = c_exit;
1070 c_if2->loc = co->loc;
1071
1072 /* ... plus the one to chain it to. */
1073 c_if1 = XCNEW (gfc_code);
1074 c_if1->op = EXEC_IF;
1075 c_if1->block = c_if2;
1076 c_if1->loc = co->loc;
1077
1078 /* Make the DO WHILE loop into a DO block by replacing the condition
1079 with a true constant. */
1080 co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
1081
1082 /* Hang the generated if statement into the loop body. */
1083
1084 loopblock = co->block->next;
1085 co->block->next = c_if1;
1086 c_if1->next = loopblock;
1087
1088 return 0;
1089}
1090
cf82db16
TK		 1091/* Code callback function for converting
1092 if (a) then
1093 ...
1094 else if (b) then
1095 end if
1096
1097 into
1098 if (a) then
1099 else
1100 if (b) then
1101 end if
1102 end if
1103
1104 because otherwise common function elimination would place the BLOCKs
1105 into the wrong place. */
1106
1107static int
1108convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1109 void *data ATTRIBUTE_UNUSED)
1110{
1111 gfc_code *co = *c;
1112 gfc_code *c_if1, *c_if2, *else_stmt;
1113
1114 if (co->op != EXEC_IF)
1115 return 0;
1116
1117 /* This loop starts out with the first ELSE statement. */
1118 else_stmt = co->block->block;
1119
1120 while (else_stmt != NULL)
1121 {
1122 gfc_code *next_else;
1123
1124 /* If there is no condition, we're done. */
1125 if (else_stmt->expr1 == NULL)
1126 break;
1127
1128 next_else = else_stmt->block;
1129
1130 /* Generate the new IF statement. */
1131 c_if2 = XCNEW (gfc_code);
1132 c_if2->op = EXEC_IF;
1133 c_if2->expr1 = else_stmt->expr1;
1134 c_if2->next = else_stmt->next;
1135 c_if2->loc = else_stmt->loc;
1136 c_if2->block = next_else;
1137
1138 /* ... plus the one to chain it to. */
1139 c_if1 = XCNEW (gfc_code);
1140 c_if1->op = EXEC_IF;
1141 c_if1->block = c_if2;
1142 c_if1->loc = else_stmt->loc;
1143
1144 /* Insert the new IF after the ELSE. */
1145 else_stmt->expr1 = NULL;
1146 else_stmt->next = c_if1;
1147 else_stmt->block = NULL;
1148
1149 else_stmt = next_else;
1150 }
1151 /* Don't walk subtrees. */
1152 return 0;
1153}
f1abbf69 1154
3413d168
TK		 1155/* Callback function to var_in_expr - return true if expr1 and
1156 expr2 are identical variables. */
1157static int
1158var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1159 void *data)
1160{
1161 gfc_expr *expr1 = (gfc_expr *) data;
1162 gfc_expr *expr2 = *e;
1163
1164 if (expr2->expr_type != EXPR_VARIABLE)
1165 return 0;
1166
1167 return expr1->symtree->n.sym == expr2->symtree->n.sym;
1168}
1169
1170/* Return true if expr1 is found in expr2. */
1171
1172static bool
1173var_in_expr (gfc_expr *expr1, gfc_expr *expr2)
1174{
1175 gcc_assert (expr1->expr_type == EXPR_VARIABLE);
1176
1177 return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1);
1178}
1179
7b3ee9c9
NK		 1180struct do_stack
1181{
1182 struct do_stack *prev;
1183 gfc_iterator *iter;
1184 gfc_code *code;
1185} *stack_top;
1186
1187/* Recursively traverse the block of a WRITE or READ statement, and maybe
1188 optimize by replacing do loops with their analog array slices. For
1189 example:
1190
1191 write (*,*) (a(i), i=1,4)
1192
1193 is replaced with
1194
1195 write (*,*) a(1:4:1) . */
1196
1197static bool
1198traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
1199{
1200 gfc_code *curr;
1201 gfc_expr *new_e, *expr, *start;
1202 gfc_ref *ref;
1203 struct do_stack ds_push;
1204 int i, future_rank = 0;
1205 gfc_iterator *iters[GFC_MAX_DIMENSIONS];
1206 gfc_expr *e;
1207
1208 /* Find the first transfer/do statement. */
1209 for (curr = code; curr; curr = curr->next)
1210 {
1211 if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
1212 break;
1213 }
1214
1215 /* Ensure it is the only transfer/do statement because cases like
1216
1217 write (*,*) (a(i), b(i), i=1,4)
1218
1219 cannot be optimized. */
1220
1221 if (!curr || curr->next)
1222 return false;
1223
1224 if (curr->op == EXEC_DO)
1225 {
1226 if (curr->ext.iterator->var->ref)
1227 return false;
1228 ds_push.prev = stack_top;
1229 ds_push.iter = curr->ext.iterator;
1230 ds_push.code = curr;
1231 stack_top = &ds_push;
1232 if (traverse_io_block (curr->block->next, has_reached, prev))
1233 {
1234 if (curr != stack_top->code && !*has_reached)
1235 {
1236 curr->block->next = NULL;
1237 gfc_free_statements (curr);
1238 }
1239 else
1240 *has_reached = true;
1241 return true;
1242 }
1243 return false;
1244 }
1245
1246 gcc_assert (curr->op == EXEC_TRANSFER);
1247
7b3ee9c9 1248 e = curr->expr1;
7b3ee9c9
NK		 1249 ref = e->ref;
1250 if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
1251 return false;
1252
1253 /* Find the iterators belonging to each variable and check conditions. */
1254 for (i = 0; i < ref->u.ar.dimen; i++)
1255 {
1256 if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
1257 || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1258 return false;
1259
1260 start = ref->u.ar.start[i];
1261 gfc_simplify_expr (start, 0);
1262 switch (start->expr_type)
1263 {
1264 case EXPR_VARIABLE:
1265
1266 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1267 if (start->ref)
1268 return false;
1269
1270 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1271 if (!stack_top || !stack_top->iter
1272 || stack_top->iter->var->symtree != start->symtree)
ac39f0e8
TK		 1273 {
1274 /* Check for (a(i,i), i=1,3). */
1275 int j;
2efade53 1276
ac39f0e8
TK		 1277 for (j=0; j<i; j++)
1278 if (iters[j] && iters[j]->var->symtree == start->symtree)
1279 return false;
1280
1281 iters[i] = NULL;
1282 }
7b3ee9c9
NK		 1283 else
1284 {
1285 iters[i] = stack_top->iter;
1286 stack_top = stack_top->prev;
1287 future_rank++;
1288 }
1289 break;
1290 case EXPR_CONSTANT:
1291 iters[i] = NULL;
1292 break;
1293 case EXPR_OP:
1294 switch (start->value.op.op)
1295 {
1296 case INTRINSIC_PLUS:
1297 case INTRINSIC_TIMES:
1298 if (start->value.op.op1->expr_type != EXPR_VARIABLE)
1299 std::swap (start->value.op.op1, start->value.op.op2);
1300 gcc_fallthrough ();
1301 case INTRINSIC_MINUS:
1302 if ((start->value.op.op1->expr_type!= EXPR_VARIABLE
1303 && start->value.op.op2->expr_type != EXPR_CONSTANT)
1304 || start->value.op.op1->ref)
1305 return false;
1306 if (!stack_top || !stack_top->iter
1307 || stack_top->iter->var->symtree
1308 != start->value.op.op1->symtree)
1309 return false;
1310 iters[i] = stack_top->iter;
1311 stack_top = stack_top->prev;
1312 break;
1313 default:
1314 return false;
1315 }
1316 future_rank++;
1317 break;
1318 default:
1319 return false;
1320 }
1321 }
1322
acd1559a
TK		 1323 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1324 for (int i = 1; i < ref->u.ar.dimen; i++)
1325 {
1326 if (iters[i])
1327 {
1328 gfc_expr *var = iters[i]->var;
1329 for (int j = i - 1; j < i; j++)
1330 {
1331 if (iters[j]
3413d168
TK		 1332 && (var_in_expr (var, iters[j]->start)
1333 || var_in_expr (var, iters[j]->end)
1334 || var_in_expr (var, iters[j]->step)))
acd1559a 1335 return false;
2efade53 1336 }
acd1559a
TK		 1337 }
1338 }
1339
7b3ee9c9
NK		 1340 /* Create new expr. */
1341 new_e = gfc_copy_expr (curr->expr1);
1342 new_e->expr_type = EXPR_VARIABLE;
1343 new_e->rank = future_rank;
1344 if (curr->expr1->shape)
1345 new_e->shape = gfc_get_shape (new_e->rank);
1346
1347 /* Assign new starts, ends and strides if necessary. */
1348 for (i = 0; i < ref->u.ar.dimen; i++)
1349 {
1350 if (!iters[i])
1351 continue;
1352 start = ref->u.ar.start[i];
1353 switch (start->expr_type)
1354 {
1355 case EXPR_CONSTANT:
1356 gfc_internal_error ("bad expression");
1357 break;
1358 case EXPR_VARIABLE:
1359 new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
1360 new_e->ref->u.ar.type = AR_SECTION;
1361 gfc_free_expr (new_e->ref->u.ar.start[i]);
1362 new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start);
1363 new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end);
1364 new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
1365 break;
1366 case EXPR_OP:
1367 new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
1368 new_e->ref->u.ar.type = AR_SECTION;
1369 gfc_free_expr (new_e->ref->u.ar.start[i]);
1370 expr = gfc_copy_expr (start);
1371 expr->value.op.op1 = gfc_copy_expr (iters[i]->start);
1372 new_e->ref->u.ar.start[i] = expr;
1373 gfc_simplify_expr (new_e->ref->u.ar.start[i], 0);
1374 expr = gfc_copy_expr (start);
1375 expr->value.op.op1 = gfc_copy_expr (iters[i]->end);
1376 new_e->ref->u.ar.end[i] = expr;
1377 gfc_simplify_expr (new_e->ref->u.ar.end[i], 0);
1378 switch (start->value.op.op)
1379 {
1380 case INTRINSIC_MINUS:
1381 case INTRINSIC_PLUS:
1382 new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
1383 break;
1384 case INTRINSIC_TIMES:
1385 expr = gfc_copy_expr (start);
1386 expr->value.op.op1 = gfc_copy_expr (iters[i]->step);
1387 new_e->ref->u.ar.stride[i] = expr;
1388 gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0);
1389 break;
1390 default:
1391 gfc_internal_error ("bad op");
1392 }
1393 break;
1394 default:
1395 gfc_internal_error ("bad expression");
1396 }
1397 }
1398 curr->expr1 = new_e;
1399
1400 /* Insert modified statement. Check whether the statement needs to be
1401 inserted at the lowest level. */
1402 if (!stack_top->iter)
1403 {
1404 if (prev)
1405 {
1406 curr->next = prev->next->next;
1407 prev->next = curr;
1408 }
1409 else
1410 {
1411 curr->next = stack_top->code->block->next->next->next;
1412 stack_top->code->block->next = curr;
1413 }
1414 }
1415 else
1416 stack_top->code->block->next = curr;
1417 return true;
1418}
1419
1420/* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1421 tries to optimize its block. */
1422
1423static int
1424simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
1425 void *data ATTRIBUTE_UNUSED)
1426{
1427 gfc_code **curr, *prev = NULL;
1428 struct do_stack write, first;
1429 bool b = false;
1430 *walk_subtrees = 1;
1431 if (!(*code)->block
1432 || ((*code)->block->op != EXEC_WRITE
1433 && (*code)->block->op != EXEC_READ))
1434 return 0;
1435
1436 *walk_subtrees = 0;
1437 write.prev = NULL;
1438 write.iter = NULL;
1439 write.code = *code;
1440
1441 for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
1442 {
1443 if ((*curr)->op == EXEC_DO)
1444 {
1445 first.prev = &write;
1446 first.iter = (*curr)->ext.iterator;
1447 first.code = *curr;
1448 stack_top = &first;
1449 traverse_io_block ((*curr)->block->next, &b, prev);
1450 stack_top = NULL;
1451 }
1452 prev = *curr;
1453 }
1454 return 0;
1455}
1456
d88412fc
TK		 1457/* Optimize a namespace, including all contained namespaces.
1458 flag_frontend_optimize and flag_fronend_loop_interchange are
1459 handled separately. */
601d98be
TK		 1460
1461static void
4d42b5cd 1462optimize_namespace (gfc_namespace *ns)
601d98be 1463{
f1abbf69 1464 gfc_namespace *saved_ns = gfc_current_ns;
2757d5ec 1465 current_ns = ns;
f1abbf69 1466 gfc_current_ns = ns;
2855325f 1467 forall_level = 0;
8144d290 1468 iterator_level = 0;
e3f9e757 1469 in_assoc_list = false;
e07e39f6 1470 in_omp_workshare = false;
a7a09efa 1471 in_omp_atomic = false;
2757d5ec 1472
d88412fc 1473 if (flag_frontend_optimize)
0f6ed121 1474 {
d88412fc
TK		 1475 gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
1476 gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
1477 gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
1478 gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
1479 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
998511a6 1480 if (flag_inline_matmul_limit != 0 || flag_external_blas)
0f6ed121 1481 {
d88412fc
TK		 1482 bool found;
1483 do
1484 {
1485 found = false;
1486 gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
1487 (void *) &found);
1488 }
1489 while (found);
bbe3927b 1490
d88412fc
TK		 1491 gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
1492 NULL);
d88412fc 1493 }
998511a6
TK		 1494
1495 if (flag_external_blas)
1496 gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
1497 NULL);
1498
1499 if (flag_inline_matmul_limit != 0)
1500 gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
1501 NULL);
0f6ed121 1502 }
bbe3927b 1503
d88412fc
TK		 1504 if (flag_frontend_loop_interchange)
1505 gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
1506 NULL);
1507
930d4d4e 1508 /* BLOCKs are handled in the expression walker below. */
4d42b5cd 1509 for (ns = ns->contained; ns; ns = ns->sibling)
930d4d4e
TK		 1510 {
1511 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1512 optimize_namespace (ns);
1513 }
f1abbf69 1514 gfc_current_ns = saved_ns;
601d98be
TK		 1515}
1516
8b7cec58
TK		 1517/* Handle dependencies for allocatable strings which potentially redefine
1518 themselves in an assignment. */
1519
1520static void
1521realloc_strings (gfc_namespace *ns)
1522{
1523 current_ns = ns;
1524 gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
1525
1526 for (ns = ns->contained; ns; ns = ns->sibling)
1527 {
1528 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
f1abbf69 1529 realloc_strings (ns);
8b7cec58
TK		 1530 }
1531
1532}
1533
e81e4b43
TK		 1534static void
1535optimize_reduction (gfc_namespace *ns)
1536{
1537 current_ns = ns;
5f23671d
JJ		 1538 gfc_code_walker (&ns->code, gfc_dummy_code_callback,
1539 callback_reduction, NULL);
e81e4b43
TK		 1540
1541/* BLOCKs are handled in the expression walker below. */
1542 for (ns = ns->contained; ns; ns = ns->sibling)
1543 {
1544 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1545 optimize_reduction (ns);
1546 }
1547}
1548
5c599206
TK		 1549/* Replace code like
1550 a = matmul(b,c) + d
1551 with
1552 a = matmul(b,c) ; a = a + d
1553 where the array function is not elemental and not allocatable
1554 and does not depend on the left-hand side.
1555*/
1556
1557static bool
1558optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
1559{
1560 gfc_expr *e;
1561
f1c7e7f1
SK		 1562 if (!*rhs)
1563 return false;
1564
5c599206
TK		 1565 e = *rhs;
1566 if (e->expr_type == EXPR_OP)
1567 {
1568 switch (e->value.op.op)
1569 {
1570 /* Unary operators and exponentiation: Only look at a single
1571 operand. */
1572 case INTRINSIC_NOT:
1573 case INTRINSIC_UPLUS:
1574 case INTRINSIC_UMINUS:
1575 case INTRINSIC_PARENTHESES:
1576 case INTRINSIC_POWER:
1577 if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
1578 return true;
1579 break;
1580
dc2c36fd
TK		 1581 case INTRINSIC_CONCAT:
1582 /* Do not do string concatenations. */
1583 break;
1584
5c599206
TK		 1585 default:
1586 /* Binary operators. */
1587 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
1588 return true;
1589
1590 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
1591 return true;
1592
1593 break;
1594 }
1595 }
1596 else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
7474dcc1
PT		 1597 && ! (e->value.function.esym
1598 && (e->value.function.esym->attr.elemental
962b8a0e
TK		 1599 || e->value.function.esym->attr.allocatable
1600 || e->value.function.esym->ts.type != c->expr1->ts.type
1601 || e->value.function.esym->ts.kind != c->expr1->ts.kind))
1602 && ! (e->value.function.isym
1603 && (e->value.function.isym->elemental
1604 || e->ts.type != c->expr1->ts.type
93ee6382
MM		 1605 || e->ts.kind != c->expr1->ts.kind))
1606 && ! gfc_inline_intrinsic_function_p (e))
5c599206
TK		 1607 {
1608
1609 gfc_code *n;
1610 gfc_expr *new_expr;
1611
1612 /* Insert a new assignment statement after the current one. */
1613 n = XCNEW (gfc_code);
1614 n->op = EXEC_ASSIGN;
1615 n->loc = c->loc;
1616 n->next = c->next;
1617 c->next = n;
1618
1619 n->expr1 = gfc_copy_expr (c->expr1);
1620 n->expr2 = c->expr2;
1621 new_expr = gfc_copy_expr (c->expr1);
1622 c->expr2 = e;
1623 *rhs = new_expr;
7474dcc1 1624
5c599206
TK		 1625 return true;
1626
1627 }
1628
1629 /* Nothing to optimize. */
1630 return false;
1631}
1632
4f21f0da
TK		 1633/* Remove unneeded TRIMs at the end of expressions. */
1634
1635static bool
1636remove_trim (gfc_expr *rhs)
1637{
1638 bool ret;
1639
1640 ret = false;
e5cf1629
SK		 1641 if (!rhs)
1642 return ret;
4f21f0da
TK		 1643
1644 /* Check for a // b // trim(c). Looping is probably not
1645 necessary because the parser usually generates
1646 (// (// a b ) trim(c) ) , but better safe than sorry. */
1647
1648 while (rhs->expr_type == EXPR_OP
1649 && rhs->value.op.op == INTRINSIC_CONCAT)
1650 rhs = rhs->value.op.op2;
1651
1652 while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
1653 && rhs->value.function.isym->id == GFC_ISYM_TRIM)
1654 {
1655 strip_function_call (rhs);
1656 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1657 remove_trim (rhs);
1658 ret = true;
1659 }
1660
1661 return ret;
1662}
1663
601d98be
TK		 1664/* Optimizations for an assignment. */
1665
1666static void
1667optimize_assignment (gfc_code * c)
1668{
1669 gfc_expr *lhs, *rhs;
1670
1671 lhs = c->expr1;
1672 rhs = c->expr2;
1673
0f6bfefd 1674 if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
94d145bf 1675 {
0f6bfefd 1676 /* Optimize a = trim(b) to a = b. */
94d145bf
TK		 1677 remove_trim (rhs);
1678
0f6bfefd 1679 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
524af0d6 1680 if (is_empty_string (rhs))
94d145bf
TK		 1681 rhs->value.character.length = 0;
1682 }
601d98be 1683
5c599206
TK		 1684 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
1685 optimize_binop_array_assignment (c, &rhs, false);
601d98be
TK		 1686}
1687
1688
1689/* Remove an unneeded function call, modifying the expression.
1690 This replaces the function call with the value of its
1691 first argument. The rest of the argument list is freed. */
1692
1693static void
1694strip_function_call (gfc_expr *e)
1695{
1696 gfc_expr *e1;
1697 gfc_actual_arglist *a;
1698
1699 a = e->value.function.actual;
1700
1701 /* We should have at least one argument. */
1702 gcc_assert (a->expr != NULL);
1703
1704 e1 = a->expr;
1705
1706 /* Free the remaining arglist, if any. */
1707 if (a->next)
1708 gfc_free_actual_arglist (a->next);
1709
1710 /* Graft the argument expression onto the original function. */
1711 *e = *e1;
cede9502 1712 free (e1);
601d98be
TK		 1713
1714}
1715
9046a4dc
TK		 1716/* Optimization of lexical comparison functions. */
1717
1718static bool
1719optimize_lexical_comparison (gfc_expr *e)
1720{
1721 if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
1722 return false;
1723
1724 switch (e->value.function.isym->id)
1725 {
1726 case GFC_ISYM_LLE:
1727 return optimize_comparison (e, INTRINSIC_LE);
1728
1729 case GFC_ISYM_LGE:
1730 return optimize_comparison (e, INTRINSIC_GE);
1731
1732 case GFC_ISYM_LGT:
1733 return optimize_comparison (e, INTRINSIC_GT);
1734
1735 case GFC_ISYM_LLT:
1736 return optimize_comparison (e, INTRINSIC_LT);
1737
1738 default:
1739 break;
1740 }
1741 return false;
1742}
1743
4099436d
TK		 1744/* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1745 do CHARACTER because of possible pessimization involving character
1746 lengths. */
1747
1748static bool
1749combine_array_constructor (gfc_expr *e)
1750{
1751
1752 gfc_expr *op1, *op2;
1753 gfc_expr *scalar;
1754 gfc_expr *new_expr;
1755 gfc_constructor *c, *new_c;
1756 gfc_constructor_base oldbase, newbase;
1757 bool scalar_first;
e35ba10a
TK		 1758 int n_elem;
1759 bool all_const;
4099436d
TK		 1760
1761 /* Array constructors have rank one. */
1762 if (e->rank != 1)
1763 return false;
1764
e3f9e757
TK		 1765 /* Don't try to combine association lists, this makes no sense
1766 and leads to an ICE. */
1767 if (in_assoc_list)
1768 return false;
1769
9c3e121b
TK		 1770 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1771 if (forall_level > 0)
1772 return false;
1773
1603ebe0
TK		 1774 /* Inside an iterator, things can get hairy; we are likely to create
1775 an invalid temporary variable. */
1776 if (iterator_level > 0)
1777 return false;
1778
cb40e807
TK		 1779 /* WHERE also doesn't work. */
1780 if (in_where > 0)
1781 return false;
1782
4099436d
TK		 1783 op1 = e->value.op.op1;
1784 op2 = e->value.op.op2;
1785
e5cf1629
SK		 1786 if (!op1 || !op2)
1787 return false;
1788
4099436d
TK		 1789 if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
1790 scalar_first = false;
1791 else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
1792 {
1793 scalar_first = true;
1794 op1 = e->value.op.op2;
1795 op2 = e->value.op.op1;
1796 }
1797 else
1798 return false;
1799
1800 if (op2->ts.type == BT_CHARACTER)
1801 return false;
1802
e35ba10a
TK		 1803 /* This might be an expanded constructor with very many constant values. If
1804 we perform the operation here, we might end up with a long compile time
1805 and actually longer execution time, so a length bound is in order here.
1806 If the constructor constains something which is not a constant, it did
1807 not come from an expansion, so leave it alone. */
1808
1809#define CONSTR_LEN_MAX 4
4099436d
TK		 1810
1811 oldbase = op1->value.constructor;
e35ba10a
TK		 1812
1813 n_elem = 0;
1814 all_const = true;
1815 for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c))
1816 {
1817 if (c->expr->expr_type != EXPR_CONSTANT)
1818 {
1819 all_const = false;
1820 break;
1821 }
1822 n_elem += 1;
1823 }
1824
1825 if (all_const && n_elem > CONSTR_LEN_MAX)
1826 return false;
1827
1828#undef CONSTR_LEN_MAX
1829
4099436d
TK		 1830 newbase = NULL;
1831 e->expr_type = EXPR_ARRAY;
1832
e35ba10a
TK		 1833 scalar = create_var (gfc_copy_expr (op2), "constr");
1834
4099436d
TK		 1835 for (c = gfc_constructor_first (oldbase); c;
1836 c = gfc_constructor_next (c))
1837 {
1838 new_expr = gfc_get_expr ();
1839 new_expr->ts = e->ts;
1840 new_expr->expr_type = EXPR_OP;
1841 new_expr->rank = c->expr->rank;
918b6c9e 1842 new_expr->where = c->expr->where;
4099436d
TK		 1843 new_expr->value.op.op = e->value.op.op;
1844
1845 if (scalar_first)
1846 {
1847 new_expr->value.op.op1 = gfc_copy_expr (scalar);
1848 new_expr->value.op.op2 = gfc_copy_expr (c->expr);
1849 }
1850 else
1851 {
1852 new_expr->value.op.op1 = gfc_copy_expr (c->expr);
1853 new_expr->value.op.op2 = gfc_copy_expr (scalar);
1854 }
1855
1856 new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
1857 new_c->iterator = c->iterator;
1858 c->iterator = NULL;
1859 }
1860
1861 gfc_free_expr (op1);
1862 gfc_free_expr (op2);
36abe895 1863 gfc_free_expr (scalar);
4099436d
TK		 1864
1865 e->value.constructor = newbase;
1866 return true;
1867}
1868
601d98be
TK		 1869/* Recursive optimization of operators. */
1870
1871static bool
1872optimize_op (gfc_expr *e)
1873{
4099436d
TK		 1874 bool changed;
1875
4d42b5cd 1876 gfc_intrinsic_op op = e->value.op.op;
601d98be 1877
4099436d
TK		 1878 changed = false;
1879
eea58adb 1880 /* Only use new-style comparisons. */
91077d4e
TK		 1881 switch(op)
1882 {
1883 case INTRINSIC_EQ_OS:
1884 op = INTRINSIC_EQ;
1885 break;
1886
1887 case INTRINSIC_GE_OS:
1888 op = INTRINSIC_GE;
1889 break;
1890
1891 case INTRINSIC_LE_OS:
1892 op = INTRINSIC_LE;
1893 break;
1894
1895 case INTRINSIC_NE_OS:
1896 op = INTRINSIC_NE;
1897 break;
1898
1899 case INTRINSIC_GT_OS:
1900 op = INTRINSIC_GT;
1901 break;
1902
1903 case INTRINSIC_LT_OS:
1904 op = INTRINSIC_LT;
1905 break;
1906
1907 default:
1908 break;
1909 }
1910
601d98be
TK		 1911 switch (op)
1912 {
1913 case INTRINSIC_EQ:
601d98be 1914 case INTRINSIC_GE:
601d98be 1915 case INTRINSIC_LE:
601d98be 1916 case INTRINSIC_NE:
601d98be 1917 case INTRINSIC_GT:
601d98be 1918 case INTRINSIC_LT:
4099436d
TK		 1919 changed = optimize_comparison (e, op);
1920
81fea426 1921 gcc_fallthrough ();
4099436d
TK		 1922 /* Look at array constructors. */
1923 case INTRINSIC_PLUS:
1924 case INTRINSIC_MINUS:
1925 case INTRINSIC_TIMES:
1926 case INTRINSIC_DIVIDE:
1927 return combine_array_constructor (e) || changed;
601d98be
TK		 1928
1929 default:
1930 break;
1931 }
1932
1933 return false;
1934}
1935
91077d4e
TK		 1936
1937/* Return true if a constant string contains only blanks. */
1938
1939static bool
9771b263 1940is_empty_string (gfc_expr *e)
91077d4e
TK		 1941{
1942 int i;
1943
1944 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1945 return false;
1946
1947 for (i=0; i < e->value.character.length; i++)
1948 {
1949 if (e->value.character.string[i] != ' ')
1950 return false;
1951 }
1952
1953 return true;
1954}
1955
1956
1957/* Insert a call to the intrinsic len_trim. Use a different name for
1958 the symbol tree so we don't run into trouble when the user has
1959 renamed len_trim for some reason. */
1960
1961static gfc_expr*
1962get_len_trim_call (gfc_expr *str, int kind)
1963{
1964 gfc_expr *fcn;
1965 gfc_actual_arglist *actual_arglist, *next;
1966
1967 fcn = gfc_get_expr ();
1968 fcn->expr_type = EXPR_FUNCTION;
1969 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1970 actual_arglist = gfc_get_actual_arglist ();
1971 actual_arglist->expr = str;
1972 next = gfc_get_actual_arglist ();
1973 next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
1974 actual_arglist->next = next;
1975
1976 fcn->value.function.actual = actual_arglist;
1977 fcn->where = str->where;
1978 fcn->ts.type = BT_INTEGER;
1979 fcn->ts.kind = gfc_charlen_int_kind;
1980
1981 gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
1982 fcn->symtree->n.sym->ts = fcn->ts;
1983 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1984 fcn->symtree->n.sym->attr.function = 1;
1985 fcn->symtree->n.sym->attr.elemental = 1;
1986 fcn->symtree->n.sym->attr.referenced = 1;
1987 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
1988 gfc_commit_symbol (fcn->symtree->n.sym);
1989
1990 return fcn;
1991}
1992
2efade53 1993
601d98be
TK		 1994/* Optimize expressions for equality. */
1995
1996static bool
32af57e2 1997optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
601d98be 1998{
601d98be
TK		 1999 gfc_expr *op1, *op2;
2000 bool change;
32af57e2
TK		 2001 int eq;
2002 bool result;
9046a4dc 2003 gfc_actual_arglist *firstarg, *secondarg;
601d98be 2004
9046a4dc
TK		 2005 if (e->expr_type == EXPR_OP)
2006 {
2007 firstarg = NULL;
2008 secondarg = NULL;
2009 op1 = e->value.op.op1;
2010 op2 = e->value.op.op2;
2011 }
2012 else if (e->expr_type == EXPR_FUNCTION)
2013 {
eea58adb 2014 /* One of the lexical comparison functions. */
9046a4dc
TK		 2015 firstarg = e->value.function.actual;
2016 secondarg = firstarg->next;
2017 op1 = firstarg->expr;
2018 op2 = secondarg->expr;
2019 }
2020 else
2021 gcc_unreachable ();
601d98be
TK		 2022
2023 /* Strip off unneeded TRIM calls from string comparisons. */
2024
4f21f0da 2025 change = remove_trim (op1);
601d98be 2026
4f21f0da
TK		 2027 if (remove_trim (op2))
2028 change = true;
601d98be 2029
c0d15a77
MM		 2030 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2031 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2032 handles them well). However, there are also cases that need a non-scalar
2033 argument. For example the any intrinsic. See PR 45380. */
2034 if (e->rank > 0)
4f21f0da 2035 return change;
c0d15a77 2036
91077d4e
TK		 2037 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2038 len_trim(a) != 0 */
2039 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2040 && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
2041 {
2042 bool empty_op1, empty_op2;
9771b263
DN		 2043 empty_op1 = is_empty_string (op1);
2044 empty_op2 = is_empty_string (op2);
91077d4e
TK		 2045
2046 if (empty_op1 || empty_op2)
2047 {
2048 gfc_expr *fcn;
2049 gfc_expr *zero;
2050 gfc_expr *str;
2051
2052 /* This can only happen when an error for comparing
2053 characters of different kinds has already been issued. */
2054 if (empty_op1 && empty_op2)
2055 return false;
2056
2057 zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
2058 str = empty_op1 ? op2 : op1;
2059
2060 fcn = get_len_trim_call (str, gfc_charlen_int_kind);
2061
2062
2063 if (empty_op1)
2064 gfc_free_expr (op1);
2065 else
2066 gfc_free_expr (op2);
2067
2068 op1 = fcn;
2069 op2 = zero;
2070 e->value.op.op1 = fcn;
2071 e->value.op.op2 = zero;
2072 }
2073 }
2074
2075
32af57e2
TK		 2076 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2077
2078 if (flag_finite_math_only
2079 || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
2080 && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
601d98be 2081 {
32af57e2 2082 eq = gfc_dep_compare_expr (op1, op2);
13001f33 2083 if (eq <= -2)
32af57e2
TK		 2084 {
2085 /* Replace A // B < A // C with B < C, and A // B < C // B
2086 with A < C. */
2087 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2ce29890 2088 && op1->expr_type == EXPR_OP
32af57e2 2089 && op1->value.op.op == INTRINSIC_CONCAT
2ce29890 2090 && op2->expr_type == EXPR_OP
32af57e2
TK		 2091 && op2->value.op.op == INTRINSIC_CONCAT)
2092 {
2093 gfc_expr *op1_left = op1->value.op.op1;
2094 gfc_expr *op2_left = op2->value.op.op1;
2095 gfc_expr *op1_right = op1->value.op.op2;
2096 gfc_expr *op2_right = op2->value.op.op2;
2097
2098 if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
2099 {
2100 /* Watch out for 'A ' // x vs. 'A' // x. */
2101
2102 if (op1_left->expr_type == EXPR_CONSTANT
2103 && op2_left->expr_type == EXPR_CONSTANT
2104 && op1_left->value.character.length
2105 != op2_left->value.character.length)
4f21f0da 2106 return change;
32af57e2
TK		 2107 else
2108 {
cede9502
JM		 2109 free (op1_left);
2110 free (op2_left);
9046a4dc
TK		 2111 if (firstarg)
2112 {
2113 firstarg->expr = op1_right;
2114 secondarg->expr = op2_right;
2115 }
2116 else
2117 {
2118 e->value.op.op1 = op1_right;
2119 e->value.op.op2 = op2_right;
2120 }
32af57e2
TK		 2121 optimize_comparison (e, op);
2122 return true;
2123 }
2124 }
2125 if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
2126 {
cede9502
JM		 2127 free (op1_right);
2128 free (op2_right);
9046a4dc
TK		 2129 if (firstarg)
2130 {
2131 firstarg->expr = op1_left;
2132 secondarg->expr = op2_left;
2133 }
2134 else
2135 {
2136 e->value.op.op1 = op1_left;
2137 e->value.op.op2 = op2_left;
2138 }
2139
32af57e2
TK		 2140 optimize_comparison (e, op);
2141 return true;
2142 }
2143 }
2144 }
2145 else
2146 {
2147 /* eq can only be -1, 0 or 1 at this point. */
2148 switch (op)
2149 {
2150 case INTRINSIC_EQ:
32af57e2
TK		 2151 result = eq == 0;
2152 break;
7474dcc1 2153
32af57e2 2154 case INTRINSIC_GE:
32af57e2
TK		 2155 result = eq >= 0;
2156 break;
2157
2158 case INTRINSIC_LE:
32af57e2
TK		 2159 result = eq <= 0;
2160 break;
2161
2162 case INTRINSIC_NE:
32af57e2
TK		 2163 result = eq != 0;
2164 break;
2165
2166 case INTRINSIC_GT:
32af57e2
TK		 2167 result = eq > 0;
2168 break;
2169
2170 case INTRINSIC_LT:
32af57e2
TK		 2171 result = eq < 0;
2172 break;
7474dcc1 2173
32af57e2
TK		 2174 default:
2175 gfc_internal_error ("illegal OP in optimize_comparison");
2176 break;
2177 }
2178
2179 /* Replace the expression by a constant expression. The typespec
2180 and where remains the way it is. */
cede9502
JM		 2181 free (op1);
2182 free (op2);
32af57e2
TK		 2183 e->expr_type = EXPR_CONSTANT;
2184 e->value.logical = result;
2185 return true;
2186 }
601d98be 2187 }
32af57e2 2188
4f21f0da 2189 return change;
601d98be
TK		 2190}
2191
4afeb65c
TK		 2192/* Optimize a trim function by replacing it with an equivalent substring
2193 involving a call to len_trim. This only works for expressions where
2194 variables are trimmed. Return true if anything was modified. */
2195
2196static bool
2197optimize_trim (gfc_expr *e)
2198{
2199 gfc_expr *a;
2200 gfc_ref *ref;
2201 gfc_expr *fcn;
7e3b6543 2202 gfc_ref **rr = NULL;
4afeb65c
TK		 2203
2204 /* Don't do this optimization within an argument list, because
2205 otherwise aliasing issues may occur. */
2206
2207 if (count_arglist != 1)
2208 return false;
2209
2210 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
2211 || e->value.function.isym == NULL
2212 || e->value.function.isym->id != GFC_ISYM_TRIM)
2213 return false;
2214
2215 a = e->value.function.actual->expr;
2216
2217 if (a->expr_type != EXPR_VARIABLE)
2218 return false;
2219
8b7cec58
TK		 2220 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2221
2222 if (a->symtree->n.sym->attr.allocatable)
2223 return false;
2224
7e3b6543
TK		 2225 /* Follow all references to find the correct place to put the newly
2226 created reference. FIXME: Also handle substring references and
2227 array references. Array references cause strange regressions at
2228 the moment. */
2229
4afeb65c
TK		 2230 if (a->ref)
2231 {
7e3b6543
TK		 2232 for (rr = &(a->ref); *rr; rr = &((*rr)->next))
2233 {
2234 if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
2235 return false;
2236 }
4afeb65c 2237 }
4afeb65c 2238
7e3b6543 2239 strip_function_call (e);
4afeb65c 2240
7e3b6543
TK		 2241 if (e->ref == NULL)
2242 rr = &(e->ref);
4afeb65c 2243
7e3b6543 2244 /* Create the reference. */
4afeb65c 2245
7e3b6543
TK		 2246 ref = gfc_get_ref ();
2247 ref->type = REF_SUBSTRING;
4afeb65c 2248
7e3b6543 2249 /* Set the start of the reference. */
4afeb65c 2250
f622221a 2251 ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
4afeb65c 2252
0f6bfefd 2253 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
4afeb65c 2254
f622221a 2255 fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind);
7e3b6543
TK		 2256
2257 /* Set the end of the reference to the call to len_trim. */
2258
2259 ref->u.ss.end = fcn;
efb63364 2260 gcc_assert (rr != NULL && *rr == NULL);
7e3b6543
TK		 2261 *rr = ref;
2262 return true;
4afeb65c
TK		 2263}
2264
d2663912
JJ		 2265/* Optimize minloc(b), where b is rank 1 array, into
2266 (/ minloc(b, dim=1) /), and similarly for maxloc,
2267 as the latter forms are expanded inline. */
2268
2269static void
2270optimize_minmaxloc (gfc_expr **e)
2271{
2272 gfc_expr *fn = *e;
2273 gfc_actual_arglist *a;
2274 char *name, *p;
2275
2276 if (fn->rank != 1
2277 || fn->value.function.actual == NULL
2278 || fn->value.function.actual->expr == NULL
2279 || fn->value.function.actual->expr->rank != 1)
2280 return;
2281
2282 *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
2283 (*e)->shape = fn->shape;
2284 fn->rank = 0;
2285 fn->shape = NULL;
2286 gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
2287
2288 name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
2289 strcpy (name, fn->value.function.name);
2290 p = strstr (name, "loc0");
2291 p[3] = '1';
51f03c6b 2292 fn->value.function.name = gfc_get_string ("%s", name);
d2663912
JJ		 2293 if (fn->value.function.actual->next)
2294 {
2295 a = fn->value.function.actual->next;
2296 gcc_assert (a->expr == NULL);
2297 }
2298 else
2299 {
2300 a = gfc_get_actual_arglist ();
2301 fn->value.function.actual->next = a;
2302 }
2303 a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2304 &fn->where);
2305 mpz_set_ui (a->expr->value.integer, 1);
2306}
2307
305a35da
TK		 2308/* Callback function for code checking that we do not pass a DO variable to an
2309 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2310
2311static int
2312doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
2313 void *data ATTRIBUTE_UNUSED)
2314{
2315 gfc_code *co;
2316 int i;
2317 gfc_formal_arglist *f;
2318 gfc_actual_arglist *a;
6c7069d6 2319 gfc_code *cl;
15e23330
TK		 2320 do_t loop, *lp;
2321 bool seen_goto;
305a35da
TK		 2322
2323 co = *c;
2324
6c7069d6
TK		 2325 /* If the doloop_list grew, we have to truncate it here. */
2326
2327 if ((unsigned) doloop_level < doloop_list.length())
2328 doloop_list.truncate (doloop_level);
2329
15e23330 2330 seen_goto = false;
305a35da
TK		 2331 switch (co->op)
2332 {
2333 case EXEC_DO:
2334
305a35da 2335 if (co->ext.iterator && co->ext.iterator->var)
15e23330 2336 loop.c = co;
305a35da 2337 else
15e23330
TK		 2338 loop.c = NULL;
2339
2340 loop.branch_level = if_level + select_level;
2341 loop.seen_goto = false;
2342 doloop_list.safe_push (loop);
2343 break;
2344
2345 /* If anything could transfer control away from a suspicious
2346 subscript, make sure to set seen_goto in the current DO loop
2347 (if any). */
2348 case EXEC_GOTO:
2349 case EXEC_EXIT:
2350 case EXEC_STOP:
2351 case EXEC_ERROR_STOP:
2352 case EXEC_CYCLE:
2353 seen_goto = true;
2354 break;
2355
2356 case EXEC_OPEN:
2357 if (co->ext.open->err)
2358 seen_goto = true;
2359 break;
2360
2361 case EXEC_CLOSE:
2362 if (co->ext.close->err)
2363 seen_goto = true;
2364 break;
2365
2366 case EXEC_BACKSPACE:
2367 case EXEC_ENDFILE:
2368 case EXEC_REWIND:
2369 case EXEC_FLUSH:
2370
2371 if (co->ext.filepos->err)
2372 seen_goto = true;
2373 break;
2374
2375 case EXEC_INQUIRE:
2376 if (co->ext.filepos->err)
2377 seen_goto = true;
2378 break;
2379
2380 case EXEC_READ:
2381 case EXEC_WRITE:
2382 if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
2383 seen_goto = true;
2384 break;
2385
2386 case EXEC_WAIT:
2387 if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
2388 loop.seen_goto = true;
305a35da
TK		 2389 break;
2390
2391 case EXEC_CALL:
da52ef43
TK		 2392
2393 if (co->resolved_sym == NULL)
2394 break;
2395
4cbc9039 2396 f = gfc_sym_get_dummy_args (co->resolved_sym);
305a35da
TK		 2397
2398 /* Withot a formal arglist, there is only unknown INTENT,
2399 which we don't check for. */
2400 if (f == NULL)
2401 break;
2402
2403 a = co->ext.actual;
2404
2405 while (a && f)
2406 {
15e23330 2407 FOR_EACH_VEC_ELT (doloop_list, i, lp)
305a35da
TK		 2408 {
2409 gfc_symbol *do_sym;
15e23330 2410 cl = lp->c;
7474dcc1 2411
6c7069d6 2412 if (cl == NULL)
305a35da
TK		 2413 break;
2414
6c7069d6 2415 do_sym = cl->ext.iterator->var->symtree->n.sym;
7474dcc1 2416
305a35da
TK		 2417 if (a->expr && a->expr->symtree
2418 && a->expr->symtree->n.sym == do_sym)
2419 {
2420 if (f->sym->attr.intent == INTENT_OUT)
fea70c99
MLI		 2421 gfc_error_now ("Variable %qs at %L set to undefined "
2422 "value inside loop beginning at %L as "
2423 "INTENT(OUT) argument to subroutine %qs",
2424 do_sym->name, &a->expr->where,
15e23330 2425 &(doloop_list[i].c->loc),
fea70c99 2426 co->symtree->n.sym->name);
305a35da 2427 else if (f->sym->attr.intent == INTENT_INOUT)
fea70c99
MLI		 2428 gfc_error_now ("Variable %qs at %L not definable inside "
2429 "loop beginning at %L as INTENT(INOUT) "
2430 "argument to subroutine %qs",
2431 do_sym->name, &a->expr->where,
15e23330 2432 &(doloop_list[i].c->loc),
fea70c99 2433 co->symtree->n.sym->name);
305a35da
TK		 2434 }
2435 }
2436 a = a->next;
2437 f = f->next;
2438 }
2439 break;
2440
2441 default:
2442 break;
2443 }
15e23330
TK		 2444 if (seen_goto && doloop_level > 0)
2445 doloop_list[doloop_level-1].seen_goto = true;
2446
305a35da
TK		 2447 return 0;
2448}
2449
15e23330 2450/* Callback function to warn about different things within DO loops. */
305a35da
TK		 2451
2452static int
2453do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2454 void *data ATTRIBUTE_UNUSED)
15e23330
TK		 2455{
2456 do_t *last;
2457
2458 if (doloop_list.length () == 0)
2459 return 0;
2460
2461 if ((*e)->expr_type == EXPR_FUNCTION)
2462 do_intent (e);
2463
2464 last = &doloop_list.last();
2465 if (last->seen_goto && !warn_do_subscript)
2466 return 0;
2467
2468 if ((*e)->expr_type == EXPR_VARIABLE)
2469 do_subscript (e);
2470
2471 return 0;
2472}
2473
2474typedef struct
2475{
2476 gfc_symbol *sym;
2477 mpz_t val;
2478} insert_index_t;
2479
2480/* Callback function - if the expression is the variable in data->sym,
2481 replace it with a constant from data->val. */
2482
2483static int
2484callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2485 void *data)
2486{
2487 insert_index_t *d;
2488 gfc_expr *ex, *n;
2489
2490 ex = (*e);
2491 if (ex->expr_type != EXPR_VARIABLE)
2492 return 0;
2493
2494 d = (insert_index_t *) data;
2495 if (ex->symtree->n.sym != d->sym)
2496 return 0;
2497
2498 n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
2499 mpz_set (n->value.integer, d->val);
2500
2501 gfc_free_expr (ex);
2502 *e = n;
2503 return 0;
2504}
2505
2506/* In the expression e, replace occurrences of the variable sym with
2507 val. If this results in a constant expression, return true and
2508 return the value in ret. Return false if the expression already
2509 is a constant. Caller has to clear ret in that case. */
2510
2511static bool
2512insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
2513{
2514 gfc_expr *n;
2515 insert_index_t data;
2516 bool rc;
2517
2518 if (e->expr_type == EXPR_CONSTANT)
2519 return false;
2520
2521 n = gfc_copy_expr (e);
2522 data.sym = sym;
2523 mpz_init_set (data.val, val);
2524 gfc_expr_walker (&n, callback_insert_index, (void *) &data);
35ca2d4e
TK		 2525
2526 /* Suppress errors here - we could get errors here such as an
2527 out of bounds access for arrays, see PR 90563. */
2528 gfc_push_suppress_errors ();
15e23330 2529 gfc_simplify_expr (n, 0);
35ca2d4e 2530 gfc_pop_suppress_errors ();
15e23330
TK		 2531
2532 if (n->expr_type == EXPR_CONSTANT)
2533 {
2534 rc = true;
2535 mpz_init_set (ret, n->value.integer);
2536 }
2537 else
2538 rc = false;
2539
2540 mpz_clear (data.val);
2541 gfc_free_expr (n);
2542 return rc;
2543
2544}
2545
2546/* Check array subscripts for possible out-of-bounds accesses in DO
2547 loops with constant bounds. */
2548
2549static int
2550do_subscript (gfc_expr **e)
2551{
2552 gfc_expr *v;
2553 gfc_array_ref *ar;
2554 gfc_ref *ref;
2555 int i,j;
2556 gfc_code *dl;
2557 do_t *lp;
2558
2559 v = *e;
2560 /* Constants are already checked. */
2561 if (v->expr_type == EXPR_CONSTANT)
2562 return 0;
2563
885b8230
TK		 2564 /* Wrong warnings will be generated in an associate list. */
2565 if (in_assoc_list)
2566 return 0;
2567
393fdeb1
TK		 2568 /* We already warned about this. */
2569 if (v->do_not_warn)
2570 return 0;
2571
2572 v->do_not_warn = 1;
2573
15e23330
TK		 2574 for (ref = v->ref; ref; ref = ref->next)
2575 {
2576 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
2577 {
2578 ar = & ref->u.ar;
2579 FOR_EACH_VEC_ELT (doloop_list, j, lp)
2580 {
2581 gfc_symbol *do_sym;
2582 mpz_t do_start, do_step, do_end;
2583 bool have_do_start, have_do_end;
2584 bool error_not_proven;
2585 int warn;
3e0679c8 2586 int sgn;
15e23330
TK		 2587
2588 dl = lp->c;
2589 if (dl == NULL)
2590 break;
2591
2592 /* If we are within a branch, or a goto or equivalent
2593 was seen in the DO loop before, then we cannot prove that
2594 this expression is actually evaluated. Don't do anything
2595 unless we want to see it all. */
2596 error_not_proven = lp->seen_goto
2597 || lp->branch_level < if_level + select_level;
2598
2599 if (error_not_proven && !warn_do_subscript)
2600 break;
2601
2602 if (error_not_proven)
2603 warn = OPT_Wdo_subscript;
2604 else
2605 warn = 0;
2606
2607 do_sym = dl->ext.iterator->var->symtree->n.sym;
2608 if (do_sym->ts.type != BT_INTEGER)
2609 continue;
2610
2611 /* If we do not know about the stepsize, the loop may be zero trip.
2612 Do not warn in this case. */
2efade53 2613
15e23330 2614 if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
3e0679c8
TK		 2615 {
2616 sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
2617 /* This can happen, but then the error has been
2618 reported previously. */
2619 if (sgn == 0)
2620 continue;
2621
2622 mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
2623 }
2624
15e23330
TK		 2625 else
2626 continue;
2627
2628 if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
2629 {
2630 have_do_start = true;
2631 mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
2632 }
2633 else
2634 have_do_start = false;
2635
15e23330
TK		 2636 if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
2637 {
2638 have_do_end = true;
2639 mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
2640 }
2641 else
2642 have_do_end = false;
2643
2644 if (!have_do_start && !have_do_end)
2645 return 0;
2646
393fdeb1
TK		 2647 /* No warning inside a zero-trip loop. */
2648 if (have_do_start && have_do_end)
2649 {
3e0679c8 2650 int cmp;
393fdeb1 2651
393fdeb1
TK		 2652 cmp = mpz_cmp (do_end, do_start);
2653 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
2654 break;
2655 }
2656
15e23330
TK		 2657 /* May have to correct the end value if the step does not equal
2658 one. */
2659 if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
2660 {
2661 mpz_t diff, rem;
2662
2663 mpz_init (diff);
2664 mpz_init (rem);
2665 mpz_sub (diff, do_end, do_start);
2666 mpz_tdiv_r (rem, diff, do_step);
2667 mpz_sub (do_end, do_end, rem);
2668 mpz_clear (diff);
2669 mpz_clear (rem);
2670 }
2671
2672 for (i = 0; i< ar->dimen; i++)
2673 {
2674 mpz_t val;
2675 if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
2676 && insert_index (ar->start[i], do_sym, do_start, val))
2677 {
2678 if (ar->as->lower[i]
2679 && ar->as->lower[i]->expr_type == EXPR_CONSTANT
2680 && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2681 gfc_warning (warn, "Array reference at %L out of bounds "
2682 "(%ld < %ld) in loop beginning at %L",
2683 &ar->start[i]->where, mpz_get_si (val),
2684 mpz_get_si (ar->as->lower[i]->value.integer),
2685 &doloop_list[j].c->loc);
2686
2687 if (ar->as->upper[i]
2688 && ar->as->upper[i]->expr_type == EXPR_CONSTANT
2689 && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2690 gfc_warning (warn, "Array reference at %L out of bounds "
2691 "(%ld > %ld) in loop beginning at %L",
2692 &ar->start[i]->where, mpz_get_si (val),
2693 mpz_get_si (ar->as->upper[i]->value.integer),
2694 &doloop_list[j].c->loc);
2695
2696 mpz_clear (val);
2697 }
2698
2699 if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
2700 && insert_index (ar->start[i], do_sym, do_end, val))
2701 {
2702 if (ar->as->lower[i]
2703 && ar->as->lower[i]->expr_type == EXPR_CONSTANT
2704 && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2705 gfc_warning (warn, "Array reference at %L out of bounds "
2706 "(%ld < %ld) in loop beginning at %L",
2707 &ar->start[i]->where, mpz_get_si (val),
2708 mpz_get_si (ar->as->lower[i]->value.integer),
2709 &doloop_list[j].c->loc);
2710
2711 if (ar->as->upper[i]
2712 && ar->as->upper[i]->expr_type == EXPR_CONSTANT
2713 && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2714 gfc_warning (warn, "Array reference at %L out of bounds "
2715 "(%ld > %ld) in loop beginning at %L",
2716 &ar->start[i]->where, mpz_get_si (val),
2717 mpz_get_si (ar->as->upper[i]->value.integer),
2718 &doloop_list[j].c->loc);
2719
2720 mpz_clear (val);
2721 }
2722 }
2723 }
2724 }
2725 }
2726 return 0;
2727}
2728/* Function for functions checking that we do not pass a DO variable
2729 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2730
2731static int
2732do_intent (gfc_expr **e)
305a35da
TK		 2733{
2734 gfc_formal_arglist *f;
2735 gfc_actual_arglist *a;
2736 gfc_expr *expr;
6c7069d6 2737 gfc_code *dl;
15e23330 2738 do_t *lp;
305a35da
TK		 2739 int i;
2740
2741 expr = *e;
2742 if (expr->expr_type != EXPR_FUNCTION)
2743 return 0;
2744
2745 /* Intrinsic functions don't modify their arguments. */
2746
2747 if (expr->value.function.isym)
2748 return 0;
2749
4cbc9039 2750 f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
305a35da
TK		 2751
2752 /* Without a formal arglist, there is only unknown INTENT,
2753 which we don't check for. */
2754 if (f == NULL)
2755 return 0;
2756
2757 a = expr->value.function.actual;
2758
2759 while (a && f)
2760 {
15e23330 2761 FOR_EACH_VEC_ELT (doloop_list, i, lp)
305a35da
TK		 2762 {
2763 gfc_symbol *do_sym;
15e23330 2764 dl = lp->c;
6c7069d6 2765 if (dl == NULL)
305a35da
TK		 2766 break;
2767
6c7069d6 2768 do_sym = dl->ext.iterator->var->symtree->n.sym;
7474dcc1 2769
305a35da
TK		 2770 if (a->expr && a->expr->symtree
2771 && a->expr->symtree->n.sym == do_sym)
2772 {
2773 if (f->sym->attr.intent == INTENT_OUT)
fea70c99
MLI		 2774 gfc_error_now ("Variable %qs at %L set to undefined value "
2775 "inside loop beginning at %L as INTENT(OUT) "
2776 "argument to function %qs", do_sym->name,
15e23330 2777 &a->expr->where, &doloop_list[i].c->loc,
fea70c99 2778 expr->symtree->n.sym->name);
305a35da 2779 else if (f->sym->attr.intent == INTENT_INOUT)
fea70c99
MLI		 2780 gfc_error_now ("Variable %qs at %L not definable inside loop"
2781 " beginning at %L as INTENT(INOUT) argument to"
2782 " function %qs", do_sym->name,
15e23330 2783 &a->expr->where, &doloop_list[i].c->loc,
fea70c99 2784 expr->symtree->n.sym->name);
305a35da
TK		 2785 }
2786 }
2787 a = a->next;
2788 f = f->next;
2789 }
2790
2791 return 0;
2792}
2793
2794static void
2795doloop_warn (gfc_namespace *ns)
2796{
2797 gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
393fdeb1
TK		 2798
2799 for (ns = ns->contained; ns; ns = ns->sibling)
2800 {
2801 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
2802 doloop_warn (ns);
2803 }
305a35da
TK		 2804}
2805
f1abbf69
TK		 2806/* This selction deals with inlining calls to MATMUL. */
2807
0f6ed121
TK		 2808/* Replace calls to matmul outside of straight assignments with a temporary
2809 variable so that later inlining will work. */
2810
2811static int
2812matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
2813 void *data)
2814{
2815 gfc_expr *e, *n;
2816 bool *found = (bool *) data;
2efade53 2817
0f6ed121
TK		 2818 e = *ep;
2819
2820 if (e->expr_type != EXPR_FUNCTION
2821 || e->value.function.isym == NULL
2822 || e->value.function.isym->id != GFC_ISYM_MATMUL)
2823 return 0;
2824
2825 if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
a7a09efa 2826 || in_omp_atomic || in_where || in_assoc_list)
0f6ed121
TK		 2827 return 0;
2828
2829 /* Check if this is already in the form c = matmul(a,b). */
2efade53 2830
0f6ed121
TK		 2831 if ((*current_code)->expr2 == e)
2832 return 0;
2833
2834 n = create_var (e, "matmul");
2efade53 2835
0f6ed121
TK		 2836 /* If create_var is unable to create a variable (for example if
2837 -fno-realloc-lhs is in force with a variable that does not have bounds
2838 known at compile-time), just return. */
2839
2840 if (n == NULL)
2841 return 0;
2efade53 2842
0f6ed121
TK		 2843 *ep = n;
2844 *found = true;
2845 return 0;
2846}
2847
2848/* Set current_code and associated variables so that matmul_to_var_expr can
2849 work. */
2850
2851static int
2852matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
2853 void *data ATTRIBUTE_UNUSED)
2854{
2855 if (current_code != c)
2856 {
2857 current_code = c;
2858 inserted_block = NULL;
2859 changed_statement = NULL;
2860 }
2efade53 2861
0f6ed121
TK		 2862 return 0;
2863}
2864
2865
bbe3927b
TK		 2866/* Take a statement of the shape c = matmul(a,b) and create temporaries
2867 for a and b if there is a dependency between the arguments and the
2868 result variable or if a or b are the result of calculations that cannot
2869 be handled by the inliner. */
2870
2871static int
2872matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
2873 void *data ATTRIBUTE_UNUSED)
2874{
2875 gfc_expr *expr1, *expr2;
2876 gfc_code *co;
2877 gfc_actual_arglist *a, *b;
2878 bool a_tmp, b_tmp;
2879 gfc_expr *matrix_a, *matrix_b;
2880 bool conjg_a, conjg_b, transpose_a, transpose_b;
2efade53 2881
bbe3927b
TK		 2882 co = *c;
2883
2884 if (co->op != EXEC_ASSIGN)
2885 return 0;
2886
2887 if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
a7a09efa 2888 || in_omp_atomic || in_where)
bbe3927b
TK		 2889 return 0;
2890
2891 /* This has some duplication with inline_matmul_assign. This
2892 is because the creation of temporary variables could still fail,
2893 and inline_matmul_assign still needs to be able to handle these
2894 cases. */
2895 expr1 = co->expr1;
2896 expr2 = co->expr2;
2897
2898 if (expr2->expr_type != EXPR_FUNCTION
2899 || expr2->value.function.isym == NULL
2900 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
2901 return 0;
2902
2903 a_tmp = false;
2904 a = expr2->value.function.actual;
2905 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
2906 if (matrix_a != NULL)
2907 {
2908 if (matrix_a->expr_type == EXPR_VARIABLE
2909 && (gfc_check_dependency (matrix_a, expr1, true)
1585b483 2910 || gfc_has_dimen_vector_ref (matrix_a)))
bbe3927b
TK		 2911 a_tmp = true;
2912 }
2913 else
2914 a_tmp = true;
2915
2916 b_tmp = false;
2917 b = a->next;
2918 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
2919 if (matrix_b != NULL)
2920 {
2921 if (matrix_b->expr_type == EXPR_VARIABLE
2922 && (gfc_check_dependency (matrix_b, expr1, true)
1585b483 2923 || gfc_has_dimen_vector_ref (matrix_b)))
bbe3927b
TK		 2924 b_tmp = true;
2925 }
2926 else
2927 b_tmp = true;
2928
2929 if (!a_tmp && !b_tmp)
2930 return 0;
2efade53 2931
bbe3927b
TK		 2932 current_code = c;
2933 inserted_block = NULL;
2934 changed_statement = NULL;
2935 if (a_tmp)
2936 {
2937 gfc_expr *at;
2938 at = create_var (a->expr,"mma");
2939 if (at)
2940 a->expr = at;
2941 }
2942 if (b_tmp)
2943 {
2944 gfc_expr *bt;
2945 bt = create_var (b->expr,"mmb");
2946 if (bt)
2947 b->expr = bt;
2948 }
2949 return 0;
2950}
2951
f1abbf69
TK		 2952/* Auxiliary function to build and simplify an array inquiry function.
2953 dim is zero-based. */
2954
2955static gfc_expr *
998511a6 2956get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
f1abbf69
TK		 2957{
2958 gfc_expr *fcn;
2959 gfc_expr *dim_arg, *kind;
2960 const char *name;
2961 gfc_expr *ec;
2962
2963 switch (id)
2964 {
2965 case GFC_ISYM_LBOUND:
2966 name = "_gfortran_lbound";
2967 break;
2968
2969 case GFC_ISYM_UBOUND:
2970 name = "_gfortran_ubound";
2971 break;
2972
2973 case GFC_ISYM_SIZE:
2974 name = "_gfortran_size";
2975 break;
2976
2977 default:
2978 gcc_unreachable ();
2979 }
2980
2981 dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
998511a6
TK		 2982 if (okind != 0)
2983 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
2984 okind);
2985 else
2986 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
2987 gfc_index_integer_kind);
f1abbf69
TK		 2988
2989 ec = gfc_copy_expr (e);
980fa45e
TK		 2990
2991 /* No bounds checking, this will be done before the loops if -fcheck=bounds
2992 is in effect. */
2993 ec->no_bounds_check = 1;
f1abbf69
TK		 2994 fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
2995 ec, dim_arg, kind);
2996 gfc_simplify_expr (fcn, 0);
980fa45e 2997 fcn->no_bounds_check = 1;
f1abbf69
TK		 2998 return fcn;
2999}
3000
3001/* Builds a logical expression. */
3002
3003static gfc_expr*
3004build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3005{
3006 gfc_typespec ts;
3007 gfc_expr *res;
3008
3009 ts.type = BT_LOGICAL;
3010 ts.kind = gfc_default_logical_kind;
3011 res = gfc_get_expr ();
3012 res->where = e1->where;
3013 res->expr_type = EXPR_OP;
3014 res->value.op.op = op;
3015 res->value.op.op1 = e1;
3016 res->value.op.op2 = e2;
3017 res->ts = ts;
3018
3019 return res;
3020}
3021
3022
3023/* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3024 compatible typespecs. */
3025
3026static gfc_expr *
3027get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3028{
3029 gfc_expr *res;
3030
3031 res = gfc_get_expr ();
3032 res->ts = e1->ts;
3033 res->where = e1->where;
3034 res->expr_type = EXPR_OP;
3035 res->value.op.op = op;
3036 res->value.op.op1 = e1;
3037 res->value.op.op2 = e2;
3038 gfc_simplify_expr (res, 0);
3039 return res;
3040}
3041
3042/* Generate the IF statement for a runtime check if we want to do inlining or
3043 not - putting in the code for both branches and putting it into the syntax
3044 tree is the caller's responsibility. For fixed array sizes, this should be
3045 removed by DCE. Only called for rank-two matrices A and B. */
3046
3047static gfc_code *
998511a6 3048inline_limit_check (gfc_expr *a, gfc_expr *b, int limit)
f1abbf69
TK		 3049{
3050 gfc_expr *inline_limit;
3051 gfc_code *if_1, *if_2, *else_2;
3052 gfc_expr *b2, *a2, *a1, *m1, *m2;
3053 gfc_typespec ts;
3054 gfc_expr *cond;
3055
f1abbf69
TK		 3056 /* Calculation is done in real to avoid integer overflow. */
3057
3058 inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
3059 &a->where);
998511a6 3060 mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE);
f1abbf69
TK		 3061 mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, 3,
3062 GFC_RND_MODE);
3063
3064 a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3065 a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3066 b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3067
3068 gfc_clear_ts (&ts);
3069 ts.type = BT_REAL;
3070 ts.kind = gfc_default_real_kind;
3071 gfc_convert_type_warn (a1, &ts, 2, 0);
3072 gfc_convert_type_warn (a2, &ts, 2, 0);
3073 gfc_convert_type_warn (b2, &ts, 2, 0);
3074
3075 m1 = get_operand (INTRINSIC_TIMES, a1, a2);
3076 m2 = get_operand (INTRINSIC_TIMES, m1, b2);
3077
3078 cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
3079 gfc_simplify_expr (cond, 0);
3080
3081 else_2 = XCNEW (gfc_code);
3082 else_2->op = EXEC_IF;
3083 else_2->loc = a->where;
3084
3085 if_2 = XCNEW (gfc_code);
3086 if_2->op = EXEC_IF;
3087 if_2->expr1 = cond;
3088 if_2->loc = a->where;
3089 if_2->block = else_2;
3090
3091 if_1 = XCNEW (gfc_code);
3092 if_1->op = EXEC_IF;
3093 if_1->block = if_2;
3094 if_1->loc = a->where;
3095
3096 return if_1;
3097}
3098
3099
3100/* Insert code to issue a runtime error if the expressions are not equal. */
3101
3102static gfc_code *
3103runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
3104{
3105 gfc_expr *cond;
3106 gfc_code *if_1, *if_2;
3107 gfc_code *c;
3108 gfc_actual_arglist *a1, *a2, *a3;
3109
3110 gcc_assert (e1->where.lb);
3111 /* Build the call to runtime_error. */
3112 c = XCNEW (gfc_code);
3113 c->op = EXEC_CALL;
3114 c->loc = e1->where;
3115
3116 /* Get a null-terminated message string. */
3117
3118 a1 = gfc_get_actual_arglist ();
3119 a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
3120 msg, strlen(msg)+1);
3121 c->ext.actual = a1;
3122
3123 /* Pass the value of the first expression. */
3124 a2 = gfc_get_actual_arglist ();
3125 a2->expr = gfc_copy_expr (e1);
3126 a1->next = a2;
3127
3128 /* Pass the value of the second expression. */
3129 a3 = gfc_get_actual_arglist ();
3130 a3->expr = gfc_copy_expr (e2);
3131 a2->next = a3;
3132
3133 gfc_check_fe_runtime_error (c->ext.actual);
3134 gfc_resolve_fe_runtime_error (c);
3135
3136 if_2 = XCNEW (gfc_code);
3137 if_2->op = EXEC_IF;
3138 if_2->loc = e1->where;
3139 if_2->next = c;
3140
3141 if_1 = XCNEW (gfc_code);
3142 if_1->op = EXEC_IF;
3143 if_1->block = if_2;
3144 if_1->loc = e1->where;
3145
3146 cond = build_logical_expr (INTRINSIC_NE, e1, e2);
3147 gfc_simplify_expr (cond, 0);
3148 if_2->expr1 = cond;
3149
3150 return if_1;
3151}
3152
3153/* Handle matrix reallocation. Caller is responsible to insert into
3154 the code tree.
3155
7474dcc1 3156 For the two-dimensional case, build
f1abbf69
TK		 3157
3158 if (allocated(c)) then
3159 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3160 deallocate(c)
3161 allocate (c(size(a,1), size(b,2)))
3162 end if
3163 else
3164 allocate (c(size(a,1),size(b,2)))
3165 end if
3166
3167 and for the other cases correspondingly.
3168*/
3169
3170static gfc_code *
3171matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
3172 enum matrix_case m_case)
3173{
3174
3175 gfc_expr *allocated, *alloc_expr;
3176 gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
3177 gfc_code *else_alloc;
3178 gfc_code *deallocate, *allocate1, *allocate_else;
3179 gfc_array_ref *ar;
3180 gfc_expr *cond, *ne1, *ne2;
3181
3182 if (warn_realloc_lhs)
3183 gfc_warning (OPT_Wrealloc_lhs,
3184 "Code for reallocating the allocatable array at %L will "
3185 "be added", &c->where);
3186
3187 alloc_expr = gfc_copy_expr (c);
3188
3189 ar = gfc_find_array_ref (alloc_expr);
3190 gcc_assert (ar && ar->type == AR_FULL);
3191
3192 /* c comes in as a full ref. Change it into a copy and make it into an
700d4cb0 3193 element ref so it has the right form for ALLOCATE. In the same
f1abbf69
TK		 3194 switch statement, also generate the size comparison for the secod IF
3195 statement. */
3196
3197 ar->type = AR_ELEMENT;
3198
3199 switch (m_case)
3200 {
3201 case A2B2:
3202 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3203 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3204 ne1 = build_logical_expr (INTRINSIC_NE,
3205 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3206 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3207 ne2 = build_logical_expr (INTRINSIC_NE,
3208 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3209 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3210 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3211 break;
3212
094773e8
TK		 3213 case A2B2T:
3214 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3215 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
3216
3217 ne1 = build_logical_expr (INTRINSIC_NE,
3218 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3219 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3220 ne2 = build_logical_expr (INTRINSIC_NE,
3221 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3222 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
3223 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
a220f43d 3224 break;
094773e8 3225
610abc02
TK		 3226 case A2TB2:
3227
3228 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3229 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3230
3231 ne1 = build_logical_expr (INTRINSIC_NE,
3232 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3233 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3234 ne2 = build_logical_expr (INTRINSIC_NE,
3235 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3236 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3237 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3238 break;
3239
f1abbf69
TK		 3240 case A2B1:
3241 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3242 cond = build_logical_expr (INTRINSIC_NE,
3243 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3244 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3245 break;
3246
3247 case A1B2:
8364e6ac 3248 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
f1abbf69
TK		 3249 cond = build_logical_expr (INTRINSIC_NE,
3250 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3251 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3252 break;
3253
998511a6
TK		 3254 case A2TB2T:
3255 /* This can only happen for BLAS, we do not handle that case in
3256 inline mamtul. */
3257 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3258 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
3259
3260 ne1 = build_logical_expr (INTRINSIC_NE,
3261 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3262 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3263 ne2 = build_logical_expr (INTRINSIC_NE,
3264 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3265 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
3266
3267 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3268 break;
3269
f1abbf69
TK		 3270 default:
3271 gcc_unreachable();
3272
3273 }
3274
3275 gfc_simplify_expr (cond, 0);
3276
3277 /* We need two identical allocate statements in two
3278 branches of the IF statement. */
7474dcc1 3279
f1abbf69
TK		 3280 allocate1 = XCNEW (gfc_code);
3281 allocate1->op = EXEC_ALLOCATE;
3282 allocate1->ext.alloc.list = gfc_get_alloc ();
3283 allocate1->loc = c->where;
3284 allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
3285
3286 allocate_else = XCNEW (gfc_code);
3287 allocate_else->op = EXEC_ALLOCATE;
3288 allocate_else->ext.alloc.list = gfc_get_alloc ();
3289 allocate_else->loc = c->where;
3290 allocate_else->ext.alloc.list->expr = alloc_expr;
3291
3292 allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
3293 "_gfortran_allocated", c->where,
3294 1, gfc_copy_expr (c));
3295
3296 deallocate = XCNEW (gfc_code);
3297 deallocate->op = EXEC_DEALLOCATE;
3298 deallocate->ext.alloc.list = gfc_get_alloc ();
3299 deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
3300 deallocate->next = allocate1;
3301 deallocate->loc = c->where;
7474dcc1 3302
f1abbf69
TK		 3303 if_size_2 = XCNEW (gfc_code);
3304 if_size_2->op = EXEC_IF;
3305 if_size_2->expr1 = cond;
3306 if_size_2->loc = c->where;
3307 if_size_2->next = deallocate;
3308
3309 if_size_1 = XCNEW (gfc_code);
3310 if_size_1->op = EXEC_IF;
3311 if_size_1->block = if_size_2;
3312 if_size_1->loc = c->where;
3313
3314 else_alloc = XCNEW (gfc_code);
3315 else_alloc->op = EXEC_IF;
3316 else_alloc->loc = c->where;
3317 else_alloc->next = allocate_else;
3318
3319 if_alloc_2 = XCNEW (gfc_code);
3320 if_alloc_2->op = EXEC_IF;
3321 if_alloc_2->expr1 = allocated;
3322 if_alloc_2->loc = c->where;
3323 if_alloc_2->next = if_size_1;
3324 if_alloc_2->block = else_alloc;
3325
3326 if_alloc_1 = XCNEW (gfc_code);
3327 if_alloc_1->op = EXEC_IF;
3328 if_alloc_1->block = if_alloc_2;
3329 if_alloc_1->loc = c->where;
3330
3331 return if_alloc_1;
3332}
3333
3334/* Callback function for has_function_or_op. */
3335
3336static int
3337is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
3338 void *data ATTRIBUTE_UNUSED)
3339{
3340 if ((*e) == 0)
3341 return 0;
3342 else
3343 return (*e)->expr_type == EXPR_FUNCTION
3344 || (*e)->expr_type == EXPR_OP;
3345}
3346
3347/* Returns true if the expression contains a function. */
3348
3349static bool
3350has_function_or_op (gfc_expr **e)
3351{
3352 if (e == NULL)
3353 return false;
3354 else
3355 return gfc_expr_walker (e, is_function_or_op, NULL);
3356}
3357
3358/* Freeze (assign to a temporary variable) a single expression. */
3359
3360static void
3361freeze_expr (gfc_expr **ep)
3362{
3363 gfc_expr *ne;
3364 if (has_function_or_op (ep))
3365 {
3366 ne = create_var (*ep, "freeze");
3367 *ep = ne;
3368 }
3369}
3370
3371/* Go through an expression's references and assign them to temporary
3372 variables if they contain functions. This is usually done prior to
3373 front-end scalarization to avoid multiple invocations of functions. */
3374
3375static void
3376freeze_references (gfc_expr *e)
3377{
3378 gfc_ref *r;
3379 gfc_array_ref *ar;
3380 int i;
3381
3382 for (r=e->ref; r; r=r->next)
3383 {
3384 if (r->type == REF_SUBSTRING)
3385 {
3386 if (r->u.ss.start != NULL)
3387 freeze_expr (&r->u.ss.start);
3388
3389 if (r->u.ss.end != NULL)
3390 freeze_expr (&r->u.ss.end);
3391 }
3392 else if (r->type == REF_ARRAY)
3393 {
3394 ar = &r->u.ar;
3395 switch (ar->type)
3396 {
3397 case AR_FULL:
3398 break;
3399
3400 case AR_SECTION:
3401 for (i=0; i<ar->dimen; i++)
3402 {
3403 if (ar->dimen_type[i] == DIMEN_RANGE)
3404 {
3405 freeze_expr (&ar->start[i]);
3406 freeze_expr (&ar->end[i]);
3407 freeze_expr (&ar->stride[i]);
3408 }
3409 else if (ar->dimen_type[i] == DIMEN_ELEMENT)
3410 {
3411 freeze_expr (&ar->start[i]);
3412 }
3413 }
3414 break;
3415
3416 case AR_ELEMENT:
3417 for (i=0; i<ar->dimen; i++)
3418 freeze_expr (&ar->start[i]);
3419 break;
3420
3421 default:
3422 break;
3423 }
3424 }
3425 }
3426}
3427
3428/* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3429
3430static gfc_expr *
3431convert_to_index_kind (gfc_expr *e)
3432{
3433 gfc_expr *res;
3434
3435 gcc_assert (e != NULL);
3436
3437 res = gfc_copy_expr (e);
3438
3439 gcc_assert (e->ts.type == BT_INTEGER);
3440
3441 if (res->ts.kind != gfc_index_integer_kind)
3442 {
3443 gfc_typespec ts;
3444 gfc_clear_ts (&ts);
3445 ts.type = BT_INTEGER;
3446 ts.kind = gfc_index_integer_kind;
3447
3448 gfc_convert_type_warn (e, &ts, 2, 0);
3449 }
3450
3451 return res;
3452}
3453
3454/* Function to create a DO loop including creation of the
3455 iteration variable. gfc_expr are copied.*/
3456
3457static gfc_code *
3458create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
3459 gfc_namespace *ns, char *vname)
3460{
3461
3462 char name[GFC_MAX_SYMBOL_LEN +1];
3463 gfc_symtree *symtree;
3464 gfc_symbol *symbol;
3465 gfc_expr *i;
3466 gfc_code *n, *n2;
3467
3468 /* Create an expression for the iteration variable. */
3469 if (vname)
3470 sprintf (name, "__var_%d_do_%s", var_num++, vname);
3471 else
3472 sprintf (name, "__var_%d_do", var_num++);
3473
3474
3475 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
3476 gcc_unreachable ();
3477
3478 /* Create the loop variable. */
3479
3480 symbol = symtree->n.sym;
3481 symbol->ts.type = BT_INTEGER;
3482 symbol->ts.kind = gfc_index_integer_kind;
3483 symbol->attr.flavor = FL_VARIABLE;
3484 symbol->attr.referenced = 1;
3485 symbol->attr.dimension = 0;
3486 symbol->attr.fe_temp = 1;
3487 gfc_commit_symbol (symbol);
3488
3489 i = gfc_get_expr ();
3490 i->expr_type = EXPR_VARIABLE;
3491 i->ts = symbol->ts;
3492 i->rank = 0;
3493 i->where = *where;
3494 i->symtree = symtree;
3495
3496 /* ... and the nested DO statements. */
3497 n = XCNEW (gfc_code);
3498 n->op = EXEC_DO;
3499 n->loc = *where;
3500 n->ext.iterator = gfc_get_iterator ();
3501 n->ext.iterator->var = i;
3502 n->ext.iterator->start = convert_to_index_kind (start);
3503 n->ext.iterator->end = convert_to_index_kind (end);
3504 if (step)
3505 n->ext.iterator->step = convert_to_index_kind (step);
3506 else
3507 n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
3508 where, 1);
3509
3510 n2 = XCNEW (gfc_code);
3511 n2->op = EXEC_DO;
3512 n2->loc = *where;
3513 n2->next = NULL;
3514 n->block = n2;
3515 return n;
3516}
3517
3518/* Get the upper bound of the DO loops for matmul along a dimension. This
3519 is one-based. */
3520
3521static gfc_expr*
3522get_size_m1 (gfc_expr *e, int dimen)
3523{
3524 mpz_t size;
3525 gfc_expr *res;
3526
3527 if (gfc_array_dimen_size (e, dimen - 1, &size))
3528 {
3529 res = gfc_get_constant_expr (BT_INTEGER,
3530 gfc_index_integer_kind, &e->where);
3531 mpz_sub_ui (res->value.integer, size, 1);
3532 mpz_clear (size);
3533 }
3534 else
3535 {
3536 res = get_operand (INTRINSIC_MINUS,
3537 get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
3538 gfc_get_int_expr (gfc_index_integer_kind,
3539 &e->where, 1));
3540 gfc_simplify_expr (res, 0);
3541 }
3542
3543 return res;
3544}
3545
3546/* Function to return a scalarized expression. It is assumed that indices are
3547 zero based to make generation of DO loops easier. A zero as index will
3548 access the first element along a dimension. Single element references will
3549 be skipped. A NULL as an expression will be replaced by a full reference.
3550 This assumes that the index loops have gfc_index_integer_kind, and that all
3551 references have been frozen. */
3552
3553static gfc_expr*
3554scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
3555{
3556 gfc_array_ref *ar;
3557 int i;
3558 int rank;
3559 gfc_expr *e;
3560 int i_index;
3561 bool was_fullref;
3562
3563 e = gfc_copy_expr(e_in);
3564
3565 rank = e->rank;
3566
3567 ar = gfc_find_array_ref (e);
3568
3569 /* We scalarize count_index variables, reducing the rank by count_index. */
3570
3571 e->rank = rank - count_index;
3572
3573 was_fullref = ar->type == AR_FULL;
3574
3575 if (e->rank == 0)
3576 ar->type = AR_ELEMENT;
3577 else
3578 ar->type = AR_SECTION;
3579
3580 /* Loop over the indices. For each index, create the expression
3581 index * stride + lbound(e, dim). */
7474dcc1 3582
f1abbf69
TK		 3583 i_index = 0;
3584 for (i=0; i < ar->dimen; i++)
3585 {
3586 if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
3587 {
3588 if (index[i_index] != NULL)
3589 {
3590 gfc_expr *lbound, *nindex;
3591 gfc_expr *loopvar;
7474dcc1
PT		 3592
3593 loopvar = gfc_copy_expr (index[i_index]);
3594
f1abbf69
TK		 3595 if (ar->stride[i])
3596 {
3597 gfc_expr *tmp;
3598
3599 tmp = gfc_copy_expr(ar->stride[i]);
3600 if (tmp->ts.kind != gfc_index_integer_kind)
3601 {
3602 gfc_typespec ts;
3603 gfc_clear_ts (&ts);
3604 ts.type = BT_INTEGER;
3605 ts.kind = gfc_index_integer_kind;
3606 gfc_convert_type (tmp, &ts, 2);
3607 }
3608 nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
3609 }
3610 else
3611 nindex = loopvar;
7474dcc1 3612
f1abbf69
TK		 3613 /* Calculate the lower bound of the expression. */
3614 if (ar->start[i])
3615 {
3616 lbound = gfc_copy_expr (ar->start[i]);
3617 if (lbound->ts.kind != gfc_index_integer_kind)
3618 {
3619 gfc_typespec ts;
3620 gfc_clear_ts (&ts);
3621 ts.type = BT_INTEGER;
3622 ts.kind = gfc_index_integer_kind;
3623 gfc_convert_type (lbound, &ts, 2);
3624
3625 }
3626 }
3627 else
3628 {
7fc67fcb
TK		 3629 gfc_expr *lbound_e;
3630 gfc_ref *ref;
3631
3632 lbound_e = gfc_copy_expr (e_in);
3633
3634 for (ref = lbound_e->ref; ref; ref = ref->next)
3635 if (ref->type == REF_ARRAY
3636 && (ref->u.ar.type == AR_FULL
3637 || ref->u.ar.type == AR_SECTION))
3638 break;
3639
3640 if (ref->next)
3641 {
3642 gfc_free_ref_list (ref->next);
3643 ref->next = NULL;
3644 }
3645
f1abbf69
TK		 3646 if (!was_fullref)
3647 {
3648 /* Look at full individual sections, like a(:). The first index
3649 is the lbound of a full ref. */
7fc67fcb 3650 int j;
f1abbf69 3651 gfc_array_ref *ar;
aab20638 3652 int to;
f1abbf69 3653
7fc67fcb 3654 ar = &ref->u.ar;
aab20638
TK		 3655
3656 /* For assumed size, we need to keep around the final
3657 reference in order not to get an error on resolution
3658 below, and we cannot use AR_FULL. */
2efade53 3659
aab20638
TK		 3660 if (ar->as->type == AS_ASSUMED_SIZE)
3661 {
3662 ar->type = AR_SECTION;
3663 to = ar->dimen - 1;
3664 }
3665 else
3666 {
3667 to = ar->dimen;
3668 ar->type = AR_FULL;
3669 }
3670
3671 for (j = 0; j < to; j++)
7fc67fcb
TK		 3672 {
3673 gfc_free_expr (ar->start[j]);
3674 ar->start[j] = NULL;
3675 gfc_free_expr (ar->end[j]);
3676 ar->end[j] = NULL;
3677 gfc_free_expr (ar->stride[j]);
3678 ar->stride[j] = NULL;
3679 }
3680
3681 /* We have to get rid of the shape, if there is one. Do
3682 so by freeing it and calling gfc_resolve to rebuild
3683 it, if necessary. */
3684
3685 if (lbound_e->shape)
3686 gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
3687
3688 lbound_e->rank = ar->dimen;
3689 gfc_resolve_expr (lbound_e);
f1abbf69 3690 }
7fc67fcb
TK		 3691 lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
3692 i + 1);
3693 gfc_free_expr (lbound_e);
f1abbf69 3694 }
7474dcc1 3695
f1abbf69
TK		 3696 ar->dimen_type[i] = DIMEN_ELEMENT;
3697
3698 gfc_free_expr (ar->start[i]);
3699 ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
7474dcc1 3700
f1abbf69
TK		 3701 gfc_free_expr (ar->end[i]);
3702 ar->end[i] = NULL;
3703 gfc_free_expr (ar->stride[i]);
3704 ar->stride[i] = NULL;
3705 gfc_simplify_expr (ar->start[i], 0);
3706 }
3707 else if (was_fullref)
3708 {
3709 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3710 }
3711 i_index ++;
3712 }
3713 }
7fc67fcb 3714
980fa45e
TK		 3715 /* Bounds checking will be done before the loops if -fcheck=bounds
3716 is in effect. */
3717 e->no_bounds_check = 1;
f1abbf69
TK		 3718 return e;
3719}
3720
7e269fe8
TK		 3721/* Helper function to check for a dimen vector as subscript. */
3722
1585b483
TK		 3723bool
3724gfc_has_dimen_vector_ref (gfc_expr *e)
7e269fe8
TK		 3725{
3726 gfc_array_ref *ar;
3727 int i;
3728
3729 ar = gfc_find_array_ref (e);
3730 gcc_assert (ar);
3731 if (ar->type == AR_FULL)
3732 return false;
3733
3734 for (i=0; i<ar->dimen; i++)
3735 if (ar->dimen_type[i] == DIMEN_VECTOR)
3736 return true;
3737
3738 return false;
3739}
f1abbf69 3740
c39d5e4a
TK		 3741/* If handed an expression of the form
3742
094773e8 3743 TRANSPOSE(CONJG(A))
c39d5e4a
TK		 3744
3745 check if A can be handled by matmul and return if there is an uneven number
3746 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3747 otherwise. The caller has to check for the correct rank. */
3748
3749static gfc_expr*
094773e8 3750check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
c39d5e4a
TK		 3751{
3752 *conjg = false;
094773e8 3753 *transpose = false;
c39d5e4a
TK		 3754
3755 do
3756 {
3757 if (e->expr_type == EXPR_VARIABLE)
3758 {
3759 gcc_assert (e->rank == 1 || e->rank == 2);
3760 return e;
3761 }
3762 else if (e->expr_type == EXPR_FUNCTION)
3763 {
3764 if (e->value.function.isym == NULL)
3765 return NULL;
3766
3767 if (e->value.function.isym->id == GFC_ISYM_CONJG)
3768 *conjg = !*conjg;
094773e8
TK		 3769 else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
3770 *transpose = !*transpose;
c39d5e4a
TK		 3771 else return NULL;
3772 }
3773 else
3774 return NULL;
3775
3776 e = e->value.function.actual->expr;
3777 }
3778 while(1);
3779
3780 return NULL;
3781}
3782
ed33417a
TK		 3783/* Macros for unified error messages. */
3784
c00d68e8
TK		 3785#define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
3786 "dimension 1: is %ld, should be %ld")
ed33417a 3787
c00d68e8
TK		 3788#define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
3789 "(%ld/%ld)")
3790
3791#define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
3792 "(%ld/%ld)")
ed33417a
TK		 3793
3794
f1abbf69
TK		 3795/* Inline assignments of the form c = matmul(a,b).
3796 Handle only the cases currently where b and c are rank-two arrays.
3797
3798 This basically translates the code to
3799
3800 BLOCK
3801 integer i,j,k
3802 c = 0
3803 do j=0, size(b,2)-1
3804 do k=0, size(a, 2)-1
3805 do i=0, size(a, 1)-1
3806 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3807 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3808 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3809 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3810 end do
3811 end do
3812 end do
3813 END BLOCK
7474dcc1 3814
f1abbf69
TK		 3815*/
3816
3817static int
3818inline_matmul_assign (gfc_code **c, int *walk_subtrees,
3819 void *data ATTRIBUTE_UNUSED)
3820{
3821 gfc_code *co = *c;
3822 gfc_expr *expr1, *expr2;
3823 gfc_expr *matrix_a, *matrix_b;
3824 gfc_actual_arglist *a, *b;
3825 gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
3826 gfc_expr *zero_e;
3827 gfc_expr *u1, *u2, *u3;
3828 gfc_expr *list[2];
3829 gfc_expr *ascalar, *bscalar, *cscalar;
3830 gfc_expr *mult;
3831 gfc_expr *var_1, *var_2, *var_3;
3832 gfc_expr *zero;
3833 gfc_namespace *ns;
3834 gfc_intrinsic_op op_times, op_plus;
3835 enum matrix_case m_case;
3836 int i;
3837 gfc_code *if_limit = NULL;
3838 gfc_code **next_code_point;
094773e8 3839 bool conjg_a, conjg_b, transpose_a, transpose_b;
ed33417a 3840 bool realloc_c;
f1abbf69
TK		 3841
3842 if (co->op != EXEC_ASSIGN)
3843 return 0;
3844
dca9e8be 3845 if (in_where || in_assoc_list)
fd42eed8
TK		 3846 return 0;
3847
5f869266
TK		 3848 /* The BLOCKS generated for the temporary variables and FORALL don't
3849 mix. */
3850 if (forall_level > 0)
3851 return 0;
3852
56a3d28b
JJ		 3853 /* For now don't do anything in OpenMP workshare, it confuses
3854 its translation, which expects only the allowed statements in there.
3855 We should figure out how to parallelize this eventually. */
a7a09efa 3856 if (in_omp_workshare || in_omp_atomic)
56a3d28b
JJ		 3857 return 0;
3858
f1abbf69
TK		 3859 expr1 = co->expr1;
3860 expr2 = co->expr2;
3861 if (expr2->expr_type != EXPR_FUNCTION
3862 || expr2->value.function.isym == NULL
3863 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
3864 return 0;
3865
3866 current_code = c;
3867 inserted_block = NULL;
3868 changed_statement = NULL;
3869
3870 a = expr2->value.function.actual;
094773e8 3871 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
610abc02 3872 if (matrix_a == NULL)
c39d5e4a 3873 return 0;
f1abbf69 3874
c39d5e4a 3875 b = a->next;
094773e8 3876 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
c39d5e4a 3877 if (matrix_b == NULL)
f1abbf69
TK		 3878 return 0;
3879
1585b483
TK		 3880 if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a)
3881 || gfc_has_dimen_vector_ref (matrix_b))
7e269fe8
TK		 3882 return 0;
3883
c39d5e4a
TK		 3884 /* We do not handle data dependencies yet. */
3885 if (gfc_check_dependency (expr1, matrix_a, true)
3886 || gfc_check_dependency (expr1, matrix_b, true))
3887 return 0;
3888
610abc02 3889 m_case = none;
f1abbf69 3890 if (matrix_a->rank == 2)
094773e8 3891 {
610abc02
TK		 3892 if (transpose_a)
3893 {
3894 if (matrix_b->rank == 2 && !transpose_b)
3895 m_case = A2TB2;
3896 }
094773e8
TK		 3897 else
3898 {
610abc02
TK		 3899 if (matrix_b->rank == 1)
3900 m_case = A2B1;
3901 else /* matrix_b->rank == 2 */
3902 {
3903 if (transpose_b)
3904 m_case = A2B2T;
3905 else
3906 m_case = A2B2;
3907 }
094773e8
TK		 3908 }
3909 }
610abc02 3910 else /* matrix_a->rank == 1 */
094773e8 3911 {
610abc02
TK		 3912 if (matrix_b->rank == 2)
3913 {
3914 if (!transpose_b)
3915 m_case = A1B2;
3916 }
094773e8 3917 }
980fa45e 3918
094773e8
TK		 3919 if (m_case == none)
3920 return 0;
f1abbf69
TK		 3921
3922 ns = insert_block ();
3923
3924 /* Assign the type of the zero expression for initializing the resulting
3925 array, and the expression (+ and * for real, integer and complex;
3926 .and. and .or for logical. */
3927
3928 switch(expr1->ts.type)
3929 {
3930 case BT_INTEGER:
3931 zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
3932 op_times = INTRINSIC_TIMES;
3933 op_plus = INTRINSIC_PLUS;
3934 break;
3935
3936 case BT_LOGICAL:
3937 op_times = INTRINSIC_AND;
3938 op_plus = INTRINSIC_OR;
3939 zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
3940 0);
3941 break;
3942 case BT_REAL:
3943 zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
3944 &expr1->where);
3945 mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
3946 op_times = INTRINSIC_TIMES;
3947 op_plus = INTRINSIC_PLUS;
3948 break;
3949
3950 case BT_COMPLEX:
3951 zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
3952 &expr1->where);
3953 mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
3954 op_times = INTRINSIC_TIMES;
3955 op_plus = INTRINSIC_PLUS;
3956
3957 break;
3958
3959 default:
3960 gcc_unreachable();
3961 }
3962
3963 current_code = &ns->code;
3964
3965 /* Freeze the references, keeping track of how many temporary variables were
3966 created. */
3967 n_vars = 0;
3968 freeze_references (matrix_a);
3969 freeze_references (matrix_b);
3970 freeze_references (expr1);
3971
3972 if (n_vars == 0)
3973 next_code_point = current_code;
3974 else
3975 {
3976 next_code_point = &ns->code;
3977 for (i=0; i<n_vars; i++)
3978 next_code_point = &(*next_code_point)->next;
3979 }
3980
3981 /* Take care of the inline flag. If the limit check evaluates to a
3982 constant, dead code elimination will eliminate the unneeded branch. */
3983
998511a6
TK		 3984 if (flag_inline_matmul_limit > 0 && matrix_a->rank == 2
3985 && matrix_b->rank == 2)
f1abbf69 3986 {
998511a6
TK		 3987 if_limit = inline_limit_check (matrix_a, matrix_b,
3988 flag_inline_matmul_limit);
f1abbf69
TK		 3989
3990 /* Insert the original statement into the else branch. */
3991 if_limit->block->block->next = co;
3992 co->next = NULL;
3993
3994 /* ... and the new ones go into the original one. */
3995 *next_code_point = if_limit;
3996 next_code_point = &if_limit->block->next;
3997 }
3998
980fa45e
TK		 3999 zero_e->no_bounds_check = 1;
4000
f1abbf69
TK		 4001 assign_zero = XCNEW (gfc_code);
4002 assign_zero->op = EXEC_ASSIGN;
4003 assign_zero->loc = co->loc;
4004 assign_zero->expr1 = gfc_copy_expr (expr1);
980fa45e 4005 assign_zero->expr1->no_bounds_check = 1;
f1abbf69
TK		 4006 assign_zero->expr2 = zero_e;
4007
ed33417a 4008 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
f1abbf69 4009
ed33417a
TK		 4010 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4011 {
4012 gfc_code *test;
4013 gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
f1abbf69 4014
ed33417a 4015 switch (m_case)
f1abbf69 4016 {
ed33417a 4017 case A2B1:
980fa45e 4018
ed33417a
TK		 4019 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4020 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
c00d68e8 4021 test = runtime_error_ne (b1, a2, B_ERROR_1);
ed33417a
TK		 4022 *next_code_point = test;
4023 next_code_point = &test->next;
980fa45e 4024
ed33417a
TK		 4025 if (!realloc_c)
4026 {
4027 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
980fa45e 4028 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4029 test = runtime_error_ne (c1, a1, C_ERROR_1);
980fa45e
TK		 4030 *next_code_point = test;
4031 next_code_point = &test->next;
4032 }
ed33417a 4033 break;
f1abbf69 4034
ed33417a 4035 case A1B2:
f1abbf69 4036
f1abbf69 4037 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
ed33417a 4038 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4039 test = runtime_error_ne (b1, a1, B_ERROR_1);
f1abbf69
TK		 4040 *next_code_point = test;
4041 next_code_point = &test->next;
4042
ed33417a
TK		 4043 if (!realloc_c)
4044 {
4045 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4046 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
c00d68e8 4047 test = runtime_error_ne (c1, b2, C_ERROR_1);
ed33417a
TK		 4048 *next_code_point = test;
4049 next_code_point = &test->next;
4050 }
4051 break;
f1abbf69 4052
ed33417a 4053 case A2B2:
f1abbf69 4054
f1abbf69 4055 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
ed33417a 4056 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
c00d68e8 4057 test = runtime_error_ne (b1, a2, B_ERROR_1);
f1abbf69
TK		 4058 *next_code_point = test;
4059 next_code_point = &test->next;
4060
ed33417a
TK		 4061 if (!realloc_c)
4062 {
4063 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4064 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4065 test = runtime_error_ne (c1, a1, C_ERROR_1);
ed33417a
TK		 4066 *next_code_point = test;
4067 next_code_point = &test->next;
f1abbf69 4068
ed33417a
TK		 4069 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4070 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
c00d68e8 4071 test = runtime_error_ne (c2, b2, C_ERROR_2);
ed33417a
TK		 4072 *next_code_point = test;
4073 next_code_point = &test->next;
4074 }
4075 break;
f1abbf69 4076
ed33417a 4077 case A2B2T:
f1abbf69 4078
f1abbf69 4079 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
ed33417a
TK		 4080 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4081 /* matrix_b is transposed, hence dimension 1 for the error message. */
c00d68e8 4082 test = runtime_error_ne (b2, a2, B_ERROR_1);
f1abbf69
TK		 4083 *next_code_point = test;
4084 next_code_point = &test->next;
094773e8 4085
ed33417a
TK		 4086 if (!realloc_c)
4087 {
4088 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4089 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4090 test = runtime_error_ne (c1, a1, C_ERROR_1);
ed33417a
TK		 4091 *next_code_point = test;
4092 next_code_point = &test->next;
094773e8 4093
ed33417a
TK		 4094 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4095 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
c00d68e8 4096 test = runtime_error_ne (c2, b1, C_ERROR_2);
ed33417a
TK		 4097 *next_code_point = test;
4098 next_code_point = &test->next;
4099 }
4100 break;
4101
4102 case A2TB2:
094773e8 4103
094773e8 4104 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
ed33417a 4105 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4106 test = runtime_error_ne (b1, a1, B_ERROR_1);
094773e8
TK		 4107 *next_code_point = test;
4108 next_code_point = &test->next;
4109
ed33417a
TK		 4110 if (!realloc_c)
4111 {
4112 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4113 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
c00d68e8 4114 test = runtime_error_ne (c1, a2, C_ERROR_1);
ed33417a
TK		 4115 *next_code_point = test;
4116 next_code_point = &test->next;
094773e8 4117
ed33417a
TK		 4118 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4119 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
c00d68e8 4120 test = runtime_error_ne (c2, b2, C_ERROR_2);
ed33417a
TK		 4121 *next_code_point = test;
4122 next_code_point = &test->next;
4123 }
4124 break;
094773e8 4125
ed33417a
TK		 4126 default:
4127 gcc_unreachable ();
094773e8 4128 }
ed33417a 4129 }
610abc02 4130
ed33417a 4131 /* Handle the reallocation, if needed. */
610abc02 4132
ed33417a
TK		 4133 if (realloc_c)
4134 {
4135 gfc_code *lhs_alloc;
610abc02 4136
ed33417a 4137 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
610abc02 4138
ed33417a
TK		 4139 *next_code_point = lhs_alloc;
4140 next_code_point = &lhs_alloc->next;
610abc02 4141
f1abbf69
TK		 4142 }
4143
4144 *next_code_point = assign_zero;
4145
4146 zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
4147
4148 assign_matmul = XCNEW (gfc_code);
4149 assign_matmul->op = EXEC_ASSIGN;
4150 assign_matmul->loc = co->loc;
4151
4152 /* Get the bounds for the loops, create them and create the scalarized
4153 expressions. */
4154
4155 switch (m_case)
4156 {
4157 case A2B2:
f1abbf69
TK		 4158
4159 u1 = get_size_m1 (matrix_b, 2);
4160 u2 = get_size_m1 (matrix_a, 2);
4161 u3 = get_size_m1 (matrix_a, 1);
4162
4163 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4164 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4165 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4166
4167 do_1->block->next = do_2;
4168 do_2->block->next = do_3;
4169 do_3->block->next = assign_matmul;
4170
4171 var_1 = do_1->ext.iterator->var;
4172 var_2 = do_2->ext.iterator->var;
4173 var_3 = do_3->ext.iterator->var;
4174
4175 list[0] = var_3;
4176 list[1] = var_1;
7fc67fcb 4177 cscalar = scalarized_expr (co->expr1, list, 2);
f1abbf69
TK		 4178
4179 list[0] = var_3;
4180 list[1] = var_2;
7fc67fcb 4181 ascalar = scalarized_expr (matrix_a, list, 2);
f1abbf69
TK		 4182
4183 list[0] = var_2;
4184 list[1] = var_1;
7fc67fcb 4185 bscalar = scalarized_expr (matrix_b, list, 2);
f1abbf69
TK		 4186
4187 break;
4188
094773e8 4189 case A2B2T:
094773e8
TK		 4190
4191 u1 = get_size_m1 (matrix_b, 1);
4192 u2 = get_size_m1 (matrix_a, 2);
4193 u3 = get_size_m1 (matrix_a, 1);
4194
4195 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4196 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4197 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4198
4199 do_1->block->next = do_2;
4200 do_2->block->next = do_3;
4201 do_3->block->next = assign_matmul;
4202
4203 var_1 = do_1->ext.iterator->var;
4204 var_2 = do_2->ext.iterator->var;
4205 var_3 = do_3->ext.iterator->var;
4206
4207 list[0] = var_3;
4208 list[1] = var_1;
4209 cscalar = scalarized_expr (co->expr1, list, 2);
4210
4211 list[0] = var_3;
4212 list[1] = var_2;
4213 ascalar = scalarized_expr (matrix_a, list, 2);
4214
4215 list[0] = var_1;
4216 list[1] = var_2;
4217 bscalar = scalarized_expr (matrix_b, list, 2);
4218
4219 break;
4220
610abc02 4221 case A2TB2:
610abc02
TK		 4222
4223 u1 = get_size_m1 (matrix_a, 2);
4224 u2 = get_size_m1 (matrix_b, 2);
4225 u3 = get_size_m1 (matrix_a, 1);
4226
4227 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4228 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4229 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4230
4231 do_1->block->next = do_2;
4232 do_2->block->next = do_3;
4233 do_3->block->next = assign_matmul;
4234
4235 var_1 = do_1->ext.iterator->var;
4236 var_2 = do_2->ext.iterator->var;
4237 var_3 = do_3->ext.iterator->var;
4238
4239 list[0] = var_1;
4240 list[1] = var_2;
4241 cscalar = scalarized_expr (co->expr1, list, 2);
4242
4243 list[0] = var_3;
4244 list[1] = var_1;
4245 ascalar = scalarized_expr (matrix_a, list, 2);
4246
4247 list[0] = var_3;
4248 list[1] = var_2;
4249 bscalar = scalarized_expr (matrix_b, list, 2);
4250
4251 break;
4252
f1abbf69
TK		 4253 case A2B1:
4254 u1 = get_size_m1 (matrix_b, 1);
4255 u2 = get_size_m1 (matrix_a, 1);
4256
4257 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4258 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4259
4260 do_1->block->next = do_2;
4261 do_2->block->next = assign_matmul;
4262
4263 var_1 = do_1->ext.iterator->var;
4264 var_2 = do_2->ext.iterator->var;
4265
4266 list[0] = var_2;
7fc67fcb 4267 cscalar = scalarized_expr (co->expr1, list, 1);
f1abbf69
TK		 4268
4269 list[0] = var_2;
4270 list[1] = var_1;
7fc67fcb 4271 ascalar = scalarized_expr (matrix_a, list, 2);
f1abbf69
TK		 4272
4273 list[0] = var_1;
7fc67fcb 4274 bscalar = scalarized_expr (matrix_b, list, 1);
f1abbf69
TK		 4275
4276 break;
4277
4278 case A1B2:
4279 u1 = get_size_m1 (matrix_b, 2);
4280 u2 = get_size_m1 (matrix_a, 1);
4281
4282 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4283 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4284
4285 do_1->block->next = do_2;
4286 do_2->block->next = assign_matmul;
4287
4288 var_1 = do_1->ext.iterator->var;
4289 var_2 = do_2->ext.iterator->var;
4290
4291 list[0] = var_1;
7fc67fcb 4292 cscalar = scalarized_expr (co->expr1, list, 1);
f1abbf69
TK		 4293
4294 list[0] = var_2;
7fc67fcb 4295 ascalar = scalarized_expr (matrix_a, list, 1);
f1abbf69
TK		 4296
4297 list[0] = var_2;
4298 list[1] = var_1;
7fc67fcb 4299 bscalar = scalarized_expr (matrix_b, list, 2);
f1abbf69
TK		 4300
4301 break;
4302
4303 default:
4304 gcc_unreachable();
4305 }
4306
86e03ef9
TK		 4307 /* Build the conjg call around the variables. Set the typespec manually
4308 because gfc_build_intrinsic_call sometimes gets this wrong. */
c39d5e4a 4309 if (conjg_a)
86e03ef9
TK		 4310 {
4311 gfc_typespec ts;
4312 ts = matrix_a->ts;
4313 ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4314 matrix_a->where, 1, ascalar);
4315 ascalar->ts = ts;
4316 }
c39d5e4a
TK		 4317
4318 if (conjg_b)
86e03ef9
TK		 4319 {
4320 gfc_typespec ts;
4321 ts = matrix_b->ts;
4322 bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4323 matrix_b->where, 1, bscalar);
4324 bscalar->ts = ts;
4325 }
f1abbf69
TK		 4326 /* First loop comes after the zero assignment. */
4327 assign_zero->next = do_1;
4328
4329 /* Build the assignment expression in the loop. */
4330 assign_matmul->expr1 = gfc_copy_expr (cscalar);
4331
4332 mult = get_operand (op_times, ascalar, bscalar);
4333 assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
4334
4335 /* If we don't want to keep the original statement around in
4336 the else branch, we can free it. */
4337
4338 if (if_limit == NULL)
4339 gfc_free_statements(co);
4340 else
4341 co->next = NULL;
4342
4343 gfc_free_expr (zero);
4344 *walk_subtrees = 0;
4345 return 0;
4346}
305a35da 4347
998511a6
TK		 4348/* Change matmul function calls in the form of
4349
4350 c = matmul(a,b)
4351
4352 to the corresponding call to a BLAS routine, if applicable. */
4353
4354static int
4355call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
4356 void *data ATTRIBUTE_UNUSED)
4357{
4358 gfc_code *co, *co_next;
4359 gfc_expr *expr1, *expr2;
4360 gfc_expr *matrix_a, *matrix_b;
4361 gfc_code *if_limit = NULL;
4362 gfc_actual_arglist *a, *b;
4363 bool conjg_a, conjg_b, transpose_a, transpose_b;
4364 gfc_code *call;
4365 const char *blas_name;
4366 const char *transa, *transb;
4367 gfc_expr *c1, *c2, *b1;
4368 gfc_actual_arglist *actual, *next;
4369 bt type;
4370 int kind;
4371 enum matrix_case m_case;
4372 bool realloc_c;
4373 gfc_code **next_code_point;
4374
4375 /* Many of the tests for inline matmul also apply here. */
4376
4377 co = *c;
4378
4379 if (co->op != EXEC_ASSIGN)
4380 return 0;
4381
4382 if (in_where || in_assoc_list)
4383 return 0;
4384
4385 /* The BLOCKS generated for the temporary variables and FORALL don't
4386 mix. */
4387 if (forall_level > 0)
4388 return 0;
4389
4390 /* For now don't do anything in OpenMP workshare, it confuses
4391 its translation, which expects only the allowed statements in there. */
4392
23cdc1e9 4393 if (in_omp_workshare || in_omp_atomic)
998511a6
TK		 4394 return 0;
4395
4396 expr1 = co->expr1;
4397 expr2 = co->expr2;
4398 if (expr2->expr_type != EXPR_FUNCTION
4399 || expr2->value.function.isym == NULL
4400 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4401 return 0;
4402
4403 type = expr2->ts.type;
4404 kind = expr2->ts.kind;
4405
4406 /* Guard against recursion. */
4407
4408 if (expr2->external_blas)
4409 return 0;
4410
4411 if (type != expr1->ts.type || kind != expr1->ts.kind)
4412 return 0;
4413
4414 if (type == BT_REAL)
4415 {
4416 if (kind == 4)
4417 blas_name = "sgemm";
4418 else if (kind == 8)
4419 blas_name = "dgemm";
4420 else
4421 return 0;
4422 }
4423 else if (type == BT_COMPLEX)
4424 {
4425 if (kind == 4)
4426 blas_name = "cgemm";
4427 else if (kind == 8)
4428 blas_name = "zgemm";
4429 else
4430 return 0;
4431 }
4432 else
4433 return 0;
4434
4435 a = expr2->value.function.actual;
4436 if (a->expr->rank != 2)
4437 return 0;
4438
4439 b = a->next;
4440 if (b->expr->rank != 2)
4441 return 0;
4442
4443 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
4444 if (matrix_a == NULL)
4445 return 0;
4446
4447 if (transpose_a)
4448 {
4449 if (conjg_a)
4450 transa = "C";
4451 else
4452 transa = "T";
4453 }
4454 else
4455 transa = "N";
4456
4457 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
4458 if (matrix_b == NULL)
4459 return 0;
4460
4461 if (transpose_b)
4462 {
4463 if (conjg_b)
4464 transb = "C";
4465 else
4466 transb = "T";
4467 }
4468 else
4469 transb = "N";
4470
4471 if (transpose_a)
4472 {
4473 if (transpose_b)
4474 m_case = A2TB2T;
4475 else
4476 m_case = A2TB2;
4477 }
4478 else
4479 {
4480 if (transpose_b)
4481 m_case = A2B2T;
4482 else
4483 m_case = A2B2;
4484 }
4485
4486 current_code = c;
4487 inserted_block = NULL;
4488 changed_statement = NULL;
4489
4490 expr2->external_blas = 1;
4491
4492 /* We do not handle data dependencies yet. */
4493 if (gfc_check_dependency (expr1, matrix_a, true)
4494 || gfc_check_dependency (expr1, matrix_b, true))
4495 return 0;
4496
4497 /* Generate the if statement and hang it into the tree. */
4498 if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit);
4499 co_next = co->next;
4500 (*current_code) = if_limit;
4501 co->next = NULL;
4502 if_limit->block->next = co;
4503
4504 call = XCNEW (gfc_code);
4505 call->loc = co->loc;
4506
4507 /* Bounds checking - a bit simpler than for inlining since we only
4508 have to take care of two-dimensional arrays here. */
4509
4510 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4511 next_code_point = &(if_limit->block->block->next);
4512
4513 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4514 {
4515 gfc_code *test;
4516 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4517 gfc_expr *c1, *a1, *c2, *b2, *a2;
4518 switch (m_case)
4519 {
4520 case A2B2:
4521 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4522 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
c00d68e8 4523 test = runtime_error_ne (b1, a2, B_ERROR_1);
998511a6
TK		 4524 *next_code_point = test;
4525 next_code_point = &test->next;
4526
4527 if (!realloc_c)
4528 {
4529 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4530 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4531 test = runtime_error_ne (c1, a1, C_ERROR_1);
998511a6
TK		 4532 *next_code_point = test;
4533 next_code_point = &test->next;
4534
4535 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4536 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
c00d68e8 4537 test = runtime_error_ne (c2, b2, C_ERROR_2);
998511a6
TK		 4538 *next_code_point = test;
4539 next_code_point = &test->next;
4540 }
4541 break;
4542
4543 case A2B2T:
4544
4545 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4546 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4547 /* matrix_b is transposed, hence dimension 1 for the error message. */
c00d68e8 4548 test = runtime_error_ne (b2, a2, B_ERROR_1);
998511a6
TK		 4549 *next_code_point = test;
4550 next_code_point = &test->next;
4551
4552 if (!realloc_c)
4553 {
4554 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4555 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4556 test = runtime_error_ne (c1, a1, C_ERROR_1);
998511a6
TK		 4557 *next_code_point = test;
4558 next_code_point = &test->next;
4559
4560 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4561 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
c00d68e8 4562 test = runtime_error_ne (c2, b1, C_ERROR_2);
998511a6
TK		 4563 *next_code_point = test;
4564 next_code_point = &test->next;
4565 }
4566 break;
4567
4568 case A2TB2:
4569
4570 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4571 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4572 test = runtime_error_ne (b1, a1, B_ERROR_1);
998511a6
TK		 4573 *next_code_point = test;
4574 next_code_point = &test->next;
4575
4576 if (!realloc_c)
4577 {
4578 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4579 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
c00d68e8 4580 test = runtime_error_ne (c1, a2, C_ERROR_1);
998511a6
TK		 4581 *next_code_point = test;
4582 next_code_point = &test->next;
4583
4584 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4585 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
c00d68e8 4586 test = runtime_error_ne (c2, b2, C_ERROR_2);
998511a6
TK		 4587 *next_code_point = test;
4588 next_code_point = &test->next;
4589 }
4590 break;
4591
4592 case A2TB2T:
4593 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4594 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
c00d68e8 4595 test = runtime_error_ne (b2, a1, B_ERROR_1);
998511a6
TK		 4596 *next_code_point = test;
4597 next_code_point = &test->next;
4598
4599 if (!realloc_c)
4600 {
4601 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4602 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
c00d68e8 4603 test = runtime_error_ne (c1, a2, C_ERROR_1);
998511a6
TK		 4604 *next_code_point = test;
4605 next_code_point = &test->next;
4606
4607 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4608 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
c00d68e8 4609 test = runtime_error_ne (c2, b1, C_ERROR_2);
998511a6
TK		 4610 *next_code_point = test;
4611 next_code_point = &test->next;
4612 }
4613 break;
4614
4615 default:
4616 gcc_unreachable ();
4617 }
2efade53 4618 }
998511a6
TK		 4619
4620 /* Handle the reallocation, if needed. */
4621
4622 if (realloc_c)
4623 {
4624 gfc_code *lhs_alloc;
4625
4626 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4627 *next_code_point = lhs_alloc;
4628 next_code_point = &lhs_alloc->next;
4629 }
4630
4631 *next_code_point = call;
4632 if_limit->next = co_next;
4633
4634 /* Set up the BLAS call. */
4635
4636 call->op = EXEC_CALL;
4637
4638 gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
4639 call->symtree->n.sym->attr.subroutine = 1;
4640 call->symtree->n.sym->attr.procedure = 1;
4641 call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4642 call->resolved_sym = call->symtree->n.sym;
b03932cb 4643 gfc_commit_symbol (call->resolved_sym);
998511a6
TK		 4644
4645 /* Argument TRANSA. */
4646 next = gfc_get_actual_arglist ();
4647 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4648 transa, 1);
4649
4650 call->ext.actual = next;
4651
4652 /* Argument TRANSB. */
4653 actual = next;
4654 next = gfc_get_actual_arglist ();
4655 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4656 transb, 1);
4657 actual->next = next;
4658
4659 c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
4660 gfc_integer_4_kind);
4661 c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
4662 gfc_integer_4_kind);
4663
4664 b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
4665 gfc_integer_4_kind);
4666
4667 /* Argument M. */
4668 actual = next;
4669 next = gfc_get_actual_arglist ();
4670 next->expr = c1;
4671 actual->next = next;
4672
4673 /* Argument N. */
4674 actual = next;
4675 next = gfc_get_actual_arglist ();
4676 next->expr = c2;
4677 actual->next = next;
4678
4679 /* Argument K. */
4680 actual = next;
4681 next = gfc_get_actual_arglist ();
4682 next->expr = b1;
4683 actual->next = next;
4684
4685 /* Argument ALPHA - set to one. */
4686 actual = next;
4687 next = gfc_get_actual_arglist ();
4688 next->expr = gfc_get_constant_expr (type, kind, &co->loc);
4689 if (type == BT_REAL)
4690 mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
4691 else
4692 mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
4693 actual->next = next;
4694
4695 /* Argument A. */
4696 actual = next;
4697 next = gfc_get_actual_arglist ();
4698 next->expr = gfc_copy_expr (matrix_a);
4699 actual->next = next;
4700
4701 /* Argument LDA. */
4702 actual = next;
4703 next = gfc_get_actual_arglist ();
4704 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
4705 1, gfc_integer_4_kind);
4706 actual->next = next;
4707
4708 /* Argument B. */
4709 actual = next;
4710 next = gfc_get_actual_arglist ();
4711 next->expr = gfc_copy_expr (matrix_b);
4712 actual->next = next;
4713
4714 /* Argument LDB. */
4715 actual = next;
4716 next = gfc_get_actual_arglist ();
4717 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
4718 1, gfc_integer_4_kind);
4719 actual->next = next;
4720
4721 /* Argument BETA - set to zero. */
4722 actual = next;
4723 next = gfc_get_actual_arglist ();
4724 next->expr = gfc_get_constant_expr (type, kind, &co->loc);
4725 if (type == BT_REAL)
4726 mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
4727 else
4728 mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
4729 actual->next = next;
4730
4731 /* Argument C. */
4732
4733 actual = next;
4734 next = gfc_get_actual_arglist ();
4735 next->expr = gfc_copy_expr (expr1);
4736 actual->next = next;
4737
4738 /* Argument LDC. */
4739 actual = next;
4740 next = gfc_get_actual_arglist ();
4741 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
4742 1, gfc_integer_4_kind);
4743 actual->next = next;
4744
4745 return 0;
4746}
4747
d88412fc
TK		 4748
4749/* Code for index interchange for loops which are grouped together in DO
4750 CONCURRENT or FORALL statements. This is currently only applied if the
4751 iterations are grouped together in a single statement.
4752
4753 For this transformation, it is assumed that memory access in strides is
4754 expensive, and that loops which access later indices (which access memory
4755 in bigger strides) should be moved to the first loops.
4756
4757 For this, a loop over all the statements is executed, counting the times
4758 that the loop iteration values are accessed in each index. The loop
4759 indices are then sorted to minimize access to later indices from inner
4760 loops. */
4761
4762/* Type for holding index information. */
4763
4764typedef struct {
4765 gfc_symbol *sym;
4766 gfc_forall_iterator *fa;
4767 int num;
4768 int n[GFC_MAX_DIMENSIONS];
4769} ind_type;
4770
2efade53 4771/* Callback function to determine if an expression is the
d88412fc
TK		 4772 corresponding variable. */
4773
4774static int
4775has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
4776{
4777 gfc_expr *expr = *e;
4778 gfc_symbol *sym;
4779
4780 if (expr->expr_type != EXPR_VARIABLE)
4781 return 0;
4782
4783 sym = (gfc_symbol *) data;
4784 return sym == expr->symtree->n.sym;
4785}
4786
4787/* Callback function to calculate the cost of a certain index. */
4788
4789static int
4790index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4791 void *data)
4792{
4793 ind_type *ind;
4794 gfc_expr *expr;
4795 gfc_array_ref *ar;
4796 gfc_ref *ref;
4797 int i,j;
4798
4799 expr = *e;
4800 if (expr->expr_type != EXPR_VARIABLE)
4801 return 0;
4802
4803 ar = NULL;
4804 for (ref = expr->ref; ref; ref = ref->next)
4805 {
4806 if (ref->type == REF_ARRAY)
4807 {
4808 ar = &ref->u.ar;
4809 break;
4810 }
4811 }
4812 if (ar == NULL || ar->type != AR_ELEMENT)
4813 return 0;
4814
4815 ind = (ind_type *) data;
4816 for (i = 0; i < ar->dimen; i++)
4817 {
4818 for (j=0; ind[j].sym != NULL; j++)
4819 {
4820 if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
4821 ind[j].n[i]++;
4822 }
4823 }
4824 return 0;
4825}
4826
4827/* Callback function for qsort, to sort the loop indices. */
4828
4829static int
4830loop_comp (const void *e1, const void *e2)
4831{
4832 const ind_type *i1 = (const ind_type *) e1;
4833 const ind_type *i2 = (const ind_type *) e2;
4834 int i;
4835
4836 for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
4837 {
4838 if (i1->n[i] != i2->n[i])
4839 return i1->n[i] - i2->n[i];
4840 }
4841 /* All other things being equal, let's not change the ordering. */
4842 return i2->num - i1->num;
4843}
4844
4845/* Main function to do the index interchange. */
4846
4847static int
4848index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
4849 void *data ATTRIBUTE_UNUSED)
4850{
4851 gfc_code *co;
4852 co = *c;
4853 int n_iter;
4854 gfc_forall_iterator *fa;
4855 ind_type *ind;
4856 int i, j;
2efade53 4857
d88412fc
TK		 4858 if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
4859 return 0;
4860
4861 n_iter = 0;
4862 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
4863 n_iter ++;
4864
4865 /* Nothing to reorder. */
4866 if (n_iter < 2)
4867 return 0;
4868
4869 ind = XALLOCAVEC (ind_type, n_iter + 1);
4870
4871 i = 0;
4872 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
4873 {
4874 ind[i].sym = fa->var->symtree->n.sym;
4875 ind[i].fa = fa;
4876 for (j=0; j<GFC_MAX_DIMENSIONS; j++)
4877 ind[i].n[j] = 0;
4878 ind[i].num = i;
4879 i++;
4880 }
4881 ind[n_iter].sym = NULL;
4882 ind[n_iter].fa = NULL;
4883
4884 gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
4885 qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
4886
4887 /* Do the actual index interchange. */
4888 co->ext.forall_iterator = fa = ind[0].fa;
4889 for (i=1; i<n_iter; i++)
4890 {
4891 fa->next = ind[i].fa;
4892 fa = fa->next;
4893 }
4894 fa->next = NULL;
4895
4896 if (flag_warn_frontend_loop_interchange)
4897 {
4898 for (i=1; i<n_iter; i++)
4899 {
4900 if (ind[i-1].num > ind[i].num)
4901 {
4902 gfc_warning (OPT_Wfrontend_loop_interchange,
4903 "Interchanging loops at %L", &co->loc);
4904 break;
4905 }
4906 }
4907 }
4908
4909 return 0;
4910}
4911
4d42b5cd
JJ		 4912#define WALK_SUBEXPR(NODE) \
4913 do \
4914 { \
4915 result = gfc_expr_walker (&(NODE), exprfn, data); \
4916 if (result) \
4917 return result; \
4918 } \
4919 while (0)
4920#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
601d98be 4921
4d42b5cd
JJ		 4922/* Walk expression *E, calling EXPRFN on each expression in it. */
4923
4924int
4925gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
601d98be 4926{
4d42b5cd
JJ		 4927 while (*e)
4928 {
4929 int walk_subtrees = 1;
4930 gfc_actual_arglist *a;
46f19baf
TK		 4931 gfc_ref *r;
4932 gfc_constructor *c;
4933
4d42b5cd
JJ		 4934 int result = exprfn (e, &walk_subtrees, data);
4935 if (result)
4936 return result;
4937 if (walk_subtrees)
4938 switch ((*e)->expr_type)
4939 {
4940 case EXPR_OP:
4941 WALK_SUBEXPR ((*e)->value.op.op1);
4942 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
4943 break;
4944 case EXPR_FUNCTION:
4945 for (a = (*e)->value.function.actual; a; a = a->next)
4946 WALK_SUBEXPR (a->expr);
4947 break;
4948 case EXPR_COMPCALL:
4949 case EXPR_PPC:
4950 WALK_SUBEXPR ((*e)->value.compcall.base_object);
4951 for (a = (*e)->value.compcall.actual; a; a = a->next)
4952 WALK_SUBEXPR (a->expr);
4953 break;
46f19baf
TK		 4954
4955 case EXPR_STRUCTURE:
4956 case EXPR_ARRAY:
4957 for (c = gfc_constructor_first ((*e)->value.constructor); c;
4958 c = gfc_constructor_next (c))
4959 {
8144d290
TK		 4960 if (c->iterator == NULL)
4961 WALK_SUBEXPR (c->expr);
4962 else
46f19baf 4963 {
8144d290
TK		 4964 iterator_level ++;
4965 WALK_SUBEXPR (c->expr);
4966 iterator_level --;
46f19baf
TK		 4967 WALK_SUBEXPR (c->iterator->var);
4968 WALK_SUBEXPR (c->iterator->start);
4969 WALK_SUBEXPR (c->iterator->end);
4970 WALK_SUBEXPR (c->iterator->step);
4971 }
4972 }
4973
4974 if ((*e)->expr_type != EXPR_ARRAY)
4975 break;
4976
4977 /* Fall through to the variable case in order to walk the
dd5a833e 4978 reference. */
81fea426 4979 gcc_fallthrough ();
46f19baf 4980
1151446c 4981 case EXPR_SUBSTRING:
46f19baf
TK		 4982 case EXPR_VARIABLE:
4983 for (r = (*e)->ref; r; r = r->next)
4984 {
4985 gfc_array_ref *ar;
4986 int i;
4987
4988 switch (r->type)
4989 {
4990 case REF_ARRAY:
4991 ar = &r->u.ar;
4992 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
4993 {
4994 for (i=0; i< ar->dimen; i++)
4995 {
4996 WALK_SUBEXPR (ar->start[i]);
4997 WALK_SUBEXPR (ar->end[i]);
4998 WALK_SUBEXPR (ar->stride[i]);
4999 }
5000 }
5001
5002 break;
5003
5004 case REF_SUBSTRING:
5005 WALK_SUBEXPR (r->u.ss.start);
5006 WALK_SUBEXPR (r->u.ss.end);
5007 break;
5008
5009 case REF_COMPONENT:
a5fbc2f3 5010 case REF_INQUIRY:
46f19baf
TK		 5011 break;
5012 }
5013 }
5014
4d42b5cd
JJ		 5015 default:
5016 break;
5017 }
5018 return 0;
5019 }
5020 return 0;
5021}
601d98be 5022
4d42b5cd
JJ		 5023#define WALK_SUBCODE(NODE) \
5024 do \
5025 { \
5026 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5027 if (result) \
5028 return result; \
5029 } \
5030 while (0)
5031
5032/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5033 on each expression in it. If any of the hooks returns non-zero, that
5034 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5035 no subcodes or subexpressions are traversed. */
5036
5037int
5038gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
5039 void *data)
5040{
5041 for (; *c; c = &(*c)->next)
601d98be 5042 {
4d42b5cd
JJ		 5043 int walk_subtrees = 1;
5044 int result = codefn (c, &walk_subtrees, data);
5045 if (result)
5046 return result;
bc81f559 5047
4d42b5cd
JJ		 5048 if (walk_subtrees)
5049 {
5050 gfc_code *b;
bc81f559 5051 gfc_actual_arglist *a;
82358e09 5052 gfc_code *co;
930d4d4e 5053 gfc_association_list *alist;
e07e39f6 5054 bool saved_in_omp_workshare;
a7a09efa 5055 bool saved_in_omp_atomic;
fd42eed8 5056 bool saved_in_where;
82358e09
TK		 5057
5058 /* There might be statement insertions before the current code,
5059 which must not affect the expression walker. */
5060
5061 co = *c;
e07e39f6 5062 saved_in_omp_workshare = in_omp_workshare;
a7a09efa 5063 saved_in_omp_atomic = in_omp_atomic;
fd42eed8 5064 saved_in_where = in_where;
bc81f559 5065
82358e09 5066 switch (co->op)
4d42b5cd 5067 {
930d4d4e
TK		 5068
5069 case EXEC_BLOCK:
5070 WALK_SUBCODE (co->ext.block.ns->code);
e3f9e757
TK		 5071 if (co->ext.block.assoc)
5072 {
5073 bool saved_in_assoc_list = in_assoc_list;
5074
5075 in_assoc_list = true;
5076 for (alist = co->ext.block.assoc; alist; alist = alist->next)
5077 WALK_SUBEXPR (alist->target);
5078
5079 in_assoc_list = saved_in_assoc_list;
5080 }
5081
930d4d4e
TK		 5082 break;
5083
4d42b5cd 5084 case EXEC_DO:
305a35da 5085 doloop_level ++;
82358e09
TK		 5086 WALK_SUBEXPR (co->ext.iterator->var);
5087 WALK_SUBEXPR (co->ext.iterator->start);
5088 WALK_SUBEXPR (co->ext.iterator->end);
5089 WALK_SUBEXPR (co->ext.iterator->step);
4d42b5cd 5090 break;
bc81f559 5091
15e23330
TK		 5092 case EXEC_IF:
5093 if_level ++;
5094 break;
5095
fd42eed8
TK		 5096 case EXEC_WHERE:
5097 in_where = true;
5098 break;
5099
bc81f559
TK		 5100 case EXEC_CALL:
5101 case EXEC_ASSIGN_CALL:
82358e09 5102 for (a = co->ext.actual; a; a = a->next)
bc81f559
TK		 5103 WALK_SUBEXPR (a->expr);
5104 break;
5105
5106 case EXEC_CALL_PPC:
82358e09
TK		 5107 WALK_SUBEXPR (co->expr1);
5108 for (a = co->ext.actual; a; a = a->next)
bc81f559
TK		 5109 WALK_SUBEXPR (a->expr);
5110 break;
5111
4d42b5cd 5112 case EXEC_SELECT:
82358e09 5113 WALK_SUBEXPR (co->expr1);
15e23330 5114 select_level ++;
82358e09 5115 for (b = co->block; b; b = b->block)
4d42b5cd
JJ		 5116 {
5117 gfc_case *cp;
29a63d67 5118 for (cp = b->ext.block.case_list; cp; cp = cp->next)
4d42b5cd
JJ		 5119 {
5120 WALK_SUBEXPR (cp->low);
5121 WALK_SUBEXPR (cp->high);
5122 }
5123 WALK_SUBCODE (b->next);
5124 }
5125 continue;
bc81f559 5126
4d42b5cd
JJ		 5127 case EXEC_ALLOCATE:
5128 case EXEC_DEALLOCATE:
5129 {
5130 gfc_alloc *a;
82358e09 5131 for (a = co->ext.alloc.list; a; a = a->next)
4d42b5cd
JJ		 5132 WALK_SUBEXPR (a->expr);
5133 break;
5134 }
bc81f559 5135
4d42b5cd 5136 case EXEC_FORALL:
8c6a85e3 5137 case EXEC_DO_CONCURRENT:
4d42b5cd
JJ		 5138 {
5139 gfc_forall_iterator *fa;
82358e09 5140 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
4d42b5cd
JJ		 5141 {
5142 WALK_SUBEXPR (fa->var);
5143 WALK_SUBEXPR (fa->start);
5144 WALK_SUBEXPR (fa->end);
5145 WALK_SUBEXPR (fa->stride);
5146 }
2855325f
TK		 5147 if (co->op == EXEC_FORALL)
5148 forall_level ++;
4d42b5cd
JJ		 5149 break;
5150 }
bc81f559 5151
4d42b5cd 5152 case EXEC_OPEN:
82358e09
TK		 5153 WALK_SUBEXPR (co->ext.open->unit);
5154 WALK_SUBEXPR (co->ext.open->file);
5155 WALK_SUBEXPR (co->ext.open->status);
5156 WALK_SUBEXPR (co->ext.open->access);
5157 WALK_SUBEXPR (co->ext.open->form);
5158 WALK_SUBEXPR (co->ext.open->recl);
5159 WALK_SUBEXPR (co->ext.open->blank);
5160 WALK_SUBEXPR (co->ext.open->position);
5161 WALK_SUBEXPR (co->ext.open->action);
5162 WALK_SUBEXPR (co->ext.open->delim);
5163 WALK_SUBEXPR (co->ext.open->pad);
5164 WALK_SUBEXPR (co->ext.open->iostat);
5165 WALK_SUBEXPR (co->ext.open->iomsg);
5166 WALK_SUBEXPR (co->ext.open->convert);
5167 WALK_SUBEXPR (co->ext.open->decimal);
5168 WALK_SUBEXPR (co->ext.open->encoding);
5169 WALK_SUBEXPR (co->ext.open->round);
5170 WALK_SUBEXPR (co->ext.open->sign);
5171 WALK_SUBEXPR (co->ext.open->asynchronous);
5172 WALK_SUBEXPR (co->ext.open->id);
5173 WALK_SUBEXPR (co->ext.open->newunit);
0ef33d44
FR		 5174 WALK_SUBEXPR (co->ext.open->share);
5175 WALK_SUBEXPR (co->ext.open->cc);
4d42b5cd 5176 break;
bc81f559 5177
4d42b5cd 5178 case EXEC_CLOSE:
82358e09
TK		 5179 WALK_SUBEXPR (co->ext.close->unit);
5180 WALK_SUBEXPR (co->ext.close->status);
5181 WALK_SUBEXPR (co->ext.close->iostat);
5182 WALK_SUBEXPR (co->ext.close->iomsg);
4d42b5cd 5183 break;
bc81f559 5184
4d42b5cd
JJ		 5185 case EXEC_BACKSPACE:
5186 case EXEC_ENDFILE:
5187 case EXEC_REWIND:
5188 case EXEC_FLUSH:
82358e09
TK		 5189 WALK_SUBEXPR (co->ext.filepos->unit);
5190 WALK_SUBEXPR (co->ext.filepos->iostat);
5191 WALK_SUBEXPR (co->ext.filepos->iomsg);
4d42b5cd 5192 break;
bc81f559 5193
4d42b5cd 5194 case EXEC_INQUIRE:
82358e09
TK		 5195 WALK_SUBEXPR (co->ext.inquire->unit);
5196 WALK_SUBEXPR (co->ext.inquire->file);
5197 WALK_SUBEXPR (co->ext.inquire->iomsg);
5198 WALK_SUBEXPR (co->ext.inquire->iostat);
5199 WALK_SUBEXPR (co->ext.inquire->exist);
5200 WALK_SUBEXPR (co->ext.inquire->opened);
5201 WALK_SUBEXPR (co->ext.inquire->number);
5202 WALK_SUBEXPR (co->ext.inquire->named);
5203 WALK_SUBEXPR (co->ext.inquire->name);
5204 WALK_SUBEXPR (co->ext.inquire->access);
5205 WALK_SUBEXPR (co->ext.inquire->sequential);
5206 WALK_SUBEXPR (co->ext.inquire->direct);
5207 WALK_SUBEXPR (co->ext.inquire->form);
5208 WALK_SUBEXPR (co->ext.inquire->formatted);
5209 WALK_SUBEXPR (co->ext.inquire->unformatted);
5210 WALK_SUBEXPR (co->ext.inquire->recl);
5211 WALK_SUBEXPR (co->ext.inquire->nextrec);
5212 WALK_SUBEXPR (co->ext.inquire->blank);
5213 WALK_SUBEXPR (co->ext.inquire->position);
5214 WALK_SUBEXPR (co->ext.inquire->action);
5215 WALK_SUBEXPR (co->ext.inquire->read);
5216 WALK_SUBEXPR (co->ext.inquire->write);
5217 WALK_SUBEXPR (co->ext.inquire->readwrite);
5218 WALK_SUBEXPR (co->ext.inquire->delim);
5219 WALK_SUBEXPR (co->ext.inquire->encoding);
5220 WALK_SUBEXPR (co->ext.inquire->pad);
5221 WALK_SUBEXPR (co->ext.inquire->iolength);
5222 WALK_SUBEXPR (co->ext.inquire->convert);
5223 WALK_SUBEXPR (co->ext.inquire->strm_pos);
5224 WALK_SUBEXPR (co->ext.inquire->asynchronous);
5225 WALK_SUBEXPR (co->ext.inquire->decimal);
5226 WALK_SUBEXPR (co->ext.inquire->pending);
5227 WALK_SUBEXPR (co->ext.inquire->id);
5228 WALK_SUBEXPR (co->ext.inquire->sign);
5229 WALK_SUBEXPR (co->ext.inquire->size);
5230 WALK_SUBEXPR (co->ext.inquire->round);
4d42b5cd 5231 break;
bc81f559 5232
4d42b5cd 5233 case EXEC_WAIT:
82358e09
TK		 5234 WALK_SUBEXPR (co->ext.wait->unit);
5235 WALK_SUBEXPR (co->ext.wait->iostat);
5236 WALK_SUBEXPR (co->ext.wait->iomsg);
5237 WALK_SUBEXPR (co->ext.wait->id);
4d42b5cd 5238 break;
bc81f559 5239
4d42b5cd
JJ		 5240 case EXEC_READ:
5241 case EXEC_WRITE:
82358e09
TK		 5242 WALK_SUBEXPR (co->ext.dt->io_unit);
5243 WALK_SUBEXPR (co->ext.dt->format_expr);
5244 WALK_SUBEXPR (co->ext.dt->rec);
5245 WALK_SUBEXPR (co->ext.dt->advance);
5246 WALK_SUBEXPR (co->ext.dt->iostat);
5247 WALK_SUBEXPR (co->ext.dt->size);
5248 WALK_SUBEXPR (co->ext.dt->iomsg);
5249 WALK_SUBEXPR (co->ext.dt->id);
5250 WALK_SUBEXPR (co->ext.dt->pos);
5251 WALK_SUBEXPR (co->ext.dt->asynchronous);
5252 WALK_SUBEXPR (co->ext.dt->blank);
5253 WALK_SUBEXPR (co->ext.dt->decimal);
5254 WALK_SUBEXPR (co->ext.dt->delim);
5255 WALK_SUBEXPR (co->ext.dt->pad);
5256 WALK_SUBEXPR (co->ext.dt->round);
5257 WALK_SUBEXPR (co->ext.dt->sign);
5258 WALK_SUBEXPR (co->ext.dt->extra_comma);
4d42b5cd 5259 break;
bc81f559 5260
6a97d9ea 5261 case EXEC_OACC_ATOMIC:
a7a09efa
JJ		 5262 case EXEC_OMP_ATOMIC:
5263 in_omp_atomic = true;
5264 break;
5265
4d42b5cd
JJ		 5266 case EXEC_OMP_PARALLEL:
5267 case EXEC_OMP_PARALLEL_DO:
dd2fc525 5268 case EXEC_OMP_PARALLEL_DO_SIMD:
4d42b5cd 5269 case EXEC_OMP_PARALLEL_SECTIONS:
e07e39f6
TK		 5270
5271 in_omp_workshare = false;
5272
5273 /* This goto serves as a shortcut to avoid code
5274 duplication or a larger if or switch statement. */
5275 goto check_omp_clauses;
7474dcc1 5276
e07e39f6 5277 case EXEC_OMP_WORKSHARE:
4d42b5cd 5278 case EXEC_OMP_PARALLEL_WORKSHARE:
e07e39f6
TK		 5279
5280 in_omp_workshare = true;
5281
5282 /* Fall through */
f014c653 5283
b4c3a85b 5284 case EXEC_OMP_CRITICAL:
f014c653
JJ		 5285 case EXEC_OMP_DISTRIBUTE:
5286 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5287 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5288 case EXEC_OMP_DISTRIBUTE_SIMD:
e07e39f6 5289 case EXEC_OMP_DO:
dd2fc525 5290 case EXEC_OMP_DO_SIMD:
b4c3a85b 5291 case EXEC_OMP_ORDERED:
4d42b5cd
JJ		 5292 case EXEC_OMP_SECTIONS:
5293 case EXEC_OMP_SINGLE:
4d42b5cd 5294 case EXEC_OMP_END_SINGLE:
dd2fc525 5295 case EXEC_OMP_SIMD:
b4c3a85b
JJ		 5296 case EXEC_OMP_TASKLOOP:
5297 case EXEC_OMP_TASKLOOP_SIMD:
f014c653
JJ		 5298 case EXEC_OMP_TARGET:
5299 case EXEC_OMP_TARGET_DATA:
b4c3a85b
JJ		 5300 case EXEC_OMP_TARGET_ENTER_DATA:
5301 case EXEC_OMP_TARGET_EXIT_DATA:
5302 case EXEC_OMP_TARGET_PARALLEL:
5303 case EXEC_OMP_TARGET_PARALLEL_DO:
5304 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5305 case EXEC_OMP_TARGET_SIMD:
f014c653
JJ		 5306 case EXEC_OMP_TARGET_TEAMS:
5307 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5308 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5309 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5310 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5311 case EXEC_OMP_TARGET_UPDATE:
4d42b5cd 5312 case EXEC_OMP_TASK:
f014c653
JJ		 5313 case EXEC_OMP_TEAMS:
5314 case EXEC_OMP_TEAMS_DISTRIBUTE:
5315 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5316 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5317 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
e07e39f6
TK		 5318
5319 /* Come to this label only from the
5320 EXEC_OMP_PARALLEL_* cases above. */
5321
5322 check_omp_clauses:
5323
82358e09 5324 if (co->ext.omp_clauses)
4d42b5cd 5325 {
f014c653
JJ		 5326 gfc_omp_namelist *n;
5327 static int list_types[]
5328 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
5329 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
5330 size_t idx;
82358e09 5331 WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
20906c66 5332 WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
82358e09
TK		 5333 WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
5334 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
dd2fc525
JJ		 5335 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
5336 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
f014c653
JJ		 5337 WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
5338 WALK_SUBEXPR (co->ext.omp_clauses->device);
5339 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
5340 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
b4c3a85b
JJ		 5341 WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
5342 WALK_SUBEXPR (co->ext.omp_clauses->hint);
5343 WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
5344 WALK_SUBEXPR (co->ext.omp_clauses->priority);
5345 for (idx = 0; idx < OMP_IF_LAST; idx++)
5346 WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
f014c653
JJ		 5347 for (idx = 0;
5348 idx < sizeof (list_types) / sizeof (list_types[0]);
5349 idx++)
5350 for (n = co->ext.omp_clauses->lists[list_types[idx]];
5351 n; n = n->next)
5352 WALK_SUBEXPR (n->expr);
4d42b5cd
JJ		 5353 }
5354 break;
5355 default:
5356 break;
5357 }
bc81f559 5358
82358e09
TK		 5359 WALK_SUBEXPR (co->expr1);
5360 WALK_SUBEXPR (co->expr2);
5361 WALK_SUBEXPR (co->expr3);
5493aa17 5362 WALK_SUBEXPR (co->expr4);
82358e09 5363 for (b = co->block; b; b = b->block)
4d42b5cd
JJ		 5364 {
5365 WALK_SUBEXPR (b->expr1);
5366 WALK_SUBEXPR (b->expr2);
5367 WALK_SUBCODE (b->next);
5368 }
2855325f
TK		 5369
5370 if (co->op == EXEC_FORALL)
5371 forall_level --;
5372
305a35da
TK		 5373 if (co->op == EXEC_DO)
5374 doloop_level --;
5375
15e23330
TK		 5376 if (co->op == EXEC_IF)
5377 if_level --;
5378
5379 if (co->op == EXEC_SELECT)
5380 select_level --;
2efade53 5381
e07e39f6 5382 in_omp_workshare = saved_in_omp_workshare;
a7a09efa 5383 in_omp_atomic = saved_in_omp_atomic;
fd42eed8 5384 in_where = saved_in_where;
4d42b5cd 5385 }
601d98be 5386 }
4d42b5cd 5387 return 0;
601d98be 5388}
fb078366
TK		 5389
5390/* As a post-resolution step, check that all global symbols which are
5391 not declared in the source file match in their call signatures.
5392 We do this by looping over the code (and expressions). The first call
5393 we happen to find is assumed to be canonical. */
5394
e68a35ae
TK		 5395
5396/* Common tests for argument checking for both functions and subroutines. */
fb078366
TK		 5397
5398static int
e0b9e5f9
TK		 5399check_externals_procedure (gfc_symbol *sym, locus *loc,
5400 gfc_actual_arglist *actual)
fb078366 5401{
fb078366 5402 gfc_gsymbol *gsym;
e68a35ae 5403 gfc_symbol *def_sym = NULL;
fb078366 5404
e68a35ae 5405 if (sym == NULL || sym->attr.is_bind_c)
fb078366
TK		 5406 return 0;
5407
e68a35ae 5408 if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
fb078366
TK		 5409 return 0;
5410
e68a35ae 5411 if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
fb078366
TK		 5412 return 0;
5413
5414 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
5415 if (gsym == NULL)
5416 return 0;
5417
e68a35ae
TK		 5418 if (gsym->ns)
5419 gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
fb078366 5420
e68a35ae
TK		 5421 if (def_sym)
5422 {
e0b9e5f9 5423 gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
e68a35ae
TK		 5424 return 0;
5425 }
5426
5427 /* First time we have seen this procedure called. Let's create an
5428 "interface" from the call and put it into a new namespace. */
5429 gfc_namespace *save_ns;
5430 gfc_symbol *new_sym;
5431
5432 gsym->where = *loc;
5433 save_ns = gfc_current_ns;
5434 gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
5435 gsym->ns->proc_name = sym;
5436
5437 gfc_get_symbol (sym->name, gsym->ns, &new_sym);
5438 gcc_assert (new_sym);
5439 new_sym->attr = sym->attr;
5440 new_sym->attr.if_source = IFSRC_DECL;
5441 gfc_current_ns = gsym->ns;
5442
5443 gfc_get_formal_from_actual_arglist (new_sym, actual);
5444 gfc_current_ns = save_ns;
fb078366
TK		 5445
5446 return 0;
e68a35ae 5447
fb078366
TK		 5448}
5449
e68a35ae 5450/* Callback for calls of external routines. */
fb078366
TK		 5451
5452static int
5453check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5454 void *data ATTRIBUTE_UNUSED)
5455{
5456 gfc_code *co = *c;
e68a35ae
TK		 5457 gfc_symbol *sym;
5458 locus *loc;
5459 gfc_actual_arglist *actual;
fb078366
TK		 5460
5461 if (co->op != EXEC_CALL)
5462 return 0;
5463
5464 sym = co->resolved_sym;
e68a35ae
TK		 5465 loc = &co->loc;
5466 actual = co->ext.actual;
fb078366 5467
e68a35ae 5468 return check_externals_procedure (sym, loc, actual);
fb078366 5469
e68a35ae 5470}
fb078366 5471
e68a35ae
TK		 5472/* Callback for external functions. */
5473
5474static int
5475check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
5476 void *data ATTRIBUTE_UNUSED)
5477{
5478 gfc_expr *e = *ep;
5479 gfc_symbol *sym;
5480 locus *loc;
5481 gfc_actual_arglist *actual;
5482
5483 if (e->expr_type != EXPR_FUNCTION)
fb078366
TK		 5484 return 0;
5485
e68a35ae
TK		 5486 sym = e->value.function.esym;
5487 if (sym == NULL)
5488 return 0;
fb078366 5489
e68a35ae
TK		 5490 loc = &e->where;
5491 actual = e->value.function.actual;
fb078366 5492
e68a35ae 5493 return check_externals_procedure (sym, loc, actual);
fb078366
TK		 5494}
5495
5496/* Called routine. */
5497
5498void
5499gfc_check_externals (gfc_namespace *ns)
5500{
5501
5502 gfc_clear_error ();
5503
7a56096c 5504 /* Turn errors into warnings if the user indicated this. */
fb078366 5505
7a56096c 5506 if (!pedantic && flag_allow_argument_mismatch)
fb078366
TK		 5507 gfc_errors_to_warnings (true);
5508
5509 gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
5510
5511 for (ns = ns->contained; ns; ns = ns->sibling)
5512 {
5513 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
5514 gfc_check_externals (ns);
5515 }
5516
5517 gfc_errors_to_warnings (false);
5518}
Mirror of https://gcc.gnu.org/git/gcc.git