Bug Summary

File:build/gcc/fortran/frontend-passes.cc
Warning:line 1711, column 3
Use of memory after it is freed

Annotated Source Code

Press '?' to see keyboard shortcuts

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