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