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