/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc

Bug Summary

File:	build/gcc/fortran/frontend-passes.cc
Warning:	line 3885, column 23 The left operand of '!=' is a garbage value
Annotated Source Code

Press '?' to see keyboard shortcuts
Show analyzer invocation
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.
 Copyright (C) 2010-2023 Free Software Foundation, Inc.
 Contributed by Thomas König.

5This file is part of GCC.

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.

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.

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/>.  */

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"

30/* Forward declarations.  */

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 *,
		  locus *, gfc_namespace *,
		  char *vname=NULL__null);
54static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *,
				 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);

61#ifdef CHECKING_P1
62static void check_locus (gfc_namespace *);
63#endif

65/* How deep we are inside an argument list.  */

67static int count_arglist;

69/* Vector of gfc_expr ** we operate on.  */

71static vec<gfc_expr **> expr_array;

73/* Pointer to the gfc_code we currently work on - to be able to insert
 a block before the statement.  */

76static gfc_code **current_code;

78/* Pointer to the block to be inserted, and the statement we are
 changing within the block.  */

81static gfc_code *inserted_block, **changed_statement;

83/* The namespace we are currently dealing with.  */

85static gfc_namespace *current_ns;

87/* If we are within any forall loop.  */

89static int forall_level;

91/* Keep track of whether we are within an OMP workshare.  */

93static bool in_omp_workshare;

95/* Keep track of whether we are within an OMP atomic.  */

97static bool in_omp_atomic;

99/* Keep track of whether we are within a WHERE statement.  */

101static bool in_where;

103/* Keep track of iterators for array constructors.  */

105static int iterator_level;

107/* Keep track of DO loop levels.  */

109typedef struct {
gfc_code *c;
int branch_level;
bool seen_goto;
113} do_t;

115static vec<do_t> doloop_list;
116static int doloop_level;

118/* Keep track of if and select case levels.  */

120static int if_level;
121static int select_level;

123/* Vector of gfc_expr * to keep track of DO loops.  */

125struct my_struct *evec;

127/* Keep track of association lists.  */

129static bool in_assoc_list;

131/* Counter for temporary variables.  */

133static int var_num = 1;

135/* What sort of matrix we are dealing with when inlining MATMUL.  */

137enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T };

139/* Keep track of the number of expressions we have inserted so far
 using create_var.  */

142int n_vars;

144/* Entry point - run all passes for a namespace.  */

146void
147gfc_run_passes (gfc_namespace *ns)
148{

/* Warn about dubious DO loops where the index might
   change.  */

doloop_level = 0;
if_level = 0;
select_level = 0;
doloop_warn (ns);
doloop_list.release ();
int w, e;

160#ifdef CHECKING_P1
check_locus (ns);
162#endif

gfc_get_errors (&w, &e);
if (e > 0)
  return;

if (flag_frontend_optimizeglobal_options.x_flag_frontend_optimize || flag_frontend_loop_interchangeglobal_options.x_flag_frontend_loop_interchange)
  optimize_namespace (ns);

if (flag_frontend_optimizeglobal_options.x_flag_frontend_optimize)
  {
    optimize_reduction (ns);
    if (flag_dump_fortran_optimizedglobal_options.x_flag_dump_fortran_optimized)
gfc_dump_parse_tree (ns, stdoutstdout);

    expr_array.release ();
  }

if (flag_realloc_lhsglobal_options.x_flag_realloc_lhs)
  realloc_strings (ns);
182}

184#ifdef CHECKING_P1

186/* Callback function: Warn if there is no location information in a
 statement.  */

189static int
190check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
  void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
192{
current_code = c;
if (c && *c && (((*c)->loc.nextc == NULL__null) || ((*c)->loc.lb == NULL__null)))
  gfc_warning_internal (0, "Inconsistent internal state: "
	  "No location in statement");

return 0;
199}


202/* Callback function: Warn if there is no location information in an
 expression.  */

205static int
206check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
  void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
208{

if (e && *e && (((*e)->where.nextc == NULL__null || (*e)->where.lb == NULL__null)))
  gfc_warning_internal (0, "Inconsistent internal state: "
	  "No location in expression near %L",
	  &((*current_code)->loc));
return 0;
215}

217/* Run check for missing location information.  */

219static void
220check_locus (gfc_namespace *ns)
221{
gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL__null);

for (ns = ns->contained; ns; ns = ns->sibling)
  {
    if (ns->code == NULL__null || ns->code->op != EXEC_BLOCK)
check_locus (ns);
  }
229}

231#endif

233/* Callback for each gfc_code node invoked from check_realloc_strings.
 For an allocatable LHS string which also appears as a variable on
 the RHS, replace

 a = a(x:y)

 with

 tmp = a(x:y)
 a = tmp
*/

245static int
246realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
	 void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
248{
gfc_expr *expr1, *expr2;
gfc_code *co = *c;
gfc_expr *n;
gfc_ref *ref;
bool found_substr;

if (co->op != EXEC_ASSIGN)
  return 0;

expr1 = co->expr1;
if (expr1->ts.type != BT_CHARACTER
    || !gfc_expr_attr(expr1).allocatable
    || !expr1->ts.deferred)
  return 0;

if (is_fe_temp (expr1))
  return 0;

expr2 = gfc_discard_nops (co->expr2);

if (expr2->expr_type == EXPR_VARIABLE)
  {
    found_substr = false;
    for (ref = expr2->ref; ref; ref = ref->next)
{
 if (ref->type == REF_SUBSTRING)
   {
     found_substr = true;
     break;
   }
}
    if (!found_substr)
return 0;
  }
else if (expr2->expr_type != EXPR_ARRAY
  && (expr2->expr_type != EXPR_OP
      || expr2->value.op.op != INTRINSIC_CONCAT))
  return 0;

if (!gfc_check_dependency (expr1, expr2, true))
  return 0;

/* gfc_check_dependency doesn't always pick up identical expressions.
   However, eliminating the above sends the compiler into an infinite
   loop on valid expressions.  Without this check, the gimplifier emits
   an ICE for a = a, where a is deferred character length.  */
if (!gfc_dep_compare_expr (expr1, expr2))
  return 0;

current_code = c;
inserted_block = NULL__null;
changed_statement = NULL__null;
n = create_var (expr2, "realloc_string");
co->expr2 = n;
return 0;
304}

306/* Callback for each gfc_code node invoked through gfc_code_walker
 from optimize_namespace.  */

309static int
310optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
      void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
312{

gfc_exec_op op;

op = (*c)->op;

if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
    || op == EXEC_CALL_PPC)
  count_arglist = 1;
else
  count_arglist = 0;

current_code = c;
inserted_block = NULL__null;
changed_statement = NULL__null;

if (op == EXEC_ASSIGN)
  optimize_assignment (*c);
return 0;
331}

333/* Callback for each gfc_expr node invoked through gfc_code_walker
 from optimize_namespace.  */

336static int
337optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
      void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
339{
bool function_expr;

if ((*e)->expr_type == EXPR_FUNCTION)
  {
    count_arglist ++;
    function_expr = true;
  }
else
  function_expr = false;

if (optimize_trim (*e))
  gfc_simplify_expr (*e, 0);

if (optimize_lexical_comparison (*e))
  gfc_simplify_expr (*e, 0);

if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
  gfc_simplify_expr (*e, 0);

if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
  switch ((*e)->value.function.isym->id)
    {
    case GFC_ISYM_MINLOC:
    case GFC_ISYM_MAXLOC:
optimize_minmaxloc (e);
break;
    default:
break;
    }

if (function_expr)
  count_arglist --;

return 0;
374}

376/* Auxiliary function to handle the arguments to reduction intrinsics.  If the
 function is a scalar, just copy it; otherwise returns the new element, the
 old one can be freed.  */

380static gfc_expr *
381copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
382{
gfc_expr *fcn, *e = c->expr;

fcn = gfc_copy_expr (e);
if (c->iterator)
  {
    gfc_constructor_base newbase;
    gfc_expr *new_expr;
    gfc_constructor *new_c;

    newbase = NULL__null;
    new_expr = gfc_get_expr ();
    new_expr->expr_type = EXPR_ARRAY;
    new_expr->ts = e->ts;
    new_expr->where = e->where;
    new_expr->rank = 1;
    new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
    new_c->iterator = c->iterator;
    new_expr->value.constructor = newbase;
    c->iterator = NULL__null;

    fcn = new_expr;
  }

if (fcn->rank != 0)
  {
    gfc_isym_id id = fn->value.function.isym->id;

    if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
fcn = gfc_build_intrinsic_call (current_ns, id,
			fn->value.function.isym->name,
			fn->where, 3, fcn, NULL__null, NULL__null);
    else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
fcn = gfc_build_intrinsic_call (current_ns, id,
			fn->value.function.isym->name,
			fn->where, 2, fcn, NULL__null);
    else
gfc_internal_error ("Illegal id in copy_walk_reduction_arg");

    fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
  }

return fcn;
425}

427/* Callback function for optimzation of reductions to scalars.  Transform ANY
 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
 correspondingly.  Handly only the simple cases without MASK and DIM.  */

431static int
432callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
    void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
434{
gfc_expr *fn, *arg;
gfc_intrinsic_op op;
gfc_isym_id id;
gfc_actual_arglist *a;
gfc_actual_arglist *dim;
gfc_constructor *c;
gfc_expr *res, *new_expr;
gfc_actual_arglist *mask;

fn = *e;

if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
    || fn->value.function.isym == NULL__null)
  return 0;

id = fn->value.function.isym->id;

if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
    && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
  return 0;

a = fn->value.function.actual;

/* Don't handle MASK or DIM.  */

dim = a->next;

if (dim->expr != NULL__null)
  return 0;

if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
  {
    mask = dim->next;
    if ( mask->expr != NULL__null)
return 0;
  }

arg = a->expr;

if (arg->expr_type != EXPR_ARRAY)
  return 0;

switch (id)
  {
  case GFC_ISYM_SUM:
    op = INTRINSIC_PLUS;
    break;

  case GFC_ISYM_PRODUCT:
    op = INTRINSIC_TIMES;
    break;

  case GFC_ISYM_ANY:
    op = INTRINSIC_OR;
    break;

  case GFC_ISYM_ALL:
    op = INTRINSIC_AND;
    break;

  default:
    return 0;
  }

c = gfc_constructor_first (arg->value.constructor);

/* Don't do any simplififcation if we have
   - no element in the constructor or
   - only have a single element in the array which contains an
   iterator.  */

if (c == NULL__null)
  return 0;

res = copy_walk_reduction_arg (c, fn);

c = gfc_constructor_next (c);
while (c)
  {
    new_expr = gfc_get_expr ();
    new_expr->ts = fn->ts;
    new_expr->expr_type = EXPR_OP;
    new_expr->rank = fn->rank;
    new_expr->where = fn->where;
    new_expr->value.op.op = op;
    new_expr->value.op.op1 = res;
    new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
    res = new_expr;
    c = gfc_constructor_next (c);
  }

gfc_simplify_expr (res, 0);
*e = res;
gfc_free_expr (fn);

return 0;
531}

533/* Callback function for common function elimination, called from cfe_expr_0.
 Put all eligible function expressions into expr_array.  */

536static int
537cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
 void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
539{

if ((*e)->expr_type != EXPR_FUNCTION)
  return 0;

/* We don't do character functions with unknown charlens.  */
if ((*e)->ts.type == BT_CHARACTER
    && ((*e)->ts.u.cl == NULL__null || (*e)->ts.u.cl->length == NULL__null
 || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
  return 0;

/* We don't do function elimination within FORALL statements, it can
   lead to wrong-code in certain circumstances.  */

if (forall_level > 0)
  return 0;

/* Function elimination inside an iterator could lead to functions which
   depend on iterator variables being moved outside.  FIXME: We should check
   if the functions do indeed depend on the iterator variable.  */

if (iterator_level > 0)
  return 0;

/* If we don't know the shape at compile time, we create an allocatable
   temporary variable to hold the intermediate result, but only if
   allocation on assignment is active.  */

if ((*e)->rank > 0 && (*e)->shape == NULL__null && !flag_realloc_lhsglobal_options.x_flag_realloc_lhs)
  return 0;

/* Skip the test for pure functions if -faggressive-function-elimination
   is specified.  */
if ((*e)->value.function.esym)
  {
    /* Don't create an array temporary for elemental functions.  */
    if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
return 0;

    /* Only eliminate potentially impure functions if the
user specifically requested it.  */
    if (!flag_aggressive_function_eliminationglobal_options.x_flag_aggressive_function_elimination
 && !(*e)->value.function.esym->attr.pure
 && !(*e)->value.function.esym->attr.implicit_pure)
return 0;
  }

if ((*e)->value.function.isym)
  {
    /* Conversions are handled on the fly by the middle end,
transpose during trans-* stages and TRANSFER by the middle end.  */
    if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
 || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
 || gfc_inline_intrinsic_function_p (*e))
return 0;

    /* Don't create an array temporary for elemental functions,
as this would be wasteful of memory.
FIXME: Create a scalar temporary during scalarization.  */
    if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
return 0;

    if (!(*e)->value.function.isym->pure)
return 0;
  }

expr_array.safe_push (e);
return 0;
607}

609/* Auxiliary function to check if an expression is a temporary created by
 create var.  */

612static bool
613is_fe_temp (gfc_expr *e)
614{
if (e->expr_type != EXPR_VARIABLE)
  return false;

return e->symtree->n.sym->attr.fe_temp;
619}

621/* Determine the length of a string, if it can be evaluated as a constant
 expression.  Return a newly allocated gfc_expr or NULL on failure.
 If the user specified a substring which is potentially longer than
 the string itself, the string will be padded with spaces, which
 is harmless.  */

627static gfc_expr *
628constant_string_length (gfc_expr *e)
629{

gfc_expr *length;
gfc_ref *ref;
gfc_expr *res;
mpz_t value;

if (e->ts.u.cl)
  {
    length = e->ts.u.cl->length;
    if (length && length->expr_type == EXPR_CONSTANT)
return gfc_copy_expr(length);
  }

/* See if there is a substring. If it has a constant length, return
   that and NULL otherwise.  */
for (ref = e->ref; ref; ref = ref->next)
  {
    if (ref->type == REF_SUBSTRING)
{
 if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
   {
     res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
			   &e->where);

     mpz_add_ui__gmpz_add_ui (res->value.integer, value, 1);
     mpz_clear__gmpz_clear (value);
     return res;
   }
 else
   return NULL__null;
}
  }

/* Return length of char symbol, if constant.  */
if (e->symtree && e->symtree->n.sym->ts.u.cl
    && e->symtree->n.sym->ts.u.cl->length
    && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
  return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);

return NULL__null;

671}

673/* Insert a block at the current position unless it has already
 been inserted; in this case use the one already there.  */

676static gfc_namespace*
677insert_block ()
678{
gfc_namespace *ns;

/* If the block hasn't already been created, do so.  */
if (inserted_block == NULL__null)
  {
    inserted_block = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
    inserted_block->op = EXEC_BLOCK;
    inserted_block->loc = (*current_code)->loc;
    ns = gfc_build_block_ns (current_ns);
    inserted_block->ext.block.ns = ns;
    inserted_block->ext.block.assoc = NULL__null;

    ns->code = *current_code;

    /* If the statement has a label,  make sure it is transferred to
the newly created block.  */

    if ((*current_code)->here)
{
 inserted_block->here = (*current_code)->here;
 (*current_code)->here = NULL__null;
}

    inserted_block->next = (*current_code)->next;
    changed_statement = &(inserted_block->ext.block.ns->code);
    (*current_code)->next = NULL__null;
    /* Insert the BLOCK at the right position.  */
    *current_code = inserted_block;
    ns->parent = current_ns;
  }
else
  ns = inserted_block->ext.block.ns;

return ns;
713}


716/* Insert a call to the intrinsic len. Use a different name for
 the symbol tree so we don't run into trouble when the user has
 renamed len for some reason.  */

720static gfc_expr*
721get_len_call (gfc_expr *str)
722{
gfc_expr *fcn;
gfc_actual_arglist *actual_arglist;

fcn = gfc_get_expr ();
fcn->expr_type = EXPR_FUNCTION;
fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
actual_arglist = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
actual_arglist->expr = str;

fcn->value.function.actual = actual_arglist;
fcn->where = str->where;
fcn->ts.type = BT_INTEGER;
fcn->ts.kind = gfc_charlen_int_kind;

gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
fcn->symtree->n.sym->ts = fcn->ts;
fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
fcn->symtree->n.sym->attr.function = 1;
fcn->symtree->n.sym->attr.elemental = 1;
fcn->symtree->n.sym->attr.referenced = 1;
fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
gfc_commit_symbol (fcn->symtree->n.sym);

return fcn;
747}


750/* Returns a new expression (a variable) to be used in place of the old one,
 with an optional assignment statement before the current statement to set
 the value of the variable. Creates a new BLOCK for the statement if that
 hasn't already been done and puts the statement, plus the newly created
 variables, in that block.  Special cases: If the expression is constant or
 a temporary which has already been created, just copy it.  */

757static gfc_expr*
758create_var (gfc_expr * e, const char *vname)
759{
char name[GFC_MAX_SYMBOL_LEN63 +1];
gfc_symtree *symtree;
gfc_symbol *symbol;
gfc_expr *result;
gfc_code *n;
gfc_namespace *ns;
int i;
bool deferred;

if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
  return gfc_copy_expr (e);

/* Creation of an array of unknown size requires realloc on assignment.
   If that is not possible, just return NULL.  */
if (flag_realloc_lhsglobal_options.x_flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL__null)
  return NULL__null;

ns = insert_block ();

if (vname)
  snprintf (name, GFC_MAX_SYMBOL_LEN63, "__var_%d_%s", var_num++, vname);
else
  snprintf (name, GFC_MAX_SYMBOL_LEN63, "__var_%d", var_num++);

if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
  gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 785, __FUNCTION__));

symbol = symtree->n.sym;
symbol->ts = e->ts;

if (e->rank > 0)
  {
    symbol->as = gfc_get_array_spec ()((gfc_array_spec *) xcalloc (1, sizeof (gfc_array_spec)));
    symbol->as->rank = e->rank;

    if (e->shape == NULL__null)
{
 /* We don't know the shape at compile time, so we use an
    allocatable.  */
 symbol->as->type = AS_DEFERRED;
 symbol->attr.allocatable = 1;
}
    else
{
 symbol->as->type = AS_EXPLICIT;
 /* Copy the shape.  */
 for (i=0; i<e->rank; i++)
   {
     gfc_expr *p, *q;

     p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
			 &(e->where));
     mpz_set_si__gmpz_set_si (p->value.integer, 1);
     symbol->as->lower[i] = p;

     q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
			 &(e->where));
     mpz_set__gmpz_set (q->value.integer, e->shape[i]);
     symbol->as->upper[i] = q;
   }
}
  }

deferred = 0;
if (e->ts.type == BT_CHARACTER)
  {
    gfc_expr *length;

    symbol->ts.u.cl = gfc_new_charlen (ns, NULL__null);
    length = constant_string_length (e);
    if (length)
symbol->ts.u.cl->length = length;
    else if (e->expr_type == EXPR_VARIABLE
      && e->symtree->n.sym->ts.type == BT_CHARACTER
      && e->ts.u.cl->length)
symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
    else
{
 symbol->attr.allocatable = 1;
 symbol->ts.u.cl->length = NULL__null;
 symbol->ts.deferred = 1;
 deferred = 1;
}
  }

symbol->attr.flavor = FL_VARIABLE;
symbol->attr.referenced = 1;
symbol->attr.dimension = e->rank > 0;
symbol->attr.fe_temp = 1;
gfc_commit_symbol (symbol);

result = gfc_get_expr ();
result->expr_type = EXPR_VARIABLE;
result->ts = symbol->ts;
result->ts.deferred = deferred;
result->rank = e->rank;
result->shape = gfc_copy_shape (e->shape, e->rank);
result->symtree = symtree;
result->where = e->where;
if (e->rank > 0)
  {
    result->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
    result->ref->type = REF_ARRAY;
    result->ref->u.ar.type = AR_FULL;
    result->ref->u.ar.where = e->where;
    result->ref->u.ar.dimen = e->rank;
    result->ref->u.ar.as = symbol->ts.type == BT_CLASS
	     ? CLASS_DATA (symbol)symbol->ts.u.derived->components->as : symbol->as;
    if (warn_array_temporariesglobal_options.x_warn_array_temporaries)
gfc_warning (OPT_Warray_temporaries,
     "Creating array temporary at %L", &(e->where));
  }

/* Generate the new assignment.  */
n = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
n->op = EXEC_ASSIGN;
n->loc = (*current_code)->loc;
n->next = *changed_statement;
n->expr1 = gfc_copy_expr (result);
n->expr2 = e;
*changed_statement = n;
n_vars ++;

return result;
884}

886/* Warn about function elimination.  */

888static void
889do_warn_function_elimination (gfc_expr *e)
890{
const char *name;
if (e->expr_type == EXPR_FUNCTION
    && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e))
 {
    if (name)
 gfc_warning (OPT_Wfunction_elimination,
      "Removing call to impure function %qs at %L", name,
      &(e->where));
    else
 gfc_warning (OPT_Wfunction_elimination,
      "Removing call to impure function at %L",
      &(e->where));
 }
904}


907/* Callback function for the code walker for doing common function
 elimination.  This builds up the list of functions in the expression
 and goes through them to detect duplicates, which it then replaces
 by variables.  */

912static int
913cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
 void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
915{
int i,j;
gfc_expr *newvar;
gfc_expr **ei, **ej;

/* Don't do this optimization within OMP workshare/atomic or ASSOC lists.  */

if (in_omp_workshare || in_omp_atomic || in_assoc_list)
  {
    *walk_subtrees = 0;
    return 0;
  }

expr_array.release ();

gfc_expr_walker (e, cfe_register_funcs, NULL__null);

/* Walk through all the functions.  */

FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)for (i = (1); (expr_array).iterate ((i), &(ei)); ++(i))
  {
    /* Skip if the function has been replaced by a variable already.  */
    if ((*ei)->expr_type == EXPR_VARIABLE)
continue;

    newvar = NULL__null;
    for (j=0; j<i; j++)
{
 ej = expr_array[j];
 if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
   {
     if (newvar == NULL__null)
newvar = create_var (*ei, "fcn");

     if (warn_function_eliminationglobal_options.x_warn_function_elimination)
do_warn_function_elimination (*ej);

     free (*ej);
     *ej = gfc_copy_expr (newvar);
   }
}
    if (newvar)
*ei = newvar;
  }

/* We did all the necessary walking in this function.  */
*walk_subtrees = 0;
return 0;
963}

965/* Callback function for common function elimination, called from
 gfc_code_walker.  This keeps track of the current code, in order
 to insert statements as needed.  */

969static int
970cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
971{
current_code = c;
inserted_block = NULL__null;
changed_statement = NULL__null;

/* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
   and allocation on assignment are prohibited inside WHERE, and finally
   masking an expression would lead to wrong-code when replacing

   WHERE (a>0)
     b = sum(foo(a) + foo(a))
   END WHERE

   with

   WHERE (a > 0)
     tmp = foo(a)
     b = sum(tmp + tmp)
   END WHERE
990*/

if ((*c)->op == EXEC_WHERE)
  {
    *walk_subtrees = 0;
    return 0;
  }


return 0;
1000}

1002/* Dummy function for expression call back, for use when we
 really don't want to do any walking.  */

1005static int
1006dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED__attribute__ ((__unused__)), int *walk_subtrees,
     void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
1008{
*walk_subtrees = 0;
return 0;
1011}

1013/* Dummy function for code callback, for use when we really
 don't want to do anything.  */
1015int
1016gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
	 int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
	 void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
1019{
return 0;
1021}

1023/* Code callback function for converting
 do while(a)
 end do
 into the equivalent
 do
   if (.not. a) exit
 end do
 This is because common function elimination would otherwise place the
 temporary variables outside the loop.  */

1033static int
1034convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
  void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
1036{
gfc_code *co = *c;
gfc_code *c_if1, *c_if2, *c_exit;
gfc_code *loopblock;
gfc_expr *e_not, *e_cond;

if (co->op != EXEC_DO_WHILE)
  return 0;

if (co->expr1 == NULL__null || co->expr1->expr_type == EXPR_CONSTANT)
  return 0;

e_cond = co->expr1;

/* Generate the condition of the if statement, which is .not. the original
   statement.  */
e_not = gfc_get_expr ();
e_not->ts = e_cond->ts;
e_not->where = e_cond->where;
e_not->expr_type = EXPR_OP;
e_not->value.op.op = INTRINSIC_NOT;
e_not->value.op.op1 = e_cond;

/* Generate the EXIT statement.  */
c_exit = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
c_exit->op = EXEC_EXIT;
c_exit->ext.which_construct = co;
c_exit->loc = co->loc;

/* Generate the IF statement.  */
c_if2 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
c_if2->op = EXEC_IF;
c_if2->expr1 = e_not;
c_if2->next = c_exit;
c_if2->loc = co->loc;

/* ... plus the one to chain it to.  */
c_if1 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
c_if1->op = EXEC_IF;
c_if1->block = c_if2;
c_if1->loc = co->loc;

/* Make the DO WHILE loop into a DO block by replacing the condition
   with a true constant.  */
co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);

/* Hang the generated if statement into the loop body.  */

loopblock = co->block->next;
co->block->next = c_if1;
c_if1->next = loopblock;

return 0;
1089}

1091/* Code callback function for converting
 if (a) then
 ...
 else if (b) then
 end if

 into
 if (a) then
 else
   if (b) then
   end if
 end if

 because otherwise common function elimination would place the BLOCKs
 into the wrong place.  */

1107static int
1108convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
1110{
gfc_code *co = *c;
gfc_code *c_if1, *c_if2, *else_stmt;

if (co->op != EXEC_IF)
  return 0;

/* This loop starts out with the first ELSE statement.  */
else_stmt = co->block->block;

while (else_stmt != NULL__null)
  {
    gfc_code *next_else;

    /* If there is no condition, we're done.  */
    if (else_stmt->expr1 == NULL__null)
break;

    next_else = else_stmt->block;

    /* Generate the new IF statement.  */
    c_if2 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
    c_if2->op = EXEC_IF;
    c_if2->expr1 = else_stmt->expr1;
    c_if2->next = else_stmt->next;
    c_if2->loc = else_stmt->loc;
    c_if2->block = next_else;

    /* ... plus the one to chain it to.  */
    c_if1 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
    c_if1->op = EXEC_IF;
    c_if1->block = c_if2;
    c_if1->loc = else_stmt->loc;

    /* Insert the new IF after the ELSE.  */
    else_stmt->expr1 = NULL__null;
    else_stmt->next = c_if1;
    else_stmt->block = NULL__null;

    else_stmt = next_else;
  }
/*  Don't walk subtrees.  */
return 0;
1153}

1155/* Callback function to var_in_expr - return true if expr1 and
 expr2 are identical variables. */
1157static int
1158var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
      void *data)
1160{
gfc_expr *expr1 = (gfc_expr *) data;
gfc_expr *expr2 = *e;

if (expr2->expr_type != EXPR_VARIABLE)
  return 0;

return expr1->symtree->n.sym == expr2->symtree->n.sym;
1168}

1170/* Return true if expr1 is found in expr2. */

1172static bool
1173var_in_expr (gfc_expr *expr1, gfc_expr *expr2)
1174{
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));

return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1);
1178}

1180struct do_stack
1181{
struct do_stack *prev;
gfc_iterator *iter;
gfc_code *code;
1185} *stack_top;

1187/* Recursively traverse the block of a WRITE or READ statement, and maybe
 optimize by replacing do loops with their analog array slices.  For
 example:

   write (*,*) (a(i), i=1,4)

 is replaced with

   write (*,*) a(1:4:1) .  */

1197static bool
1198traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
1199{
gfc_code *curr;
gfc_expr *new_e, *expr, *start;
gfc_ref *ref;
struct do_stack ds_push;
int i, future_rank = 0;
gfc_iterator *iters[GFC_MAX_DIMENSIONS15];
gfc_expr *e;

/* Find the first transfer/do statement.  */
for (curr = code; curr; curr = curr->next)
  {
    if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
break;
  }

/* Ensure it is the only transfer/do statement because cases like

   write (*,*) (a(i), b(i), i=1,4)

   cannot be optimized.  */

if (!curr || curr->next)
  return false;

if (curr->op == EXEC_DO)
  {
    if (curr->ext.iterator->var->ref)
return false;
    ds_push.prev = stack_top;
    ds_push.iter = curr->ext.iterator;
    ds_push.code = curr;
    stack_top = &ds_push;
    if (traverse_io_block (curr->block->next, has_reached, prev))
{
 if (curr != stack_top->code && !*has_reached)
   {
     curr->block->next = NULL__null;
     gfc_free_statements (curr);
   }
 else
   *has_reached = true;
 return true;
}
    return false;
  }

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));

e = curr->expr1;
ref = e->ref;
if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
  return false;

/* Find the iterators belonging to each variable and check conditions.  */
for (i = 0; i < ref->u.ar.dimen; i++)
  {
    if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
 || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
return false;

    start = ref->u.ar.start[i];
    gfc_simplify_expr (start, 0);
    switch (start->expr_type)
{
case EXPR_VARIABLE:

 /* write (*,*) (a(i), i=a%b,1) not handled yet.  */
 if (start->ref)
   return false;

 /*  Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4).  */
 if (!stack_top || !stack_top->iter
     || stack_top->iter->var->symtree != start->symtree)
   {
     /* Check for (a(i,i), i=1,3).  */
     int j;

     for (j=0; j<i; j++)
if (iters[j] && iters[j]->var->symtree == start->symtree)
  return false;

     iters[i] = NULL__null;
   }
 else
   {
     iters[i] = stack_top->iter;
     stack_top = stack_top->prev;
     future_rank++;
   }
 break;
case EXPR_CONSTANT:
 iters[i] = NULL__null;
 break;
case EXPR_OP:
 switch (start->value.op.op)
   {
   case INTRINSIC_PLUS:
   case INTRINSIC_TIMES:
     if (start->value.op.op1->expr_type != EXPR_VARIABLE)
std::swap (start->value.op.op1, start->value.op.op2);
     gcc_fallthrough ();
   case INTRINSIC_MINUS:
     if (start->value.op.op1->expr_type!= EXPR_VARIABLE
  || start->value.op.op2->expr_type != EXPR_CONSTANT
  || start->value.op.op1->ref)
return false;
     if (!stack_top || !stack_top->iter
  || stack_top->iter->var->symtree
  != start->value.op.op1->symtree)
return false;
     iters[i] = stack_top->iter;
     stack_top = stack_top->prev;
     break;
   default:
     return false;
   }
 future_rank++;
 break;
default:
 return false;
}
  }

/* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
for (int i = 1; i < ref->u.ar.dimen; i++)
  {
    if (iters[i])
{
 gfc_expr *var = iters[i]->var;
 for (int j = i - 1; j < i; j++)
   {
     if (iters[j]
  && (var_in_expr (var, iters[j]->start)
      || var_in_expr (var, iters[j]->end)
      || var_in_expr (var, iters[j]->step)))
  return false;
   }
}
  }

/* Create new expr.  */
new_e = gfc_copy_expr (curr->expr1);
new_e->expr_type = EXPR_VARIABLE;
new_e->rank = future_rank;
if (curr->expr1->shape)
  new_e->shape = gfc_get_shape (new_e->rank)(((mpz_t *) xcalloc (((new_e->rank)), sizeof (mpz_t))));

/* Assign new starts, ends and strides if necessary.  */
for (i = 0; i < ref->u.ar.dimen; i++)
  {
    if (!iters[i])
continue;
    start = ref->u.ar.start[i];
    switch (start->expr_type)
{
case EXPR_CONSTANT:
 gfc_internal_error ("bad expression");
 break;
case EXPR_VARIABLE:
 new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
 new_e->ref->u.ar.type = AR_SECTION;
 gfc_free_expr (new_e->ref->u.ar.start[i]);
 new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start);
 new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end);
 new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
 break;
case EXPR_OP:
 new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
 new_e->ref->u.ar.type = AR_SECTION;
 gfc_free_expr (new_e->ref->u.ar.start[i]);
 expr = gfc_copy_expr (start);
 expr->value.op.op1 = gfc_copy_expr (iters[i]->start);
 new_e->ref->u.ar.start[i] = expr;
 gfc_simplify_expr (new_e->ref->u.ar.start[i], 0);
 expr = gfc_copy_expr (start);
 expr->value.op.op1 = gfc_copy_expr (iters[i]->end);
 new_e->ref->u.ar.end[i] = expr;
 gfc_simplify_expr (new_e->ref->u.ar.end[i], 0);
 switch (start->value.op.op)
   {
   case INTRINSIC_MINUS:
   case INTRINSIC_PLUS:
     new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
     break;
   case INTRINSIC_TIMES:
     expr = gfc_copy_expr (start);
     expr->value.op.op1 = gfc_copy_expr (iters[i]->step);
     new_e->ref->u.ar.stride[i] = expr;
     gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0);
     break;
   default:
     gfc_internal_error ("bad op");
   }
 break;
default:
 gfc_internal_error ("bad expression");
}
  }
curr->expr1 = new_e;

/* Insert modified statement. Check whether the statement needs to be
   inserted at the lowest level.  */
if (!stack_top->iter)
  {
    if (prev)
{
 curr->next = prev->next->next;
 prev->next = curr;
}
    else
{
 curr->next = stack_top->code->block->next->next->next;
 stack_top->code->block->next = curr;
}
  }
else
  stack_top->code->block->next = curr;
return true;
1418}

1420/* Function for the gfc_code_walker.  If code is a READ or WRITE statement, it
 tries to optimize its block.  */

1423static int
1424simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
     void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
1426{
gfc_code **curr, *prev = NULL__null;
struct do_stack write, first;
bool b = false;
*walk_subtrees = 1;
if (!(*code)->block
    || ((*code)->block->op != EXEC_WRITE
 && (*code)->block->op != EXEC_READ))
  return 0;

*walk_subtrees = 0;
write.prev = NULL__null;
write.iter = NULL__null;
write.code = *code;

for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
  {
    if ((*curr)->op == EXEC_DO)
{
 first.prev = &write;
 first.iter = (*curr)->ext.iterator;
 first.code = *curr;
 stack_top = &first;
 traverse_io_block ((*curr)->block->next, &b, prev);
 stack_top = NULL__null;
}
    prev = *curr;
  }
return 0;
1455}

1457/* Optimize a namespace, including all contained namespaces.
flag_frontend_optimize and flag_fronend_loop_interchange are
handled separately.  */

1461static void
1462optimize_namespace (gfc_namespace *ns)
1463{
gfc_namespace *saved_ns = gfc_current_ns;
current_ns = ns;
gfc_current_ns = ns;
forall_level = 0;
iterator_level = 0;
in_assoc_list = false;
in_omp_workshare = false;
in_omp_atomic = false;

if (flag_frontend_optimizeglobal_options.x_flag_frontend_optimize)
  {
    gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL__null);
    gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL__null);
    gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL__null);
    gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL__null);
    gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL__null);
    if (flag_inline_matmul_limitglobal_options.x_flag_inline_matmul_limit != 0 || flag_external_blasglobal_options.x_flag_external_blas)
{
 bool found;
 do
   {
     found = false;
     gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
	       (void *) &found);
   }
 while (found);

 gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
	   NULL__null);
}

    if (flag_external_blasglobal_options.x_flag_external_blas)
gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
	 NULL__null);

    if (flag_inline_matmul_limitglobal_options.x_flag_inline_matmul_limit != 0)
gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
	 NULL__null);
  }

if (flag_frontend_loop_interchangeglobal_options.x_flag_frontend_loop_interchange)
  gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
     NULL__null);

/* BLOCKs are handled in the expression walker below.  */
for (ns = ns->contained; ns; ns = ns->sibling)
  {
    if (ns->code == NULL__null || ns->code->op != EXEC_BLOCK)
optimize_namespace (ns);
  }
gfc_current_ns = saved_ns;
1515}

1517/* Handle dependencies for allocatable strings which potentially redefine
 themselves in an assignment.  */

1520static void
1521realloc_strings (gfc_namespace *ns)
1522{
current_ns = ns;
gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL__null);

for (ns = ns->contained; ns; ns = ns->sibling)
  {
    if (ns->code == NULL__null || ns->code->op != EXEC_BLOCK)
realloc_strings (ns);
  }

1532}

1534static void
1535optimize_reduction (gfc_namespace *ns)
1536{
current_ns = ns;
gfc_code_walker (&ns->code, gfc_dummy_code_callback,
   callback_reduction, NULL__null);

1541/* BLOCKs are handled in the expression walker below.  */
for (ns = ns->contained; ns; ns = ns->sibling)
  {
    if (ns->code == NULL__null || ns->code->op != EXEC_BLOCK)
optimize_reduction (ns);
  }
1547}

1549/* Replace code like
 a = matmul(b,c) + d
 with
 a = matmul(b,c) ;   a = a + d
 where the array function is not elemental and not allocatable
 and does not depend on the left-hand side.
1555*/

1557static bool
1558optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
1559{
gfc_expr *e;

if (!*rhs)
  return false;

e = *rhs;
if (e->expr_type == EXPR_OP)
  {
    switch (e->value.op.op)
{
 /* Unary operators and exponentiation: Only look at a single
    operand.  */
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
case INTRINSIC_PARENTHESES:
case INTRINSIC_POWER:
 if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
   return true;
 break;

case INTRINSIC_CONCAT:
 /* Do not do string concatenations.  */
 break;

default:
 /* Binary operators.  */
 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
   return true;

 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
   return true;

 break;
}
  }
else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
  && ! (e->value.function.esym
 && (e->value.function.esym->attr.elemental
     || e->value.function.esym->attr.allocatable
     || e->value.function.esym->ts.type != c->expr1->ts.type
     || e->value.function.esym->ts.kind != c->expr1->ts.kind))
  && ! (e->value.function.isym
 && (e->value.function.isym->elemental
     || e->ts.type != c->expr1->ts.type
     || e->ts.kind != c->expr1->ts.kind))
  && ! gfc_inline_intrinsic_function_p (e))
  {

    gfc_code *n;
    gfc_expr *new_expr;

    /* Insert a new assignment statement after the current one.  */
    n = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
    n->op = EXEC_ASSIGN;
    n->loc = c->loc;
    n->next = c->next;
    c->next = n;

    n->expr1 = gfc_copy_expr (c->expr1);
    n->expr2 = c->expr2;
    new_expr = gfc_copy_expr (c->expr1);
    c->expr2 = e;
    *rhs = new_expr;

    return true;

  }

/* Nothing to optimize.  */
return false;
1631}

1633/* Remove unneeded TRIMs at the end of expressions.  */

1635static bool
1636remove_trim (gfc_expr *rhs)
1637{
bool ret;

ret = false;
if (!rhs)
  return ret;

/* Check for a // b // trim(c).  Looping is probably not
   necessary because the parser usually generates
   (// (// a b ) trim(c) ) , but better safe than sorry.  */

while (rhs->expr_type == EXPR_OP
&& rhs->value.op.op == INTRINSIC_CONCAT)
  rhs = rhs->value.op.op2;

while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
&& rhs->value.function.isym->id == GFC_ISYM_TRIM)
  {
    strip_function_call (rhs);
    /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
    remove_trim (rhs);
    ret = true;
  }

return ret;
1662}

1664/* Optimizations for an assignment.  */

1666static void
1667optimize_assignment (gfc_code * c)
1668{
gfc_expr *lhs, *rhs;

lhs = c->expr1;
rhs = c->expr2;

if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
  {
    /* Optimize  a = trim(b)  to  a = b.  */
    remove_trim (rhs);

    /* Replace a = '   ' by a = '' to optimize away a memcpy.  */
    if (is_empty_string (rhs))
rhs->value.character.length = 0;
  }

if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
  optimize_binop_array_assignment (c, &rhs, false);
1686}


1689/* Remove an unneeded function call, modifying the expression.
 This replaces the function call with the value of its
 first argument.  The rest of the argument list is freed.  */

1693static void
1694strip_function_call (gfc_expr *e)
1695{
gfc_expr *e1;
gfc_actual_arglist *a;

a = e->value.function.actual;

/* We should have at least one argument.  */
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));

e1 = a->expr;

/* Free the remaining arglist, if any.  */
if (a->next)
  gfc_free_actual_arglist (a->next);

/* Graft the argument expression onto the original function.  */
*e = *e1;
free (e1);

1714}

1716/* Optimization of lexical comparison functions.  */

1718static bool
1719optimize_lexical_comparison (gfc_expr *e)
1720{
if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL__null)
  return false;

switch (e->value.function.isym->id)
  {
  case GFC_ISYM_LLE:
    return optimize_comparison (e, INTRINSIC_LE);

  case GFC_ISYM_LGE:
    return optimize_comparison (e, INTRINSIC_GE);

  case GFC_ISYM_LGT:
    return optimize_comparison (e, INTRINSIC_GT);

  case GFC_ISYM_LLT:
    return optimize_comparison (e, INTRINSIC_LT);

  default:
    break;
  }
return false;
1742}

1744/* Combine stuff like [a]>b into [a>b], for easier optimization later.  Do not
 do CHARACTER because of possible pessimization involving character
 lengths.  */

1748static bool
1749combine_array_constructor (gfc_expr *e)
1750{

gfc_expr *op1, *op2;
gfc_expr *scalar;
gfc_expr *new_expr;
gfc_constructor *c, *new_c;
gfc_constructor_base oldbase, newbase;
bool scalar_first;
int n_elem;
bool all_const;

/* Array constructors have rank one.  */
if (e->rank != 1)
  return false;

/* Don't try to combine association lists, this makes no sense
   and leads to an ICE.  */
if (in_assoc_list)
  return false;

/* With FORALL, the BLOCKS created by create_var will cause an ICE.  */
if (forall_level > 0)
  return false;

/* Inside an iterator, things can get hairy; we are likely to create
   an invalid temporary variable.  */
if (iterator_level > 0)
  return false;

/* WHERE also doesn't work.  */
if (in_where > 0)
  return false;

op1 = e->value.op.op1;
op2 = e->value.op.op2;

if (!op1 || !op2)
  return false;

if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
  scalar_first = false;
else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
  {
    scalar_first = true;
    op1 = e->value.op.op2;
    op2 = e->value.op.op1;
  }
else
  return false;

if (op2->ts.type == BT_CHARACTER)
  return false;

/* This might be an expanded constructor with very many constant values. If
   we perform the operation here, we might end up with a long compile time
   and actually longer execution time, so a length bound is in order here.
   If the constructor constains something which is not a constant, it did
   not come from an expansion, so leave it alone.  */

1809#define CONSTR_LEN_MAX 4

oldbase = op1->value.constructor;

n_elem = 0;
all_const = true;
for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c))
  {
    if (c->expr->expr_type != EXPR_CONSTANT)
{
 all_const = false;
 break;
}
    n_elem += 1;
  }

if (all_const && n_elem > CONSTR_LEN_MAX)
  return false;

1828#undef CONSTR_LEN_MAX

newbase = NULL__null;
e->expr_type = EXPR_ARRAY;

scalar = create_var (gfc_copy_expr (op2), "constr");

for (c = gfc_constructor_first (oldbase); c;
     c = gfc_constructor_next (c))
  {
    new_expr = gfc_get_expr ();
    new_expr->ts = e->ts;
    new_expr->expr_type = EXPR_OP;
    new_expr->rank = c->expr->rank;
    new_expr->where = c->expr->where;
    new_expr->value.op.op = e->value.op.op;

    if (scalar_first)
{
 new_expr->value.op.op1 = gfc_copy_expr (scalar);
 new_expr->value.op.op2 = gfc_copy_expr (c->expr);
}
    else
{
 new_expr->value.op.op1 = gfc_copy_expr (c->expr);
 new_expr->value.op.op2 = gfc_copy_expr (scalar);
}

    new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
    new_c->iterator = c->iterator;
    c->iterator = NULL__null;
  }

gfc_free_expr (op1);
gfc_free_expr (op2);
gfc_free_expr (scalar);

e->value.constructor = newbase;
return true;
1867}

1869/* Recursive optimization of operators.  */

1871static bool
1872optimize_op (gfc_expr *e)
1873{
bool changed;

gfc_intrinsic_op op = e->value.op.op;

changed = false;

/* Only use new-style comparisons.  */
switch(op)
  {
  case INTRINSIC_EQ_OS:
    op = INTRINSIC_EQ;
    break;

  case INTRINSIC_GE_OS:
    op = INTRINSIC_GE;
    break;

  case INTRINSIC_LE_OS:
    op = INTRINSIC_LE;
    break;

  case INTRINSIC_NE_OS:
    op = INTRINSIC_NE;
    break;

  case INTRINSIC_GT_OS:
    op = INTRINSIC_GT;
    break;

  case INTRINSIC_LT_OS:
    op = INTRINSIC_LT;
    break;

  default:
    break;
  }

switch (op)
  {
  case INTRINSIC_EQ:
  case INTRINSIC_GE:
  case INTRINSIC_LE:
  case INTRINSIC_NE:
  case INTRINSIC_GT:
  case INTRINSIC_LT:
    changed = optimize_comparison (e, op);

    gcc_fallthrough ();
    /* Look at array constructors.  */
  case INTRINSIC_PLUS:
  case INTRINSIC_MINUS:
  case INTRINSIC_TIMES:
  case INTRINSIC_DIVIDE:
    return combine_array_constructor (e) || changed;

  default:
    break;
  }

return false;
1934}


1937/* Return true if a constant string contains only blanks.  */

1939static bool
1940is_empty_string (gfc_expr *e)
1941{
int i;

if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
  return false;

for (i=0; i < e->value.character.length; i++)
  {
    if (e->value.character.string[i] != ' ')
return false;
  }

return true;
1954}


1957/* Insert a call to the intrinsic len_trim. Use a different name for
 the symbol tree so we don't run into trouble when the user has
 renamed len_trim for some reason.  */

1961static gfc_expr*
1962get_len_trim_call (gfc_expr *str, int kind)
1963{
gfc_expr *fcn;
gfc_actual_arglist *actual_arglist, *next;

fcn = gfc_get_expr ();
fcn->expr_type = EXPR_FUNCTION;
fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
actual_arglist = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
actual_arglist->expr = str;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL__null, kind);
actual_arglist->next = next;

fcn->value.function.actual = actual_arglist;
fcn->where = str->where;
fcn->ts.type = BT_INTEGER;
fcn->ts.kind = gfc_charlen_int_kind;

gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
fcn->symtree->n.sym->ts = fcn->ts;
fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
fcn->symtree->n.sym->attr.function = 1;
fcn->symtree->n.sym->attr.elemental = 1;
fcn->symtree->n.sym->attr.referenced = 1;
fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
gfc_commit_symbol (fcn->symtree->n.sym);

return fcn;
1991}


1994/* Optimize expressions for equality.  */

1996static bool
1997optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
1998{
gfc_expr *op1, *op2;
bool change;
int eq;
bool result;
gfc_actual_arglist *firstarg, *secondarg;

if (e->expr_type == EXPR_OP)
  {
    firstarg = NULL__null;
    secondarg = NULL__null;
    op1 = e->value.op.op1;
    op2 = e->value.op.op2;
  }
else if (e->expr_type == EXPR_FUNCTION)
  {
    /* One of the lexical comparison functions.  */
    firstarg = e->value.function.actual;
    secondarg = firstarg->next;
    op1 = firstarg->expr;
    op2 = secondarg->expr;
  }
else
  gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 2021, __FUNCTION__));

/* Strip off unneeded TRIM calls from string comparisons.  */

change = remove_trim (op1);

if (remove_trim (op2))
  change = true;

/* An expression of type EXPR_CONSTANT is only valid for scalars.  */
/* TODO: A scalar constant may be acceptable in some cases (the scalarizer
   handles them well). However, there are also cases that need a non-scalar
   argument. For example the any intrinsic. See PR 45380.  */
if (e->rank > 0)
  return change;

/* Replace a == '' with len_trim(a) == 0 and a /= '' with
   len_trim(a) != 0 */
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
    && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
  {
    bool empty_op1, empty_op2;
    empty_op1 = is_empty_string (op1);
    empty_op2 = is_empty_string (op2);

    if (empty_op1 || empty_op2)
{
 gfc_expr *fcn;
 gfc_expr *zero;
 gfc_expr *str;

 /* This can only happen when an error for comparing
    characters of different kinds has already been issued.  */
 if (empty_op1 && empty_op2)
   return false;

 zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
 str = empty_op1 ? op2 : op1;

 fcn = get_len_trim_call (str, gfc_charlen_int_kind);


 if (empty_op1)
   gfc_free_expr (op1);
 else
   gfc_free_expr (op2);

 op1 = fcn;
 op2 = zero;
 e->value.op.op1 = fcn;
 e->value.op.op2 = zero;
}
  }


/* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */

if (flag_finite_math_onlyglobal_options.x_flag_finite_math_only
    || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
  {
    eq = gfc_dep_compare_expr (op1, op2);
    if (eq <= -2)
{
 /* Replace A // B < A // C with B < C, and A // B < C // B
    with A < C.  */
 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
     && op1->expr_type == EXPR_OP
     && op1->value.op.op == INTRINSIC_CONCAT
     && op2->expr_type == EXPR_OP
     && op2->value.op.op == INTRINSIC_CONCAT)
   {
     gfc_expr *op1_left = op1->value.op.op1;
     gfc_expr *op2_left = op2->value.op.op1;
     gfc_expr *op1_right = op1->value.op.op2;
     gfc_expr *op2_right = op2->value.op.op2;

     if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
{
  /* Watch out for 'A ' // x vs. 'A' // x.  */

  if (op1_left->expr_type == EXPR_CONSTANT
	&& op2_left->expr_type == EXPR_CONSTANT
	&& op1_left->value.character.length
	   != op2_left->value.character.length)
    return change;
  else
    {
      free (op1_left);
      free (op2_left);
      if (firstarg)
	{
	  firstarg->expr = op1_right;
	  secondarg->expr = op2_right;
	}
      else
	{
	  e->value.op.op1 = op1_right;
	  e->value.op.op2 = op2_right;
	}
      optimize_comparison (e, op);
      return true;
    }
}
     if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
{
  free (op1_right);
  free (op2_right);
  if (firstarg)
    {
      firstarg->expr = op1_left;
      secondarg->expr = op2_left;
    }
  else
    {
      e->value.op.op1 = op1_left;
      e->value.op.op2 = op2_left;
    }

  optimize_comparison (e, op);
  return true;
}
   }
}
    else
{
 /* eq can only be -1, 0 or 1 at this point.  */
 switch (op)
   {
   case INTRINSIC_EQ:
     result = eq == 0;
     break;

   case INTRINSIC_GE:
     result = eq >= 0;
     break;

   case INTRINSIC_LE:
     result = eq <= 0;
     break;

   case INTRINSIC_NE:
     result = eq != 0;
     break;

   case INTRINSIC_GT:
     result = eq > 0;
     break;

   case INTRINSIC_LT:
     result = eq < 0;
     break;

   default:
     gfc_internal_error ("illegal OP in optimize_comparison");
     break;
   }

 /* Replace the expression by a constant expression.  The typespec
    and where remains the way it is.  */
 free (op1);
 free (op2);
 e->expr_type = EXPR_CONSTANT;
 e->value.logical = result;
 return true;
}
  }

return change;
2190}

2192/* Optimize a trim function by replacing it with an equivalent substring
 involving a call to len_trim.  This only works for expressions where
 variables are trimmed.  Return true if anything was modified.  */

2196static bool
2197optimize_trim (gfc_expr *e)
2198{
gfc_expr *a;
gfc_ref *ref;
gfc_expr *fcn;
gfc_ref **rr = NULL__null;

/* Don't do this optimization within an argument list, because
   otherwise aliasing issues may occur.  */

if (count_arglist != 1)
  return false;

if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
    || e->value.function.isym == NULL__null
    || e->value.function.isym->id != GFC_ISYM_TRIM)
  return false;

a = e->value.function.actual->expr;

if (a->expr_type != EXPR_VARIABLE)
  return false;

/* This would pessimize the idiom a = trim(a) for reallocatable strings.  */

if (a->symtree->n.sym->attr.allocatable)
  return false;

/* Follow all references to find the correct place to put the newly
   created reference.  FIXME:  Also handle substring references and
   array references.  Array references cause strange regressions at
   the moment.  */

if (a->ref)
  {
    for (rr = &(a->ref); *rr; rr = &((*rr)->next))
{
 if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
   return false;
}
  }

strip_function_call (e);

if (e->ref == NULL__null)
  rr = &(e->ref);

/* Create the reference.  */

ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
ref->type = REF_SUBSTRING;

/* Set the start of the reference.  */

ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null, 1);

/* Build the function call to len_trim(x, gfc_default_integer_kind).  */

fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind);

/* Set the end of the reference to the call to len_trim.  */

ref->u.ss.end = fcn;
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));
*rr = ref;
return true;
2263}

2265/* Optimize minloc(b), where b is rank 1 array, into
 (/ minloc(b, dim=1) /), and similarly for maxloc,
 as the latter forms are expanded inline.  */

2269static void
2270optimize_minmaxloc (gfc_expr **e)
2271{
gfc_expr *fn = *e;
gfc_actual_arglist *a;
char *name, *p;

if (fn->rank != 1
    || fn->value.function.actual == NULL__null
    || fn->value.function.actual->expr == NULL__null
    || fn->value.function.actual->expr->ts.type == BT_CHARACTER
    || fn->value.function.actual->expr->rank != 1)
  return;

*e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
(*e)->shape = fn->shape;
fn->rank = 0;
fn->shape = NULL__null;
gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);

name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1)((char *) __builtin_alloca(sizeof (char) * (strlen (fn->value
.function.name) + 1)));
strcpy (name, fn->value.function.name);
p = strstr (name, "loc0");
p[3] = '1';
fn->value.function.name = gfc_get_string ("%s", name);
if (fn->value.function.actual->next)
  {
    a = fn->value.function.actual->next;
    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));
  }
else
  {
    a = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
    fn->value.function.actual->next = a;
  }
a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
		   &fn->where);
mpz_set_ui__gmpz_set_ui (a->expr->value.integer, 1);
2307}

2309/* Data package to hand down for DO loop checks in a contained
 procedure.  */
2311typedef struct contained_info
2312{
gfc_symbol *do_var;
gfc_symbol *procedure;
locus where_do;
2316} contained_info;

2318static enum gfc_exec_op last_io_op;

2320/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
 contained function call.  */

2323static int
2324doloop_contained_function_call (gfc_expr **e,
		int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)), void *data)
2326{
gfc_expr *expr = *e;
gfc_formal_arglist *f;
gfc_actual_arglist *a;
gfc_symbol *sym, *do_var;
contained_info *info;

if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym
    || expr->value.function.esym == NULL__null)
  return 0;

sym = expr->value.function.esym;
f = gfc_sym_get_dummy_args (sym);
if (f == NULL__null)
  return 0;

info = (contained_info *) data;
do_var = info->do_var;
a = expr->value.function.actual;

while (a && f)
  {
    if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
{
 if (f->sym->attr.intent == INTENT_OUT)
   {
     gfc_error_now ("Index variable %qs set to undefined as "
	     "INTENT(OUT) argument at %L in procedure %qs "
	     "called from within DO loop at %L", do_var->name,
	     &a->expr->where, info->procedure->name,
	     &info->where_do);
     return 1;
   }
 else if (f->sym->attr.intent == INTENT_INOUT)
   {
     gfc_error_now ("Index variable %qs not definable as "
	     "INTENT(INOUT) argument at %L in procedure %qs "
	     "called from within DO loop at %L", do_var->name,
	     &a->expr->where, info->procedure->name,
	     &info->where_do);
     return 1;
   }
}
    a = a->next;
    f = f->next;
  }
return 0;
2373}

2375/* Callback function that goes through the code in a contained
 procedure to make sure it does not change a variable in a DO
 loop.  */

2379static int
2380doloop_contained_procedure_code (gfc_code **c,
		 int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
		 void *data)
2383{
gfc_code *co = *c;
contained_info *info = (contained_info *) data;
gfc_symbol *do_var = info->do_var;
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")
	 "called from within DO loop at %L")gettext ("Index variable %qs redefined at %L in procedure %qs "
 "called from within DO loop at %L");
static enum gfc_exec_op saved_io_op;

switch (co->op)
  {
  case EXEC_ASSIGN:
    if (co->expr1->symtree && co->expr1->symtree->n.sym == do_var)
gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name,
       &info->where_do);
    break;

  case EXEC_DO:
    if (co->ext.iterator && co->ext.iterator->var
 && co->ext.iterator->var->symtree->n.sym == do_var)
gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name,
   &info->where_do);
    break;

  case EXEC_READ:
  case EXEC_WRITE:
  case EXEC_INQUIRE:
  case EXEC_IOLENGTH:
    saved_io_op = last_io_op;
    last_io_op = co->op;
    break;

  case EXEC_OPEN:
    if (co->ext.open && co->ext.open->iostat
 && co->ext.open->iostat->symtree->n.sym == do_var)
gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where,
       info->procedure->name, &info->where_do);
    break;

  case EXEC_CLOSE:
    if (co->ext.close && co->ext.close->iostat
 && co->ext.close->iostat->symtree->n.sym == do_var)
gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where,
       info->procedure->name, &info->where_do);
    break;

  case EXEC_TRANSFER:
    switch (last_io_op)
{

case EXEC_INQUIRE:
2433#define CHECK_INQ(a) do { if (co->ext.inquire    &&			\
	      co->ext.inquire->a &&			\
	      co->ext.inquire->a->symtree->n.sym == do_var) \
     gfc_error_now (errmsg, do_var->name,			\
	     &co->ext.inquire->a->where,		\
	     info->procedure->name,			\
	     &info->where_do);				\
 } while (0)

 CHECK_INQ(iostat);
 CHECK_INQ(number);
 CHECK_INQ(position);
 CHECK_INQ(recl);
 CHECK_INQ(position);
 CHECK_INQ(iolength);
 CHECK_INQ(strm_pos);
 break;
2450#undef CHECK_INQ

case EXEC_READ:
 if (co->expr1 && co->expr1->symtree
     && co->expr1->symtree->n.sym == do_var)
   gfc_error_now (errmsg, do_var->name, &co->expr1->where,
	   info->procedure->name, &info->where_do);

 /* Fallthrough.  */

case EXEC_WRITE:
 if (co->ext.dt && co->ext.dt->iostat && co->ext.dt->iostat->symtree
     && co->ext.dt->iostat->symtree->n.sym == do_var)
   gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where,
	   info->procedure->name, &info->where_do);
 break;

case EXEC_IOLENGTH:
 if (co->expr1 && co->expr1->symtree
     && co->expr1->symtree->n.sym == do_var)
   gfc_error_now (errmsg, do_var->name, &co->expr1->where,
	   info->procedure->name, &info->where_do);
 break;

default:
 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 2475, __FUNCTION__));
}
    break;

  case EXEC_DT_END:
    last_io_op = saved_io_op;
    break;

  case EXEC_CALL:
    gfc_formal_arglist *f;
    gfc_actual_arglist *a;

    f = gfc_sym_get_dummy_args (co->resolved_sym);
    if (f == NULL__null)
break;
    a = co->ext.actual;
    /* Slightly different error message here. If there is an error,
return 1 to avoid an infinite loop.  */
    while (a && f)
{
 if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
   {
     if (f->sym->attr.intent == INTENT_OUT)
{
  gfc_error_now ("Index variable %qs set to undefined as "
		 "INTENT(OUT) argument at %L in subroutine %qs "
		 "called from within DO loop at %L",
		 do_var->name, &a->expr->where,
		 info->procedure->name, &info->where_do);
  return 1;
}
     else if (f->sym->attr.intent == INTENT_INOUT)
{
  gfc_error_now ("Index variable %qs not definable as "
		 "INTENT(INOUT) argument at %L in subroutine %qs "
		 "called from within DO loop at %L", do_var->name,
		 &a->expr->where, info->procedure->name,
		 &info->where_do);
  return 1;
}
   }
 a = a->next;
 f = f->next;
}
    break;
  default:
    break;
  }
return 0;
2524}

2526/* Callback function for code checking that we do not pass a DO variable to an
 INTENT(OUT) or INTENT(INOUT) dummy variable.  */

2529static int
2530doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
2532{
gfc_code *co;
int i;
gfc_formal_arglist *f;
gfc_actual_arglist *a;
gfc_code *cl;
do_t loop, *lp;
bool seen_goto;

co = *c;

/* If the doloop_list grew, we have to truncate it here.  */

if ((unsigned) doloop_level < doloop_list.length())
  doloop_list.truncate (doloop_level);

seen_goto = false;
switch (co->op)
  {
  case EXEC_DO:

    if (co->ext.iterator && co->ext.iterator->var)
loop.c = co;
    else
loop.c = NULL__null;

    loop.branch_level = if_level + select_level;
    loop.seen_goto = false;
    doloop_list.safe_push (loop);
    break;

    /* If anything could transfer control away from a suspicious
subscript, make sure to set seen_goto in the current DO loop
(if any).  */
  case EXEC_GOTO:
  case EXEC_EXIT:
  case EXEC_STOP:
  case EXEC_ERROR_STOP:
  case EXEC_CYCLE:
    seen_goto = true;
    break;

  case EXEC_OPEN:
    if (co->ext.open->err)
seen_goto = true;
    break;

  case EXEC_CLOSE:
    if (co->ext.close->err)
seen_goto = true;
    break;

  case EXEC_BACKSPACE:
  case EXEC_ENDFILE:
  case EXEC_REWIND:
  case EXEC_FLUSH:

    if (co->ext.filepos->err)
seen_goto = true;
    break;

  case EXEC_INQUIRE:
    if (co->ext.filepos->err)
seen_goto = true;
    break;

  case EXEC_READ:
  case EXEC_WRITE:
    if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
seen_goto = true;
    break;

  case EXEC_WAIT:
    if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
loop.seen_goto = true;
    break;

  case EXEC_CALL:
    if (co->resolved_sym == NULL__null)
break;

    /* Test if somebody stealthily changes the DO variable from
under us by changing it in a host-associated procedure.  */
    if (co->resolved_sym->attr.contained)
{
 FOR_EACH_VEC_ELT (doloop_list, i, lp)for (i = 0; (doloop_list).iterate ((i), &(lp)); ++(i))
   {
     gfc_symbol *sym = co->resolved_sym;
     contained_info info;
     gfc_namespace *ns;

     cl = lp->c;
     info.do_var = cl->ext.iterator->var->symtree->n.sym;
     info.procedure = co->resolved_sym;  /* sym? */
     info.where_do = co->loc;
     /* Look contained procedures under the namespace of the
 variable.  */
     for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
if (ns->proc_name && ns->proc_name == sym)
  gfc_code_walker (&ns->code, doloop_contained_procedure_code,
		   doloop_contained_function_call, &info);
   }
}

    f = gfc_sym_get_dummy_args (co->resolved_sym);

    /* Withot a formal arglist, there is only unknown INTENT,
which we don't check for.  */
    if (f == NULL__null)
break;

    a = co->ext.actual;

    while (a && f)
{
 FOR_EACH_VEC_ELT (doloop_list, i, lp)for (i = 0; (doloop_list).iterate ((i), &(lp)); ++(i))
   {
     gfc_symbol *do_sym;
     cl = lp->c;

     if (cl == NULL__null)
break;

     do_sym = cl->ext.iterator->var->symtree->n.sym;

     if (a->expr && a->expr->symtree && f->sym
  && a->expr->symtree->n.sym == do_sym)
{
  if (f->sym->attr.intent == INTENT_OUT)
    gfc_error_now ("Variable %qs at %L set to undefined "
		   "value inside loop beginning at %L as "
		   "INTENT(OUT) argument to subroutine %qs",
		   do_sym->name, &a->expr->where,
		   &(doloop_list[i].c->loc),
		   co->symtree->n.sym->name);
  else if (f->sym->attr.intent == INTENT_INOUT)
    gfc_error_now ("Variable %qs at %L not definable inside "
		   "loop beginning at %L as INTENT(INOUT) "
		   "argument to subroutine %qs",
		   do_sym->name, &a->expr->where,
		   &(doloop_list[i].c->loc),
		   co->symtree->n.sym->name);
}
   }
 a = a->next;
 f = f->next;
}

    break;

  default:
    break;
  }
if (seen_goto && doloop_level > 0)
  doloop_list[doloop_level-1].seen_goto = true;

return 0;
2689}

2691/* Callback function to warn about different things within DO loops.  */

2693static int
2694do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
    void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
2696{
do_t *last;

if (doloop_list.length () == 0)
  return 0;

if ((*e)->expr_type == EXPR_FUNCTION)
  do_intent (e);

last = &doloop_list.last();
if (last->seen_goto && !warn_do_subscriptglobal_options.x_warn_do_subscript)
  return 0;

if ((*e)->expr_type == EXPR_VARIABLE)
  do_subscript (e);

return 0;
2713}

2715typedef struct
2716{
gfc_symbol *sym;
mpz_t val;
2719} insert_index_t;

2721/* Callback function - if the expression is the variable in data->sym,
 replace it with a constant from data->val.  */

2724static int
2725callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
       void *data)
2727{
insert_index_t *d;
gfc_expr *ex, *n;

ex = (*e);
if (ex->expr_type != EXPR_VARIABLE)
  return 0;

d = (insert_index_t *) data;
if (ex->symtree->n.sym != d->sym)
  return 0;

n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
mpz_set__gmpz_set (n->value.integer, d->val);

gfc_free_expr (ex);
*e = n;
return 0;
2745}

2747/* In the expression e, replace occurrences of the variable sym with
 val.  If this results in a constant expression, return true and
 return the value in ret.  Return false if the expression already
 is a constant.  Caller has to clear ret in that case.  */

2752static bool
2753insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
2754{
gfc_expr *n;
insert_index_t data;
bool rc;

if (e->expr_type == EXPR_CONSTANT)
  return false;

n = gfc_copy_expr (e);
data.sym = sym;
mpz_init_set__gmpz_init_set (data.val, val);
gfc_expr_walker (&n, callback_insert_index, (void *) &data);

/* Suppress errors here - we could get errors here such as an
   out of bounds access for arrays, see PR 90563.  */
gfc_push_suppress_errors ();
gfc_simplify_expr (n, 0);
gfc_pop_suppress_errors ();

if (n->expr_type == EXPR_CONSTANT)
  {
    rc = true;
    mpz_init_set__gmpz_init_set (ret, n->value.integer);
  }
else
  rc = false;

mpz_clear__gmpz_clear (data.val);
gfc_free_expr (n);
return rc;

2785}

2787/* Check array subscripts for possible out-of-bounds accesses in DO
 loops with constant bounds.  */

2790static int
2791do_subscript (gfc_expr **e)
2792{
gfc_expr *v;
gfc_array_ref *ar;
gfc_ref *ref;
int i,j;
gfc_code *dl;
do_t *lp;

v = *e;
/* Constants are already checked.  */
if (v->expr_type == EXPR_CONSTANT)
  return 0;

/* Wrong warnings will be generated in an associate list.  */
if (in_assoc_list)
  return 0;

/* We already warned about this.  */
if (v->do_not_warn)
  return 0;

v->do_not_warn = 1;

for (ref = v->ref; ref; ref = ref->next)
  {
    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
{
 ar = & ref->u.ar;
 FOR_EACH_VEC_ELT (doloop_list, j, lp)for (j = 0; (doloop_list).iterate ((j), &(lp)); ++(j))
   {
     gfc_symbol *do_sym;
     mpz_t do_start, do_step, do_end;
     bool have_do_start, have_do_end;
     bool error_not_proven;
     int warn;
     int sgn;

     dl = lp->c;
     if (dl == NULL__null)
break;

     /* If we are within a branch, or a goto or equivalent
 was seen in the DO loop before, then we cannot prove that
 this expression is actually evaluated.  Don't do anything
 unless we want to see it all.  */
     error_not_proven = lp->seen_goto
|| lp->branch_level < if_level + select_level;

     if (error_not_proven && !warn_do_subscriptglobal_options.x_warn_do_subscript)
break;

     if (error_not_proven)
warn = OPT_Wdo_subscript;
     else
warn = 0;

     do_sym = dl->ext.iterator->var->symtree->n.sym;
     if (do_sym->ts.type != BT_INTEGER)
continue;

     /* If we do not know about the stepsize, the loop may be zero trip.
 Do not warn in this case.  */

     if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
{
  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));
  /* This can happen, but then the error has been
     reported previously.  */
  if (sgn == 0)
    continue;

  mpz_init_set__gmpz_init_set (do_step, dl->ext.iterator->step->value.integer);
}

     else
continue;

     if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
{
  have_do_start = true;
  mpz_init_set__gmpz_init_set (do_start, dl->ext.iterator->start->value.integer);
}
     else
have_do_start = false;

     if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
{
  have_do_end = true;
  mpz_init_set__gmpz_init_set (do_end, dl->ext.iterator->end->value.integer);
}
     else
have_do_end = false;

     if (!have_do_start && !have_do_end)
{
  mpz_clear__gmpz_clear (do_step);
  return 0;
}

     /* No warning inside a zero-trip loop.  */
     if (have_do_start && have_do_end)
{
  int cmp;

  cmp = mpz_cmp__gmpz_cmp (do_end, do_start);
  if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
    {
      mpz_clear__gmpz_clear (do_start);
      mpz_clear__gmpz_clear (do_end);
      mpz_clear__gmpz_clear (do_step);
      break;
    }
}

     /* May have to correct the end value if the step does not equal
 one.  */
     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)
{
  mpz_t diff, rem;

  mpz_init__gmpz_init (diff);
  mpz_init__gmpz_init (rem);
  mpz_sub__gmpz_sub (diff, do_end, do_start);
  mpz_tdiv_r__gmpz_tdiv_r (rem, diff, do_step);
  mpz_sub__gmpz_sub (do_end, do_end, rem);
  mpz_clear__gmpz_clear (diff);
  mpz_clear__gmpz_clear (rem);
}

     for (i = 0; i< ar->dimen; i++)
{
  mpz_t val;
  if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
      && insert_index (ar->start[i], do_sym, do_start, val))
    {
      if (ar->as->lower[i]
	  && ar->as->lower[i]->expr_type == EXPR_CONSTANT
	  && ar->as->lower[i]->ts.type == BT_INTEGER
	  && mpz_cmp__gmpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
	gfc_warning (warn, "Array reference at %L out of bounds "
		     "(%ld < %ld) in loop beginning at %L",
		     &ar->start[i]->where, mpz_get_si__gmpz_get_si (val),
		     mpz_get_si__gmpz_get_si (ar->as->lower[i]->value.integer),
		     &doloop_list[j].c->loc);

      if (ar->as->upper[i]
	  && ar->as->upper[i]->expr_type == EXPR_CONSTANT
	  && ar->as->upper[i]->ts.type == BT_INTEGER
	  && mpz_cmp__gmpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
	    gfc_warning (warn, "Array reference at %L out of bounds "
			 "(%ld > %ld) in loop beginning at %L",
			 &ar->start[i]->where, mpz_get_si__gmpz_get_si (val),
			 mpz_get_si__gmpz_get_si (ar->as->upper[i]->value.integer),
			 &doloop_list[j].c->loc);

      mpz_clear__gmpz_clear (val);
    }

  if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
      && insert_index (ar->start[i], do_sym, do_end, val))
    {
      if (ar->as->lower[i]
	  && ar->as->lower[i]->expr_type == EXPR_CONSTANT
	  && ar->as->lower[i]->ts.type == BT_INTEGER
	  && mpz_cmp__gmpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
	gfc_warning (warn, "Array reference at %L out of bounds "
		     "(%ld < %ld) in loop beginning at %L",
		     &ar->start[i]->where, mpz_get_si__gmpz_get_si (val),
		     mpz_get_si__gmpz_get_si (ar->as->lower[i]->value.integer),
		     &doloop_list[j].c->loc);

      if (ar->as->upper[i]
	  && ar->as->upper[i]->expr_type == EXPR_CONSTANT
	  && ar->as->upper[i]->ts.type == BT_INTEGER
	  && mpz_cmp__gmpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
	gfc_warning (warn, "Array reference at %L out of bounds "
		     "(%ld > %ld) in loop beginning at %L",
		     &ar->start[i]->where, mpz_get_si__gmpz_get_si (val),
		     mpz_get_si__gmpz_get_si (ar->as->upper[i]->value.integer),
		     &doloop_list[j].c->loc);

      mpz_clear__gmpz_clear (val);
    }
}

     if (have_do_start)
mpz_clear__gmpz_clear (do_start);
     if (have_do_end)
mpz_clear__gmpz_clear (do_end);
     mpz_clear__gmpz_clear (do_step);
   }
}
  }
return 0;
2986}
2987/* Function for functions checking that we do not pass a DO variable
 to an INTENT(OUT) or INTENT(INOUT) dummy variable.  */

2990static int
2991do_intent (gfc_expr **e)
2992{
gfc_formal_arglist *f;
gfc_actual_arglist *a;
gfc_expr *expr;
gfc_code *dl;
do_t *lp;
int i;
gfc_symbol *sym;

expr = *e;
if (expr->expr_type != EXPR_FUNCTION)
  return 0;

/* Intrinsic functions don't modify their arguments.  */

if (expr->value.function.isym)
  return 0;

sym = expr->value.function.esym;
if (sym == NULL__null)
  return 0;

if (sym->attr.contained)
  {
    FOR_EACH_VEC_ELT (doloop_list, i, lp)for (i = 0; (doloop_list).iterate ((i), &(lp)); ++(i))
{
 contained_info info;
 gfc_namespace *ns;

 dl = lp->c;
 info.do_var = dl->ext.iterator->var->symtree->n.sym;
 info.procedure = sym;
 info.where_do = expr->where;
 /* Look contained procedures under the namespace of the
 variable.  */
 for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
   if (ns->proc_name && ns->proc_name == sym)
     gfc_code_walker (&ns->code, doloop_contained_procedure_code,
	       dummy_expr_callback, &info);
}
  }

f = gfc_sym_get_dummy_args (sym);

/* Without a formal arglist, there is only unknown INTENT,
   which we don't check for.  */
if (f == NULL__null)
  return 0;

a = expr->value.function.actual;

while (a && f)
  {
    FOR_EACH_VEC_ELT (doloop_list, i, lp)for (i = 0; (doloop_list).iterate ((i), &(lp)); ++(i))
{
 gfc_symbol *do_sym;
 dl = lp->c;
 if (dl == NULL__null)
   break;

 do_sym = dl->ext.iterator->var->symtree->n.sym;

 if (a->expr && a->expr->symtree
     && a->expr->symtree->n.sym == do_sym
     && f->sym)
   {
     if (f->sym->attr.intent == INTENT_OUT)
gfc_error_now ("Variable %qs at %L set to undefined value "
	       "inside loop beginning at %L as INTENT(OUT) "
	       "argument to function %qs", do_sym->name,
	       &a->expr->where, &doloop_list[i].c->loc,
	       expr->symtree->n.sym->name);
     else if (f->sym->attr.intent == INTENT_INOUT)
gfc_error_now ("Variable %qs at %L not definable inside loop"
	       " beginning at %L as INTENT(INOUT) argument to"
	       " function %qs", do_sym->name,
	       &a->expr->where, &doloop_list[i].c->loc,
	       expr->symtree->n.sym->name);
   }
}
    a = a->next;
    f = f->next;
  }

return 0;
3077}

3079static void
3080doloop_warn (gfc_namespace *ns)
3081{
gfc_code_walker (&ns->code, doloop_code, do_function, NULL__null);

for (ns = ns->contained; ns; ns = ns->sibling)
  {
    if (ns->code == NULL__null || ns->code->op != EXEC_BLOCK)
doloop_warn (ns);
  }
3089}

3091/* This selction deals with inlining calls to MATMUL.  */

3093/* Replace calls to matmul outside of straight assignments with a temporary
 variable so that later inlining will work.  */

3096static int
3097matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
    void *data)
3099{
gfc_expr *e, *n;
bool *found = (bool *) data;

e = *ep;

if (e->expr_type != EXPR_FUNCTION
    || e->value.function.isym == NULL__null
    || e->value.function.isym->id != GFC_ISYM_MATMUL)
  return 0;

if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
    || in_omp_atomic || in_where || in_assoc_list)
  return 0;

/* Check if this is already in the form c = matmul(a,b).  */

if ((*current_code)->expr2 == e)
  return 0;

n = create_var (e, "matmul");

/* If create_var is unable to create a variable (for example if
   -fno-realloc-lhs is in force with a variable that does not have bounds
   known at compile-time), just return.  */

if (n == NULL__null)
  return 0;

*ep = n;
*found = true;
return 0;
3131}

3133/* Set current_code and associated variables so that matmul_to_var_expr can
 work.  */

3136static int
3137matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
    void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3139{
if (current_code != c)
  {
    current_code = c;
    inserted_block = NULL__null;
    changed_statement = NULL__null;
  }

return 0;
3148}


3151/* Take a statement of the shape c = matmul(a,b) and create temporaries
 for a and b if there is a dependency between the arguments and the
 result variable or if a or b are the result of calculations that cannot
 be handled by the inliner.  */

3156static int
3157matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
  void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3159{
gfc_expr *expr1, *expr2;
gfc_code *co;
gfc_actual_arglist *a, *b;
bool a_tmp, b_tmp;
gfc_expr *matrix_a, *matrix_b;
bool conjg_a, conjg_b, transpose_a, transpose_b;

co = *c;

if (co->op != EXEC_ASSIGN)
  return 0;

if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
    || in_omp_atomic || in_where)
  return 0;

/* This has some duplication with inline_matmul_assign.  This
   is because the creation of temporary variables could still fail,
   and inline_matmul_assign still needs to be able to handle these
   cases.  */
expr1 = co->expr1;
expr2 = co->expr2;

if (expr2->expr_type != EXPR_FUNCTION
    || expr2->value.function.isym == NULL__null
    || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
  return 0;

a_tmp = false;
a = expr2->value.function.actual;
matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
if (matrix_a != NULL__null)
  {
    if (matrix_a->expr_type == EXPR_VARIABLE
 && (gfc_check_dependency (matrix_a, expr1, true)
     || gfc_has_dimen_vector_ref (matrix_a)))
a_tmp = true;
  }
else
  a_tmp = true;

b_tmp = false;
b = a->next;
matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
if (matrix_b != NULL__null)
  {
    if (matrix_b->expr_type == EXPR_VARIABLE
 && (gfc_check_dependency (matrix_b, expr1, true)
     || gfc_has_dimen_vector_ref (matrix_b)))
b_tmp = true;
  }
else
  b_tmp = true;

if (!a_tmp && !b_tmp)
  return 0;

current_code = c;
inserted_block = NULL__null;
changed_statement = NULL__null;
if (a_tmp)
  {
    gfc_expr *at;
    at = create_var (a->expr,"mma");
    if (at)
a->expr = at;
  }
if (b_tmp)
  {
    gfc_expr *bt;
    bt = create_var (b->expr,"mmb");
    if (bt)
b->expr = bt;
  }
return 0;
3235}

3237/* Auxiliary function to build and simplify an array inquiry function.
 dim is zero-based.  */

3240static gfc_expr *
3241get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
3242{
gfc_expr *fcn;
gfc_expr *dim_arg, *kind;
const char *name;
gfc_expr *ec;

switch (id)
  {
  case GFC_ISYM_LBOUND:
    name = "_gfortran_lbound";
    break;

  case GFC_ISYM_UBOUND:
    name = "_gfortran_ubound";
    break;

  case GFC_ISYM_SIZE:
    name = "_gfortran_size";
    break;

  default:
    gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 3263, __FUNCTION__));
  }

dim_arg =  gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
if (okind != 0)
  kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
	     okind);
else
  kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
	     gfc_index_integer_kind);

ec = gfc_copy_expr (e);

/* No bounds checking, this will be done before the loops if -fcheck=bounds
   is in effect.  */
ec->no_bounds_check = 1;
fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
		  ec, dim_arg,  kind);
gfc_simplify_expr (fcn, 0);
fcn->no_bounds_check = 1;
return fcn;
3284}

3286/* Builds a logical expression.  */

3288static gfc_expr*
3289build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3290{
gfc_typespec ts;
gfc_expr *res;

ts.type = BT_LOGICAL;
ts.kind = gfc_default_logical_kind;
res = gfc_get_expr ();
res->where = e1->where;
res->expr_type = EXPR_OP;
res->value.op.op = op;
res->value.op.op1 = e1;
res->value.op.op2 = e2;
res->ts = ts;

return res;
3305}


3308/* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
 compatible typespecs.  */

3311static gfc_expr *
3312get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3313{
gfc_expr *res;

res = gfc_get_expr ();
res->ts = e1->ts;
res->where = e1->where;
res->expr_type = EXPR_OP;
res->value.op.op = op;
res->value.op.op1 = e1;
res->value.op.op2 = e2;
gfc_simplify_expr (res, 0);
return res;
3325}

3327/* Generate the IF statement for a runtime check if we want to do inlining or
 not - putting in the code for both branches and putting it into the syntax
 tree is the caller's responsibility.  For fixed array sizes, this should be
 removed by DCE. Only called for rank-two matrices A and B.  */

3332static gfc_code *
3333inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a)
3334{
gfc_expr *inline_limit;
gfc_code *if_1, *if_2, *else_2;
gfc_expr *b2, *a2, *a1, *m1, *m2;
gfc_typespec ts;
gfc_expr *cond;

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));

/* Calculation is done in real to avoid integer overflow.  */

inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
			&a->where);
mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODEMPFR_RNDN);

/* Set the limit according to the rank.  */
mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1,
      GFC_RND_MODEMPFR_RNDN);

a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);

/* For a_rank = 1, must use one as the size of a along the second
   dimension as to avoid too much code duplication.  */

if (rank_a == 2)
  a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
else
  a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1);

b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);

gfc_clear_ts (&ts);
ts.type = BT_REAL;
ts.kind = gfc_default_real_kind;
gfc_convert_type_warn (a1, &ts, 2, 0);
gfc_convert_type_warn (a2, &ts, 2, 0);
gfc_convert_type_warn (b2, &ts, 2, 0);

m1 = get_operand (INTRINSIC_TIMES, a1, a2);
m2 = get_operand (INTRINSIC_TIMES, m1, b2);

cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
gfc_simplify_expr (cond, 0);

else_2 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
else_2->op = EXEC_IF;
else_2->loc = a->where;

if_2 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
if_2->op = EXEC_IF;
if_2->expr1 = cond;
if_2->loc = a->where;
if_2->block = else_2;

if_1 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
if_1->op = EXEC_IF;
if_1->block = if_2;
if_1->loc = a->where;

return if_1;
3394}


3397/* Insert code to issue a runtime error if the expressions are not equal.  */

3399static gfc_code *
3400runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
3401{
gfc_expr *cond;
gfc_code *if_1, *if_2;
gfc_code *c;
gfc_actual_arglist *a1, *a2, *a3;

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));
/* Build the call to runtime_error.  */
c = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
c->op = EXEC_CALL;
c->loc = e1->where;

/* Get a null-terminated message string.  */

a1 = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
		     msg, strlen(msg)+1);
c->ext.actual = a1;

/* Pass the value of the first expression.  */
a2 = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
a2->expr = gfc_copy_expr (e1);
a1->next = a2;

/* Pass the value of the second expression.  */
a3 = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
a3->expr = gfc_copy_expr (e2);
a2->next = a3;

gfc_check_fe_runtime_error (c->ext.actual);
gfc_resolve_fe_runtime_error (c);

if_2 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
if_2->op = EXEC_IF;
if_2->loc = e1->where;
if_2->next = c;

if_1 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
if_1->op = EXEC_IF;
if_1->block = if_2;
if_1->loc = e1->where;

cond = build_logical_expr (INTRINSIC_NE, e1, e2);
gfc_simplify_expr (cond, 0);
if_2->expr1 = cond;

return if_1;
3448}

3450/* Handle matrix reallocation.  Caller is responsible to insert into
 the code tree.

 For the two-dimensional case, build

if (allocated(c)) then
   if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
      deallocate(c)
      allocate (c(size(a,1), size(b,2)))
   end if
else
   allocate (c(size(a,1),size(b,2)))
end if

and for the other cases correspondingly.
3465*/

3467static gfc_code *
3468matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
    enum matrix_case m_case)
3470{

gfc_expr *allocated, *alloc_expr;
gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
gfc_code *else_alloc;
gfc_code *deallocate, *allocate1, *allocate_else;
gfc_array_ref *ar;
gfc_expr *cond, *ne1, *ne2;

if (warn_realloc_lhsglobal_options.x_warn_realloc_lhs)
  gfc_warning (OPT_Wrealloc_lhs,
 "Code for reallocating the allocatable array at %L will "
 "be added", &c->where);

alloc_expr = gfc_copy_expr (c);

ar = gfc_find_array_ref (alloc_expr);
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));

/* c comes in as a full ref.  Change it into a copy and make it into an
   element ref so it has the right form for ALLOCATE.  In the same
   switch statement, also generate the size comparison for the secod IF
   statement.  */

ar->type = AR_ELEMENT;

switch (m_case)
  {
  case A2B2:
    ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    ne1 = build_logical_expr (INTRINSIC_NE,
		get_array_inq_function (GFC_ISYM_SIZE, c, 1),
		get_array_inq_function (GFC_ISYM_SIZE, a, 1));
    ne2 = build_logical_expr (INTRINSIC_NE,
		get_array_inq_function (GFC_ISYM_SIZE, c, 2),
		get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    break;

  case A2B2T:
    ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);

    ne1 = build_logical_expr (INTRINSIC_NE,
		get_array_inq_function (GFC_ISYM_SIZE, c, 1),
		get_array_inq_function (GFC_ISYM_SIZE, a, 1));
    ne2 = build_logical_expr (INTRINSIC_NE,
		get_array_inq_function (GFC_ISYM_SIZE, c, 2),
		get_array_inq_function (GFC_ISYM_SIZE, b, 1));
    cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    break;

  case A2TB2:

    ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
    ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);

    ne1 = build_logical_expr (INTRINSIC_NE,
		get_array_inq_function (GFC_ISYM_SIZE, c, 1),
		get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    ne2 = build_logical_expr (INTRINSIC_NE,
		get_array_inq_function (GFC_ISYM_SIZE, c, 2),
		get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    break;

  case A2B1:
    ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    cond = build_logical_expr (INTRINSIC_NE,
		 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
		 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    break;

  case A1B2:
    ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    cond = build_logical_expr (INTRINSIC_NE,
		 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
		 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    break;

  case A2TB2T:
    /* This can only happen for BLAS, we do not handle that case in
inline mamtul.  */
    ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
    ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);

    ne1 = build_logical_expr (INTRINSIC_NE,
		get_array_inq_function (GFC_ISYM_SIZE, c, 1),
		get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    ne2 = build_logical_expr (INTRINSIC_NE,
		get_array_inq_function (GFC_ISYM_SIZE, c, 2),
		get_array_inq_function (GFC_ISYM_SIZE, b, 1));

    cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    break;

  default:
    gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 3568, __FUNCTION__));

  }

gfc_simplify_expr (cond, 0);

/* We need two identical allocate statements in two
   branches of the IF statement.  */

allocate1 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
allocate1->op = EXEC_ALLOCATE;
allocate1->ext.alloc.list = gfc_get_alloc ()((gfc_alloc *) xcalloc (1, sizeof (gfc_alloc)));
allocate1->loc = c->where;
allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);

allocate_else = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
allocate_else->op = EXEC_ALLOCATE;
allocate_else->ext.alloc.list = gfc_get_alloc ()((gfc_alloc *) xcalloc (1, sizeof (gfc_alloc)));
allocate_else->loc = c->where;
allocate_else->ext.alloc.list->expr = alloc_expr;

allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
			"_gfortran_allocated", c->where,
			1, gfc_copy_expr (c));

deallocate = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
deallocate->op = EXEC_DEALLOCATE;
deallocate->ext.alloc.list = gfc_get_alloc ()((gfc_alloc *) xcalloc (1, sizeof (gfc_alloc)));
deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
deallocate->next = allocate1;
deallocate->loc = c->where;

if_size_2 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
if_size_2->op = EXEC_IF;
if_size_2->expr1 = cond;
if_size_2->loc = c->where;
if_size_2->next = deallocate;

if_size_1 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
if_size_1->op = EXEC_IF;
if_size_1->block = if_size_2;
if_size_1->loc = c->where;

else_alloc = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
else_alloc->op = EXEC_IF;
else_alloc->loc = c->where;
else_alloc->next = allocate_else;

if_alloc_2 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
if_alloc_2->op = EXEC_IF;
if_alloc_2->expr1 = allocated;
if_alloc_2->loc = c->where;
if_alloc_2->next = if_size_1;
if_alloc_2->block = else_alloc;

if_alloc_1 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
if_alloc_1->op = EXEC_IF;
if_alloc_1->block = if_alloc_2;
if_alloc_1->loc = c->where;

return if_alloc_1;
3629}

3631/* Callback function for has_function_or_op.  */

3633static int
3634is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
    void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3636{
if ((*e) == 0)
  return 0;
else
  return (*e)->expr_type == EXPR_FUNCTION
    || (*e)->expr_type == EXPR_OP;
3642}

3644/* Returns true if the expression contains a function.  */

3646static bool
3647has_function_or_op (gfc_expr **e)
3648{
if (e == NULL__null)
  return false;
else
  return gfc_expr_walker (e, is_function_or_op, NULL__null);
3653}

3655/* Freeze (assign to a temporary variable) a single expression.  */

3657static void
3658freeze_expr (gfc_expr **ep)
3659{
gfc_expr *ne;
if (has_function_or_op (ep))
  {
    ne = create_var (*ep, "freeze");
    *ep = ne;
  }
3666}

3668/* Go through an expression's references and assign them to temporary
 variables if they contain functions.  This is usually done prior to
 front-end scalarization to avoid multiple invocations of functions.  */

3672static void
3673freeze_references (gfc_expr *e)
3674{
gfc_ref *r;
gfc_array_ref *ar;
int i;

for (r=e->ref; r; r=r->next)
  {
    if (r->type == REF_SUBSTRING)
{
 if (r->u.ss.start != NULL__null)
   freeze_expr (&r->u.ss.start);

 if (r->u.ss.end != NULL__null)
   freeze_expr (&r->u.ss.end);
}
    else if (r->type == REF_ARRAY)
{
 ar = &r->u.ar;
 switch (ar->type)
   {
   case AR_FULL:
     break;

   case AR_SECTION:
     for (i=0; i<ar->dimen; i++)
{
  if (ar->dimen_type[i] == DIMEN_RANGE)
    {
      freeze_expr (&ar->start[i]);
      freeze_expr (&ar->end[i]);
      freeze_expr (&ar->stride[i]);
    }
  else if (ar->dimen_type[i] == DIMEN_ELEMENT)
    {
      freeze_expr (&ar->start[i]);
    }
}
     break;

   case AR_ELEMENT:
     for (i=0; i<ar->dimen; i++)
freeze_expr (&ar->start[i]);
     break;

   default:
     break;
   }
}
  }
3723}

3725/* Convert to gfc_index_integer_kind if needed, just do a copy otherwise.  */

3727static gfc_expr *
3728convert_to_index_kind (gfc_expr *e)
3729{
gfc_expr *res;

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));

res = gfc_copy_expr (e);

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));

if (res->ts.kind != gfc_index_integer_kind)
  {
    gfc_typespec ts;
    gfc_clear_ts (&ts);
    ts.type = BT_INTEGER;
    ts.kind = gfc_index_integer_kind;

    gfc_convert_type_warn (e, &ts, 2, 0);
  }

return res;
3749}

3751/* Function to create a DO loop including creation of the
 iteration variable.  gfc_expr are copied.*/

3754static gfc_code *
3755create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
gfc_namespace *ns, char *vname)
3757{

char name[GFC_MAX_SYMBOL_LEN63 +1];
gfc_symtree *symtree;
gfc_symbol *symbol;
gfc_expr *i;
gfc_code *n, *n2;

/* Create an expression for the iteration variable.  */
if (vname)
  sprintf (name, "__var_%d_do_%s", var_num++, vname);
else
  sprintf (name, "__var_%d_do", var_num++);


if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
  gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 3773, __FUNCTION__));

/* Create the loop variable.  */

symbol = symtree->n.sym;
symbol->ts.type = BT_INTEGER;
symbol->ts.kind = gfc_index_integer_kind;
symbol->attr.flavor = FL_VARIABLE;
symbol->attr.referenced = 1;
symbol->attr.dimension = 0;
symbol->attr.fe_temp = 1;
gfc_commit_symbol (symbol);

i = gfc_get_expr ();
i->expr_type = EXPR_VARIABLE;
i->ts = symbol->ts;
i->rank = 0;
i->where = *where;
i->symtree = symtree;

/* ... and the nested DO statements.  */
n = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
n->op = EXEC_DO;
n->loc = *where;
n->ext.iterator = gfc_get_iterator ()((gfc_iterator *) xcalloc (1, sizeof (gfc_iterator)));
n->ext.iterator->var = i;
n->ext.iterator->start = convert_to_index_kind (start);
n->ext.iterator->end = convert_to_index_kind (end);
if (step)
  n->ext.iterator->step = convert_to_index_kind (step);
else
  n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
			      where, 1);

n2 = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
n2->op = EXEC_DO;
n2->loc = *where;
n2->next = NULL__null;
n->block = n2;
return n;
3813}

3815/* Get the upper bound of the DO loops for matmul along a dimension.  This
is one-based.  */

3818static gfc_expr*
3819get_size_m1 (gfc_expr *e, int dimen)
3820{
mpz_t size;
gfc_expr *res;

if (gfc_array_dimen_size (e, dimen - 1, &size))
  {
    res = gfc_get_constant_expr (BT_INTEGER,
		   gfc_index_integer_kind, &e->where);
    mpz_sub_ui__gmpz_sub_ui (res->value.integer, size, 1);
    mpz_clear__gmpz_clear (size);
  }
else
  {
    res = get_operand (INTRINSIC_MINUS,
	 get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
	 gfc_get_int_expr (gfc_index_integer_kind,
			   &e->where, 1));
    gfc_simplify_expr (res, 0);
  }

return res;
3841}

3843/* Function to return a scalarized expression. It is assumed that indices are
zero based to make generation of DO loops easier.  A zero as index will
access the first element along a dimension.  Single element references will
be skipped.  A NULL as an expression will be replaced by a full reference.
This assumes that the index loops have gfc_index_integer_kind, and that all
references have been frozen.  */

3850static gfc_expr*
3851scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
3852{
gfc_array_ref *ar;
int i;
int rank;
gfc_expr *e;
int i_index;
bool was_fullref;

e = gfc_copy_expr(e_in);

rank = e->rank;

ar = gfc_find_array_ref (e);

/* We scalarize count_index variables, reducing the rank by count_index.  */

e->rank = rank - count_index;

was_fullref = ar->type == AR_FULL;
41
←
Assuming field 'type' is not equal to AR_FULL→

if (e->rank == 0)
42
←
Assuming field 'rank' is not equal to 0→
43
←
Taking false branch→
  ar->type = AR_ELEMENT;
else
  ar->type = AR_SECTION;

/* Loop over the indices.  For each index, create the expression
   index * stride + lbound(e, dim).  */

i_index = 0;
for (i=0; i < ar->dimen; i++)
44
←
Assuming 'i' is < field 'dimen'→
55
←
Assuming 'i' is < field 'dimen'→
  {
    if (was_fullref44.1
'was_fullref' is false
1
'was_fullref' is false
 || ar->dimen_type[i] == DIMEN_RANGE)
45
←
Assuming the condition is true→
46
←
Taking true branch→
56
←
Assuming the condition is true→
57
←
Taking true branch→
{
 if (index[i_index] != NULL__null)
47
←
Taking true branch→
58
←
The left operand of '!=' is a garbage value
   {
     gfc_expr *lbound, *nindex;
     gfc_expr *loopvar;

     loopvar = gfc_copy_expr (index[i_index]);

     if (ar->stride[i])
48
←
Assuming the condition is false→
49
←
Taking false branch→
{
  gfc_expr *tmp;

  tmp = gfc_copy_expr(ar->stride[i]);
  if (tmp->ts.kind != gfc_index_integer_kind)
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);
      ts.type = BT_INTEGER;
      ts.kind = gfc_index_integer_kind;
      gfc_convert_type (tmp, &ts, 2);
    }
  nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
}
     else
nindex = loopvar;

     /* Calculate the lower bound of the expression.  */
     if (ar->start[i])
50
←
Assuming the condition is true→
51
←
Taking true branch→
{
  lbound = gfc_copy_expr (ar->start[i]);
  if (lbound->ts.kind != gfc_index_integer_kind)
52
←
Assuming 'gfc_index_integer_kind' is equal to field 'kind'→
53
←
Taking false branch→
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);
      ts.type = BT_INTEGER;
      ts.kind = gfc_index_integer_kind;
      gfc_convert_type (lbound, &ts, 2);

    }
}
     else
{
  gfc_expr *lbound_e;
  gfc_ref *ref;

  lbound_e = gfc_copy_expr (e_in);

  for (ref = lbound_e->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY
	&& (ref->u.ar.type == AR_FULL
	    || ref->u.ar.type == AR_SECTION))
      break;

  if (ref->next)
    {
      gfc_free_ref_list (ref->next);
      ref->next = NULL__null;
    }

  if (!was_fullref)
    {
      /* Look at full individual sections, like a(:).  The first index
	 is the lbound of a full ref.  */
      int j;
      gfc_array_ref *ar;
      int to;

      ar = &ref->u.ar;

      /* For assumed size, we need to keep around the final
	 reference in order not to get an error on resolution
	 below, and we cannot use AR_FULL.  */

      if (ar->as->type == AS_ASSUMED_SIZE)
	{
	  ar->type = AR_SECTION;
	  to = ar->dimen - 1;
	}
      else
	{
	  to = ar->dimen;
	  ar->type = AR_FULL;
	}

      for (j = 0; j < to; j++)
	{
	  gfc_free_expr (ar->start[j]);
	  ar->start[j] = NULL__null;
	  gfc_free_expr (ar->end[j]);
	  ar->end[j] = NULL__null;
	  gfc_free_expr (ar->stride[j]);
	  ar->stride[j] = NULL__null;
	}

      /* We have to get rid of the shape, if there is one.  Do
	 so by freeing it and calling gfc_resolve to rebuild
	 it, if necessary.  */

      if (lbound_e->shape)
	gfc_free_shape (&(lbound_e->shape), lbound_e->rank);

      lbound_e->rank = ar->dimen;
      gfc_resolve_expr (lbound_e);
    }
  lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
				   i + 1);
  gfc_free_expr (lbound_e);
}

     ar->dimen_type[i] = DIMEN_ELEMENT;

     gfc_free_expr (ar->start[i]);
     ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);

     gfc_free_expr (ar->end[i]);
     ar->end[i] = NULL__null;
     gfc_free_expr (ar->stride[i]);
     ar->stride[i] = NULL__null;
     gfc_simplify_expr (ar->start[i], 0);
   }
 else if (was_fullref)
   {
     gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
   }
 i_index ++;
54
←
The value 1 is assigned to 'i_index'→
}
  }

/* Bounds checking will be done before the loops if -fcheck=bounds
   is in effect. */
e->no_bounds_check = 1;
return e;
4016}

4018/* Helper function to check for a dimen vector as subscript.  */

4020bool
4021gfc_has_dimen_vector_ref (gfc_expr *e)
4022{
gfc_array_ref *ar;
int i;

ar = gfc_find_array_ref (e);
gcc_assert (ar)((void)(!(ar) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 4027, __FUNCTION__), 0 : 0));
if (ar->type == AR_FULL)
  return false;

for (i=0; i<ar->dimen; i++)
  if (ar->dimen_type[i] == DIMEN_VECTOR)
    return true;

return false;
4036}

4038/* If handed an expression of the form

 TRANSPOSE(CONJG(A))

 check if A can be handled by matmul and return if there is an uneven number
 of CONJG calls.  Return a pointer to the array when everything is OK, NULL
 otherwise. The caller has to check for the correct rank.  */

4046static gfc_expr*
4047check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
4048{
*conjg = false;
*transpose = false;

do
  {
    if (e->expr_type == EXPR_VARIABLE)
{
 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));
 return e;
}
    else if (e->expr_type == EXPR_FUNCTION)
{
 if (e->value.function.isym == NULL__null)
   return NULL__null;

 if (e->value.function.isym->id == GFC_ISYM_CONJG)
   *conjg = !*conjg;
 else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
   *transpose = !*transpose;
 else return NULL__null;
}
    else
return NULL__null;

    e = e->value.function.actual->expr;
  }
while(1);

return NULL__null;
4078}

4080/* Macros for unified error messages.  */

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")
     "dimension 1: is %ld, should be %ld")gettext ("Incorrect extent in argument B in MATMUL intrinsic in "
 "dimension 1: is %ld, should be %ld")

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)"
)
    "(%ld/%ld)")gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
)

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)"
)
    "(%ld/%ld)")gettext ("Array bound mismatch for dimension 2 of array " "(%ld/%ld)"
)


4092/* Inline assignments of the form c = matmul(a,b).
 Handle only the cases currently where b and c are rank-two arrays.

 This basically translates the code to

 BLOCK
   integer i,j,k
   c = 0
   do j=0, size(b,2)-1
     do k=0, size(a, 2)-1
       do i=0, size(a, 1)-1
          c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
   c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
          a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
          b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
       end do
     end do
   end do
 END BLOCK

4112*/

4114static int
4115inline_matmul_assign (gfc_code **c, int *walk_subtrees,
	  void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
4117{
gfc_code *co = *c;
gfc_expr *expr1, *expr2;
gfc_expr *matrix_a, *matrix_b;
gfc_actual_arglist *a, *b;
gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
gfc_expr *zero_e;
gfc_expr *u1, *u2, *u3;
gfc_expr *list[2];
gfc_expr *ascalar, *bscalar, *cscalar;
gfc_expr *mult;
gfc_expr *var_1, *var_2, *var_3;
gfc_expr *zero;
gfc_namespace *ns;
gfc_intrinsic_op op_times, op_plus;
enum matrix_case m_case;
int i;
gfc_code *if_limit = NULL__null;
gfc_code **next_code_point;
bool conjg_a, conjg_b, transpose_a, transpose_b;
bool realloc_c;

if (co->op != EXEC_ASSIGN)
1
Assuming field 'op' is equal to EXEC_ASSIGN→
  return 0;

if (in_where || in_assoc_list)
2
←
Assuming 'in_where' is false→
3
←
Assuming 'in_assoc_list' is false→
4
←
Taking false branch→
  return 0;

/* The BLOCKS generated for the temporary variables and FORALL don't
   mix.  */
if (forall_level > 0)
5
←
Assuming 'forall_level' is <= 0→
  return 0;

/* For now don't do anything in OpenMP workshare, it confuses
   its translation, which expects only the allowed statements in there.
   We should figure out how to parallelize this eventually.  */
if (in_omp_workshare || in_omp_atomic)
6
←
Assuming 'in_omp_workshare' is false→
7
←
Assuming 'in_omp_atomic' is false→
8
←
Taking false branch→
  return 0;

expr1 = co->expr1;
expr2 = co->expr2;
if (expr2->expr_type != EXPR_FUNCTION
9
←
Assuming field 'expr_type' is equal to EXPR_FUNCTION→
12
←
Taking false branch→
    || expr2->value.function.isym == NULL__null
10
←
Assuming field 'isym' is not equal to NULL→
    || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
11
←
Assuming field 'id' is equal to GFC_ISYM_MATMUL→
  return 0;

current_code = c;
inserted_block = NULL__null;
changed_statement = NULL__null;

a = expr2->value.function.actual;
matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
if (matrix_a == NULL__null)
13
←
Assuming 'matrix_a' is not equal to NULL→
14
←
Taking false branch→
  return 0;

b = a->next;
matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
if (matrix_b == NULL__null)
15
←
Assuming 'matrix_b' is not equal to NULL→
  return 0;

if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a)
16
←
Assuming the condition is false→
17
←
Assuming the condition is false→
    || gfc_has_dimen_vector_ref (matrix_b))
18
←
Assuming the condition is false→
  return 0;

/* We do not handle data dependencies yet.  */
if (gfc_check_dependency (expr1, matrix_a, true)
19
←
Assuming the condition is false→
21
←
Taking false branch→
    || gfc_check_dependency (expr1, matrix_b, true))
20
←
Assuming the condition is false→
  return 0;

m_case = none;
if (matrix_a->rank == 2)
22
←
Assuming field 'rank' is not equal to 2→
23
←
Taking false branch→
  {
    if (transpose_a)
{
 if (matrix_b->rank == 2 && !transpose_b)
   m_case = A2TB2;
}
    else
{
 if (matrix_b->rank == 1)
   m_case = A2B1;
 else /* matrix_b->rank == 2 */
   {
     if (transpose_b)
m_case = A2B2T;
     else
m_case = A2B2;
   }
}
  }
else /* matrix_a->rank == 1 */
  {
    if (matrix_b->rank == 2)
24
←
Assuming field 'rank' is equal to 2→
25
←
Taking true branch→
{
 if (!transpose_b)
26
←
Assuming 'transpose_b' is false→
27
←
Taking true branch→
   m_case = A1B2;
}
  }

if (m_case27.1
'm_case' is not equal to none
 == none)
28
←
Taking false branch→
  return 0;

/* We only handle assignment to numeric or logical variables.  */
switch(expr1->ts.type)
29
←
Control jumps to 'case BT_INTEGER:'  at line 4222→
  {
  case BT_INTEGER:
  case BT_LOGICAL:
  case BT_REAL:
  case BT_COMPLEX:
    break;
30
←
 Execution continues on line 4232→

  default:
    return 0;
  }

ns = insert_block ();

/* Assign the type of the zero expression for initializing the resulting
   array, and the expression (+ and * for real, integer and complex;
   .and. and .or for logical.  */

switch(expr1->ts.type)
31
←
Control jumps to 'case BT_INTEGER:'  at line 4240→
  {
  case BT_INTEGER:
    zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
    op_times = INTRINSIC_TIMES;
    op_plus = INTRINSIC_PLUS;
    break;
32
←
 Execution continues on line 4273→

  case BT_LOGICAL:
    op_times = INTRINSIC_AND;
    op_plus = INTRINSIC_OR;
    zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
		     0);
    break;
  case BT_REAL:
    zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
		      &expr1->where);
    mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODEMPFR_RNDN);
    op_times = INTRINSIC_TIMES;
    op_plus = INTRINSIC_PLUS;
    break;

  case BT_COMPLEX:
    zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
		      &expr1->where);
    mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODEMPFR_RNDN);
    op_times = INTRINSIC_TIMES;
    op_plus = INTRINSIC_PLUS;

    break;

  default:
    gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 4270, __FUNCTION__));
  }

current_code = &ns->code;

/* Freeze the references, keeping track of how many temporary variables were
   created.  */
n_vars = 0;
freeze_references (matrix_a);
freeze_references (matrix_b);
freeze_references (expr1);

if (n_vars32.1
'n_vars' is equal to 0
 == 0)
33
←
Taking true branch→
  next_code_point = current_code;
else
  {
    next_code_point = &ns->code;
    for (i=0; i<n_vars; i++)
next_code_point = &(*next_code_point)->next;
  }

/* Take care of the inline flag.  If the limit check evaluates to a
   constant, dead code elimination will eliminate the unneeded branch.  */

if (flag_inline_matmul_limitglobal_options.x_flag_inline_matmul_limit > 0
34
←
Assuming field 'x_flag_inline_matmul_limit' is <= 0→
    && (matrix_a->rank == 1 || matrix_a->rank == 2)
    && matrix_b->rank == 2)
  {
    if_limit = inline_limit_check (matrix_a, matrix_b,
		     flag_inline_matmul_limitglobal_options.x_flag_inline_matmul_limit,
		     matrix_a->rank);

    /* Insert the original statement into the else branch.  */
    if_limit->block->block->next = co;
    co->next = NULL__null;

    /* ... and the new ones go into the original one.  */
    *next_code_point = if_limit;
    next_code_point = &if_limit->block->next;
  }

zero_e->no_bounds_check = 1;

assign_zero = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
assign_zero->op = EXEC_ASSIGN;
assign_zero->loc = co->loc;
assign_zero->expr1 = gfc_copy_expr (expr1);
assign_zero->expr1->no_bounds_check = 1;
assign_zero->expr2 = zero_e;

realloc_c = flag_realloc_lhsglobal_options.x_flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
35
←
Assuming field 'x_flag_realloc_lhs' is 0→

if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
36
←
Assuming the condition is false→
37
←
Taking false branch→
  {
    gfc_code *test;
    gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;

    switch (m_case)
{
case A2B1:

 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
     test = runtime_error_ne (c1, a1, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

case A1B2:

 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
     test = runtime_error_ne (c1, b2, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

case A2B2:

 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
     test = runtime_error_ne (c1, a1, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;

     c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
     b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
     test = runtime_error_ne (c2, b2, C_ERROR_2gettext ("Array bound mismatch for dimension 2 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

case A2B2T:

 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
 /* matrix_b is transposed, hence dimension 1 for the error message.  */
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
     test = runtime_error_ne (c1, a1, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;

     c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
     b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
     test = runtime_error_ne (c2, b1, C_ERROR_2gettext ("Array bound mismatch for dimension 2 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

case A2TB2:

 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
     test = runtime_error_ne (c1, a2, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;

     c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
     b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
     test = runtime_error_ne (c2, b2, C_ERROR_2gettext ("Array bound mismatch for dimension 2 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

default:
 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 4439, __FUNCTION__));
}
  }

/* Handle the reallocation, if needed.  */

if (realloc_c37.1
'realloc_c' is false
)
38
←
Taking false branch→
  {
    gfc_code *lhs_alloc;

    lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);

    *next_code_point = lhs_alloc;
    next_code_point = &lhs_alloc->next;

  }

*next_code_point = assign_zero;

zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);

assign_matmul = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
assign_matmul->op = EXEC_ASSIGN;
assign_matmul->loc = co->loc;

/* Get the bounds for the loops, create them and create the scalarized
   expressions.  */

switch (m_case)
39
←
Control jumps to 'case A1B2:'  at line 4590→
  {
  case A2B2:

    u1 = get_size_m1 (matrix_b, 2);
    u2 = get_size_m1 (matrix_a, 2);
    u3 = get_size_m1 (matrix_a, 1);

    do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL__null, &co->loc, ns);
    do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL__null, &co->loc, ns);
    do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL__null, &co->loc, ns);

    do_1->block->next = do_2;
    do_2->block->next = do_3;
    do_3->block->next = assign_matmul;

    var_1 = do_1->ext.iterator->var;
    var_2 = do_2->ext.iterator->var;
    var_3 = do_3->ext.iterator->var;

    list[0] = var_3;
    list[1] = var_1;
    cscalar = scalarized_expr (co->expr1, list, 2);

    list[0] = var_3;
    list[1] = var_2;
    ascalar = scalarized_expr (matrix_a, list, 2);

    list[0] = var_2;
    list[1] = var_1;
    bscalar = scalarized_expr (matrix_b, list, 2);

    break;

  case A2B2T:

    u1 = get_size_m1 (matrix_b, 1);
    u2 = get_size_m1 (matrix_a, 2);
    u3 = get_size_m1 (matrix_a, 1);

    do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL__null, &co->loc, ns);
    do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL__null, &co->loc, ns);
    do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL__null, &co->loc, ns);

    do_1->block->next = do_2;
    do_2->block->next = do_3;
    do_3->block->next = assign_matmul;

    var_1 = do_1->ext.iterator->var;
    var_2 = do_2->ext.iterator->var;
    var_3 = do_3->ext.iterator->var;

    list[0] = var_3;
    list[1] = var_1;
    cscalar = scalarized_expr (co->expr1, list, 2);

    list[0] = var_3;
    list[1] = var_2;
    ascalar = scalarized_expr (matrix_a, list, 2);

    list[0] = var_1;
    list[1] = var_2;
    bscalar = scalarized_expr (matrix_b, list, 2);

    break;

  case A2TB2:

    u1 = get_size_m1 (matrix_a, 2);
    u2 = get_size_m1 (matrix_b, 2);
    u3 = get_size_m1 (matrix_a, 1);

    do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL__null, &co->loc, ns);
    do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL__null, &co->loc, ns);
    do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL__null, &co->loc, ns);

    do_1->block->next = do_2;
    do_2->block->next = do_3;
    do_3->block->next = assign_matmul;

    var_1 = do_1->ext.iterator->var;
    var_2 = do_2->ext.iterator->var;
    var_3 = do_3->ext.iterator->var;

    list[0] = var_1;
    list[1] = var_2;
    cscalar = scalarized_expr (co->expr1, list, 2);

    list[0] = var_3;
    list[1] = var_1;
    ascalar = scalarized_expr (matrix_a, list, 2);

    list[0] = var_3;
    list[1] = var_2;
    bscalar = scalarized_expr (matrix_b, list, 2);

    break;

  case A2B1:
    u1 = get_size_m1 (matrix_b, 1);
    u2 = get_size_m1 (matrix_a, 1);

    do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL__null, &co->loc, ns);
    do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL__null, &co->loc, ns);

    do_1->block->next = do_2;
    do_2->block->next = assign_matmul;

    var_1 = do_1->ext.iterator->var;
    var_2 = do_2->ext.iterator->var;

    list[0] = var_2;
    cscalar = scalarized_expr (co->expr1, list, 1);

    list[0] = var_2;
    list[1] = var_1;
    ascalar = scalarized_expr (matrix_a, list, 2);

    list[0] = var_1;
    bscalar = scalarized_expr (matrix_b, list, 1);

    break;

  case A1B2:
    u1 = get_size_m1 (matrix_b, 2);
    u2 = get_size_m1 (matrix_a, 1);

    do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL__null, &co->loc, ns);
    do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL__null, &co->loc, ns);

    do_1->block->next = do_2;
    do_2->block->next = assign_matmul;

    var_1 = do_1->ext.iterator->var;
    var_2 = do_2->ext.iterator->var;

    list[0] = var_1;
    cscalar = scalarized_expr (co->expr1, list, 1);
40
←
Calling 'scalarized_expr'→

    list[0] = var_2;
    ascalar = scalarized_expr (matrix_a, list, 1);

    list[0] = var_2;
    list[1] = var_1;
    bscalar = scalarized_expr (matrix_b, list, 2);

    break;

  default:
    gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 4616, __FUNCTION__));
  }

/* Build the conjg call around the variables.  Set the typespec manually
   because gfc_build_intrinsic_call sometimes gets this wrong.  */
if (conjg_a)
  {
    gfc_typespec ts;
    ts = matrix_a->ts;
    ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
			  matrix_a->where, 1, ascalar);
    ascalar->ts = ts;
  }

if (conjg_b)
  {
    gfc_typespec ts;
    ts = matrix_b->ts;
    bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
			  matrix_b->where, 1, bscalar);
    bscalar->ts = ts;
  }
/* First loop comes after the zero assignment.  */
assign_zero->next = do_1;

/* Build the assignment expression in the loop.  */
assign_matmul->expr1 = gfc_copy_expr (cscalar);

mult = get_operand (op_times, ascalar, bscalar);
assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);

/* If we don't want to keep the original statement around in
   the else branch, we can free it.  */

if (if_limit == NULL__null)
  gfc_free_statements(co);
else
  co->next = NULL__null;

gfc_free_expr (zero);
*walk_subtrees = 0;
return 0;
4658}

4660/* Change matmul function calls in the form of

 c = matmul(a,b)

 to the corresponding call to a BLAS routine, if applicable.  */

4666static int
4667call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
    void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
4669{
gfc_code *co, *co_next;
gfc_expr *expr1, *expr2;
gfc_expr *matrix_a, *matrix_b;
gfc_code *if_limit = NULL__null;
gfc_actual_arglist *a, *b;
bool conjg_a, conjg_b, transpose_a, transpose_b;
gfc_code *call;
const char *blas_name;
const char *transa, *transb;
gfc_expr *c1, *c2, *b1;
gfc_actual_arglist *actual, *next;
bt type;
int kind;
enum matrix_case m_case;
bool realloc_c;
gfc_code **next_code_point;

/* Many of the tests for inline matmul also apply here.  */

co = *c;

if (co->op != EXEC_ASSIGN)
  return 0;

if (in_where || in_assoc_list)
  return 0;

/* The BLOCKS generated for the temporary variables and FORALL don't
   mix.  */
if (forall_level > 0)
  return 0;

/* For now don't do anything in OpenMP workshare, it confuses
   its translation, which expects only the allowed statements in there. */

if (in_omp_workshare || in_omp_atomic)
  return 0;

expr1 = co->expr1;
expr2 = co->expr2;
if (expr2->expr_type != EXPR_FUNCTION
    || expr2->value.function.isym == NULL__null
    || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
  return 0;

type = expr2->ts.type;
kind = expr2->ts.kind;

/* Guard against recursion. */

if (expr2->external_blas)
  return 0;

if (type != expr1->ts.type || kind != expr1->ts.kind)
  return 0;

if (type == BT_REAL)
  {
    if (kind == 4)
blas_name = "sgemm";
    else if (kind == 8)
blas_name = "dgemm";
    else
return 0;
  }
else if (type == BT_COMPLEX)
  {
    if (kind == 4)
blas_name = "cgemm";
    else if (kind == 8)
blas_name = "zgemm";
    else
return 0;
  }
else
  return 0;

a = expr2->value.function.actual;
if (a->expr->rank != 2)
  return 0;

b = a->next;
if (b->expr->rank != 2)
  return 0;

matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
if (matrix_a == NULL__null)
  return 0;

if (transpose_a)
  {
    if (conjg_a)
transa = "C";
    else
transa = "T";
  }
else
  transa = "N";

matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
if (matrix_b == NULL__null)
  return 0;

if (transpose_b)
  {
    if (conjg_b)
transb = "C";
    else
transb = "T";
  }
else
  transb = "N";

if (transpose_a)
  {
    if (transpose_b)
m_case = A2TB2T;
    else
m_case = A2TB2;
  }
else
  {
    if (transpose_b)
m_case = A2B2T;
    else
m_case = A2B2;
  }

current_code = c;
inserted_block = NULL__null;
changed_statement = NULL__null;

expr2->external_blas = 1;

/* We do not handle data dependencies yet.  */
if (gfc_check_dependency (expr1, matrix_a, true)
    || gfc_check_dependency (expr1, matrix_b, true))
  return 0;

/* Generate the if statement and hang it into the tree.  */
if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limitglobal_options.x_flag_blas_matmul_limit, 2);
co_next = co->next;
(*current_code) = if_limit;
co->next = NULL__null;
if_limit->block->next = co;

call = XCNEW (gfc_code)((gfc_code *) xcalloc (1, sizeof (gfc_code)));
call->loc = co->loc;

/* Bounds checking - a bit simpler than for inlining since we only
   have to take care of two-dimensional arrays here.  */

realloc_c = flag_realloc_lhsglobal_options.x_flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
next_code_point = &(if_limit->block->block->next);

if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
  {
    gfc_code *test;
    //      gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
    gfc_expr *c1, *a1, *c2, *b2, *a2;
    switch (m_case)
{
case A2B2:
 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
     test = runtime_error_ne (c1, a1, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;

     c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
     b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
     test = runtime_error_ne (c2, b2, C_ERROR_2gettext ("Array bound mismatch for dimension 2 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

case A2B2T:

 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
 /* matrix_b is transposed, hence dimension 1 for the error message.  */
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
     test = runtime_error_ne (c1, a1, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;

     c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
     b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
     test = runtime_error_ne (c2, b1, C_ERROR_2gettext ("Array bound mismatch for dimension 2 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

case A2TB2:

 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
     test = runtime_error_ne (c1, a2, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;

     c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
     b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
     test = runtime_error_ne (c2, b2, C_ERROR_2gettext ("Array bound mismatch for dimension 2 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

case A2TB2T:
 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
 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"));
 *next_code_point = test;
 next_code_point = &test->next;

 if (!realloc_c)
   {
     c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
     a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
     test = runtime_error_ne (c1, a2, C_ERROR_1gettext ("Array bound mismatch for dimension 1 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;

     c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
     b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
     test = runtime_error_ne (c2, b1, C_ERROR_2gettext ("Array bound mismatch for dimension 2 of array " "(%ld/%ld)"
));
     *next_code_point = test;
     next_code_point = &test->next;
   }
 break;

default:
 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/frontend-passes.cc"
, 4928, __FUNCTION__));
}
  }

/* Handle the reallocation, if needed.  */

if (realloc_c)
  {
    gfc_code *lhs_alloc;

    lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
    *next_code_point = lhs_alloc;
    next_code_point = &lhs_alloc->next;
  }

*next_code_point = call;
if_limit->next = co_next;

/* Set up the BLAS call.  */

call->op = EXEC_CALL;

gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
call->symtree->n.sym->attr.subroutine = 1;
call->symtree->n.sym->attr.procedure = 1;
call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
call->resolved_sym = call->symtree->n.sym;
gfc_commit_symbol (call->resolved_sym);

/* Argument TRANSA.  */
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
		       transa, 1);

call->ext.actual = next;

/* Argument TRANSB.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
		       transb, 1);
actual->next = next;

c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
	       gfc_integer_4_kind4);
c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
	       gfc_integer_4_kind4);

b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
	       gfc_integer_4_kind4);

/* Argument M. */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = c1;
actual->next = next;

/* Argument N. */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = c2;
actual->next = next;

/* Argument K.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = b1;
actual->next = next;

/* Argument ALPHA - set to one.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = gfc_get_constant_expr (type, kind, &co->loc);
if (type == BT_REAL)
  mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODEMPFR_RNDN);
else
  mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
actual->next = next;

/* Argument A.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = gfc_copy_expr (matrix_a);
actual->next = next;

/* Argument LDA.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
		       1, gfc_integer_4_kind4);
actual->next = next;

/* Argument B.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = gfc_copy_expr (matrix_b);
actual->next = next;

/* Argument LDB.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
		       1, gfc_integer_4_kind4);
actual->next = next;

/* Argument BETA - set to zero.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = gfc_get_constant_expr (type, kind, &co->loc);
if (type == BT_REAL)
  mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODEMPFR_RNDN);
else
  mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
actual->next = next;

/* Argument C.  */

actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = gfc_copy_expr (expr1);
actual->next = next;

/* Argument LDC.  */
actual = next;
next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
		       1, gfc_integer_4_kind4);
actual->next = next;

return 0;
5058}


5061/* Code for index interchange for loops which are grouped together in DO
 CONCURRENT or FORALL statements.  This is currently only applied if the
 iterations are grouped together in a single statement.

 For this transformation, it is assumed that memory access in strides is
 expensive, and that loops which access later indices (which access memory
 in bigger strides) should be moved to the first loops.

 For this, a loop over all the statements is executed, counting the times
 that the loop iteration values are accessed in each index.  The loop
 indices are then sorted to minimize access to later indices from inner
 loops.  */

5074/* Type for holding index information.  */

5076typedef struct {
gfc_symbol *sym;
gfc_forall_iterator *fa;
int num;
int n[GFC_MAX_DIMENSIONS15];
5081} ind_type;

5083/* Callback function to determine if an expression is the
 corresponding variable.  */

5086static int
5087has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)), void *data)
5088{
gfc_expr *expr = *e;
gfc_symbol *sym;

if (expr->expr_type != EXPR_VARIABLE)
  return 0;

sym = (gfc_symbol *) data;
return sym == expr->symtree->n.sym;
5097}

5099/* Callback function to calculate the cost of a certain index.  */

5101static int
5102index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
   void *data)
5104{
ind_type *ind;
gfc_expr *expr;
gfc_array_ref *ar;
gfc_ref *ref;
int i,j;

expr = *e;
if (expr->expr_type != EXPR_VARIABLE)
  return 0;

ar = NULL__null;
for (ref = expr->ref; ref; ref = ref->next)
  {
    if (ref->type == REF_ARRAY)
{
 ar = &ref->u.ar;
 break;
}
  }
if (ar == NULL__null || ar->type != AR_ELEMENT)
  return 0;

ind = (ind_type *) data;
for (i = 0; i < ar->dimen; i++)
  {
    for (j=0; ind[j].sym != NULL__null; j++)
{
 if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
     ind[j].n[i]++;
}
  }
return 0;
5137}

5139/* Callback function for qsort, to sort the loop indices. */

5141static int
5142loop_comp (const void *e1, const void *e2)
5143{
const ind_type *i1 = (const ind_type *) e1;
const ind_type *i2 = (const ind_type *) e2;
int i;

for (i=GFC_MAX_DIMENSIONS15-1; i >= 0; i--)
  {
    if (i1->n[i] != i2->n[i])
return i1->n[i] - i2->n[i];
  }
/* All other things being equal, let's not change the ordering.  */
return i2->num - i1->num;
5155}

5157/* Main function to do the index interchange.  */

5159static int
5160index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
  void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
5162{
gfc_code *co;
co = *c;
int n_iter;
gfc_forall_iterator *fa;
ind_type *ind;
int i, j;

if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
  return 0;

n_iter = 0;
for (fa = co->ext.forall_iterator; fa; fa = fa->next)
  n_iter ++;

/* Nothing to reorder. */
if (n_iter < 2)
  return 0;

ind = XALLOCAVEC (ind_type, n_iter + 1)((ind_type *) __builtin_alloca(sizeof (ind_type) * (n_iter + 1
)));

i = 0;
for (fa = co->ext.forall_iterator; fa; fa = fa->next)
  {
    ind[i].sym = fa->var->symtree->n.sym;
    ind[i].fa = fa;
    for (j=0; j<GFC_MAX_DIMENSIONS15; j++)
ind[i].n[j] = 0;
    ind[i].num = i;
    i++;
  }
ind[n_iter].sym = NULL__null;
ind[n_iter].fa = NULL__null;

gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp)gcc_qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp
);

/* Do the actual index interchange.  */
co->ext.forall_iterator = fa = ind[0].fa;
for (i=1; i<n_iter; i++)
  {
    fa->next = ind[i].fa;
    fa = fa->next;
  }
fa->next = NULL__null;

if (flag_warn_frontend_loop_interchangeglobal_options.x_flag_warn_frontend_loop_interchange)
  {
    for (i=1; i<n_iter; i++)
{
 if (ind[i-1].num > ind[i].num)
   {
     gfc_warning (OPT_Wfrontend_loop_interchange,
	   "Interchanging loops at %L", &co->loc);
     break;
   }
}
  }

return 0;
5222}

5224#define WALK_SUBEXPR(NODE)do { result = gfc_expr_walker (&(NODE), exprfn, data); if
 (result) return result; } while (0) \
do							\
  {							\
    result = gfc_expr_walker (&(NODE), exprfn, data);	\
    if (result)					\
return result;					\
  }							\
while (0)
5232#define WALK_SUBEXPR_TAIL(NODE)e = &(NODE); continue e = &(NODE); continue

5234/* Walk expression *E, calling EXPRFN on each expression in it.  */

5236int
5237gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
5238{
while (*e)
  {
    int walk_subtrees = 1;
    gfc_actual_arglist *a;
    gfc_ref *r;
    gfc_constructor *c;

    int result = exprfn (e, &walk_subtrees, data);
    if (result)
return result;
    if (walk_subtrees)
switch ((*e)->expr_type)
 {
 case EXPR_OP:
   WALK_SUBEXPR ((*e)->value.op.op1)do { result = gfc_expr_walker (&((*e)->value.op.op1), exprfn
, data); if (result) return result; } while (0);
   WALK_SUBEXPR_TAIL ((*e)->value.op.op2)e = &((*e)->value.op.op2); continue;
   /* No fallthru because of the tail recursion above.  */
 case EXPR_FUNCTION:
   for (a = (*e)->value.function.actual; a; a = a->next)
     WALK_SUBEXPR (a->expr)do { result = gfc_expr_walker (&(a->expr), exprfn, data
); if (result) return result; } while (0);
   break;
 case EXPR_COMPCALL:
 case EXPR_PPC:
   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);
   for (a = (*e)->value.compcall.actual; a; a = a->next)
     WALK_SUBEXPR (a->expr)do { result = gfc_expr_walker (&(a->expr), exprfn, data
); if (result) return result; } while (0);
   break;

 case EXPR_STRUCTURE:
 case EXPR_ARRAY:
   for (c = gfc_constructor_first ((*e)->value.constructor); c;
 c = gfc_constructor_next (c))
     {
if (c->iterator == NULL__null)
  WALK_SUBEXPR (c->expr)do { result = gfc_expr_walker (&(c->expr), exprfn, data
); if (result) return result; } while (0);
else
  {
    iterator_level ++;
    WALK_SUBEXPR (c->expr)do { result = gfc_expr_walker (&(c->expr), exprfn, data
); if (result) return result; } while (0);
    iterator_level --;
    WALK_SUBEXPR (c->iterator->var)do { result = gfc_expr_walker (&(c->iterator->var),
 exprfn, data); if (result) return result; } while (0);
    WALK_SUBEXPR (c->iterator->start)do { result = gfc_expr_walker (&(c->iterator->start
), exprfn, data); if (result) return result; } while (0);
    WALK_SUBEXPR (c->iterator->end)do { result = gfc_expr_walker (&(c->iterator->end),
 exprfn, data); if (result) return result; } while (0);
    WALK_SUBEXPR (c->iterator->step)do { result = gfc_expr_walker (&(c->iterator->step)
, exprfn, data); if (result) return result; } while (0);
  }
     }

   if ((*e)->expr_type != EXPR_ARRAY)
     break;

   /* Fall through to the variable case in order to walk the
      reference.  */
   gcc_fallthrough ();

 case EXPR_SUBSTRING:
 case EXPR_VARIABLE:
   for (r = (*e)->ref; r; r = r->next)
     {
gfc_array_ref *ar;
int i;

switch (r->type)
  {
  case REF_ARRAY:
    ar = &r->u.ar;
    if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
      {
	for (i=0; i< ar->dimen; i++)
	  {
	    WALK_SUBEXPR (ar->start[i])do { result = gfc_expr_walker (&(ar->start[i]), exprfn
, data); if (result) return result; } while (0);
	    WALK_SUBEXPR (ar->end[i])do { result = gfc_expr_walker (&(ar->end[i]), exprfn, data
); if (result) return result; } while (0);
	    WALK_SUBEXPR (ar->stride[i])do { result = gfc_expr_walker (&(ar->stride[i]), exprfn
, data); if (result) return result; } while (0);
	  }
      }

    break;

  case REF_SUBSTRING:
    WALK_SUBEXPR (r->u.ss.start)do { result = gfc_expr_walker (&(r->u.ss.start), exprfn
, data); if (result) return result; } while (0);
    WALK_SUBEXPR (r->u.ss.end)do { result = gfc_expr_walker (&(r->u.ss.end), exprfn,
 data); if (result) return result; } while (0);
    break;

  case REF_COMPONENT:
  case REF_INQUIRY:
    break;
  }
     }

 default:
   break;
 }
    return 0;
  }
return 0;
5333}

5335#define WALK_SUBCODE(NODE)do { result = gfc_code_walker (&(NODE), codefn, exprfn, data
); if (result) return result; } while (0) \
do								\
  {								\
    result = gfc_code_walker (&(NODE), codefn, exprfn, data);	\
    if (result)						\
return result;						\
  }								\
while (0)

5344/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
 on each expression in it.  If any of the hooks returns non-zero, that
 value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
 no subcodes or subexpressions are traversed.  */

5349int
5350gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 void *data)
5352{
for (; *c; c = &(*c)->next)
  {
    int walk_subtrees = 1;
    int result = codefn (c, &walk_subtrees, data);
    if (result)
return result;

    if (walk_subtrees)
{
 gfc_code *b;
 gfc_actual_arglist *a;
 gfc_code *co;
 gfc_association_list *alist;
 bool saved_in_omp_workshare;
 bool saved_in_omp_atomic;
 bool saved_in_where;

 /* There might be statement insertions before the current code,
    which must not affect the expression walker.  */

 co = *c;
 saved_in_omp_workshare = in_omp_workshare;
 saved_in_omp_atomic = in_omp_atomic;
 saved_in_where = in_where;

 switch (co->op)
   {

   case EXEC_BLOCK:
     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);
     if (co->ext.block.assoc)
{
  bool saved_in_assoc_list = in_assoc_list;

  in_assoc_list = true;
  for (alist = co->ext.block.assoc; alist; alist = alist->next)
    WALK_SUBEXPR (alist->target)do { result = gfc_expr_walker (&(alist->target), exprfn
, data); if (result) return result; } while (0);

  in_assoc_list = saved_in_assoc_list;
}

     break;

   case EXEC_DO:
     doloop_level ++;
     WALK_SUBEXPR (co->ext.iterator->var)do { result = gfc_expr_walker (&(co->ext.iterator->
var), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.iterator->start)do { result = gfc_expr_walker (&(co->ext.iterator->
start), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.iterator->end)do { result = gfc_expr_walker (&(co->ext.iterator->
end), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.iterator->step)do { result = gfc_expr_walker (&(co->ext.iterator->
step), exprfn, data); if (result) return result; } while (0);
     break;

   case EXEC_IF:
     if_level ++;
     break;

   case EXEC_WHERE:
     in_where = true;
     break;

   case EXEC_CALL:
   case EXEC_ASSIGN_CALL:
     for (a = co->ext.actual; a; a = a->next)
WALK_SUBEXPR (a->expr)do { result = gfc_expr_walker (&(a->expr), exprfn, data
); if (result) return result; } while (0);
     break;

   case EXEC_CALL_PPC:
     WALK_SUBEXPR (co->expr1)do { result = gfc_expr_walker (&(co->expr1), exprfn, data
); if (result) return result; } while (0);
     for (a = co->ext.actual; a; a = a->next)
WALK_SUBEXPR (a->expr)do { result = gfc_expr_walker (&(a->expr), exprfn, data
); if (result) return result; } while (0);
     break;

   case EXEC_SELECT:
     WALK_SUBEXPR (co->expr1)do { result = gfc_expr_walker (&(co->expr1), exprfn, data
); if (result) return result; } while (0);
     select_level ++;
     for (b = co->block; b; b = b->block)
{
  gfc_case *cp;
  for (cp = b->ext.block.case_list; cp; cp = cp->next)
    {
      WALK_SUBEXPR (cp->low)do { result = gfc_expr_walker (&(cp->low), exprfn, data
); if (result) return result; } while (0);
      WALK_SUBEXPR (cp->high)do { result = gfc_expr_walker (&(cp->high), exprfn, data
); if (result) return result; } while (0);
    }
  WALK_SUBCODE (b->next)do { result = gfc_code_walker (&(b->next), codefn, exprfn
, data); if (result) return result; } while (0);
}
     continue;

   case EXEC_ALLOCATE:
   case EXEC_DEALLOCATE:
     {
gfc_alloc *a;
for (a = co->ext.alloc.list; a; a = a->next)
  WALK_SUBEXPR (a->expr)do { result = gfc_expr_walker (&(a->expr), exprfn, data
); if (result) return result; } while (0);
break;
     }

   case EXEC_FORALL:
   case EXEC_DO_CONCURRENT:
     {
gfc_forall_iterator *fa;
for (fa = co->ext.forall_iterator; fa; fa = fa->next)
  {
    WALK_SUBEXPR (fa->var)do { result = gfc_expr_walker (&(fa->var), exprfn, data
); if (result) return result; } while (0);
    WALK_SUBEXPR (fa->start)do { result = gfc_expr_walker (&(fa->start), exprfn, data
); if (result) return result; } while (0);
    WALK_SUBEXPR (fa->end)do { result = gfc_expr_walker (&(fa->end), exprfn, data
); if (result) return result; } while (0);
    WALK_SUBEXPR (fa->stride)do { result = gfc_expr_walker (&(fa->stride), exprfn, data
); if (result) return result; } while (0);
  }
if (co->op == EXEC_FORALL)
  forall_level ++;
break;
     }

   case EXEC_OPEN:
     WALK_SUBEXPR (co->ext.open->unit)do { result = gfc_expr_walker (&(co->ext.open->unit
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->file)do { result = gfc_expr_walker (&(co->ext.open->file
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->status)do { result = gfc_expr_walker (&(co->ext.open->status
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->access)do { result = gfc_expr_walker (&(co->ext.open->access
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->form)do { result = gfc_expr_walker (&(co->ext.open->form
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->recl)do { result = gfc_expr_walker (&(co->ext.open->recl
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->blank)do { result = gfc_expr_walker (&(co->ext.open->blank
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->position)do { result = gfc_expr_walker (&(co->ext.open->position
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->action)do { result = gfc_expr_walker (&(co->ext.open->action
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->delim)do { result = gfc_expr_walker (&(co->ext.open->delim
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->pad)do { result = gfc_expr_walker (&(co->ext.open->pad)
, exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->iostat)do { result = gfc_expr_walker (&(co->ext.open->iostat
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->iomsg)do { result = gfc_expr_walker (&(co->ext.open->iomsg
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->convert)do { result = gfc_expr_walker (&(co->ext.open->convert
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->decimal)do { result = gfc_expr_walker (&(co->ext.open->decimal
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->encoding)do { result = gfc_expr_walker (&(co->ext.open->encoding
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->round)do { result = gfc_expr_walker (&(co->ext.open->round
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->sign)do { result = gfc_expr_walker (&(co->ext.open->sign
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->asynchronous)do { result = gfc_expr_walker (&(co->ext.open->asynchronous
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->id)do { result = gfc_expr_walker (&(co->ext.open->id),
 exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->newunit)do { result = gfc_expr_walker (&(co->ext.open->newunit
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->share)do { result = gfc_expr_walker (&(co->ext.open->share
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.open->cc)do { result = gfc_expr_walker (&(co->ext.open->cc),
 exprfn, data); if (result) return result; } while (0);
     break;

   case EXEC_CLOSE:
     WALK_SUBEXPR (co->ext.close->unit)do { result = gfc_expr_walker (&(co->ext.close->unit
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.close->status)do { result = gfc_expr_walker (&(co->ext.close->status
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.close->iostat)do { result = gfc_expr_walker (&(co->ext.close->iostat
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.close->iomsg)do { result = gfc_expr_walker (&(co->ext.close->iomsg
), exprfn, data); if (result) return result; } while (0);
     break;

   case EXEC_BACKSPACE:
   case EXEC_ENDFILE:
   case EXEC_REWIND:
   case EXEC_FLUSH:
     WALK_SUBEXPR (co->ext.filepos->unit)do { result = gfc_expr_walker (&(co->ext.filepos->unit
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.filepos->iostat)do { result = gfc_expr_walker (&(co->ext.filepos->iostat
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.filepos->iomsg)do { result = gfc_expr_walker (&(co->ext.filepos->iomsg
), exprfn, data); if (result) return result; } while (0);
     break;

   case EXEC_INQUIRE:
     WALK_SUBEXPR (co->ext.inquire->unit)do { result = gfc_expr_walker (&(co->ext.inquire->unit
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->file)do { result = gfc_expr_walker (&(co->ext.inquire->file
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->iomsg)do { result = gfc_expr_walker (&(co->ext.inquire->iomsg
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->iostat)do { result = gfc_expr_walker (&(co->ext.inquire->iostat
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->exist)do { result = gfc_expr_walker (&(co->ext.inquire->exist
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->opened)do { result = gfc_expr_walker (&(co->ext.inquire->opened
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->number)do { result = gfc_expr_walker (&(co->ext.inquire->number
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->named)do { result = gfc_expr_walker (&(co->ext.inquire->named
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->name)do { result = gfc_expr_walker (&(co->ext.inquire->name
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->access)do { result = gfc_expr_walker (&(co->ext.inquire->access
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->sequential)do { result = gfc_expr_walker (&(co->ext.inquire->sequential
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->direct)do { result = gfc_expr_walker (&(co->ext.inquire->direct
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->form)do { result = gfc_expr_walker (&(co->ext.inquire->form
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->formatted)do { result = gfc_expr_walker (&(co->ext.inquire->formatted
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->unformatted)do { result = gfc_expr_walker (&(co->ext.inquire->unformatted
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->recl)do { result = gfc_expr_walker (&(co->ext.inquire->recl
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->nextrec)do { result = gfc_expr_walker (&(co->ext.inquire->nextrec
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->blank)do { result = gfc_expr_walker (&(co->ext.inquire->blank
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->position)do { result = gfc_expr_walker (&(co->ext.inquire->position
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->action)do { result = gfc_expr_walker (&(co->ext.inquire->action
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->read)do { result = gfc_expr_walker (&(co->ext.inquire->read
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->write)do { result = gfc_expr_walker (&(co->ext.inquire->write
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->readwrite)do { result = gfc_expr_walker (&(co->ext.inquire->readwrite
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->delim)do { result = gfc_expr_walker (&(co->ext.inquire->delim
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->encoding)do { result = gfc_expr_walker (&(co->ext.inquire->encoding
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->pad)do { result = gfc_expr_walker (&(co->ext.inquire->pad
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->iolength)do { result = gfc_expr_walker (&(co->ext.inquire->iolength
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->convert)do { result = gfc_expr_walker (&(co->ext.inquire->convert
), exprfn, data); if (result) return result; } while (0);
     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);
     WALK_SUBEXPR (co->ext.inquire->asynchronous)do { result = gfc_expr_walker (&(co->ext.inquire->asynchronous
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->decimal)do { result = gfc_expr_walker (&(co->ext.inquire->decimal
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->pending)do { result = gfc_expr_walker (&(co->ext.inquire->pending
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->id)do { result = gfc_expr_walker (&(co->ext.inquire->id
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->sign)do { result = gfc_expr_walker (&(co->ext.inquire->sign
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->size)do { result = gfc_expr_walker (&(co->ext.inquire->size
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.inquire->round)do { result = gfc_expr_walker (&(co->ext.inquire->round
), exprfn, data); if (result) return result; } while (0);
     break;

   case EXEC_WAIT:
     WALK_SUBEXPR (co->ext.wait->unit)do { result = gfc_expr_walker (&(co->ext.wait->unit
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.wait->iostat)do { result = gfc_expr_walker (&(co->ext.wait->iostat
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.wait->iomsg)do { result = gfc_expr_walker (&(co->ext.wait->iomsg
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.wait->id)do { result = gfc_expr_walker (&(co->ext.wait->id),
 exprfn, data); if (result) return result; } while (0);
     break;

   case EXEC_READ:
   case EXEC_WRITE:
     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);
     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);
     WALK_SUBEXPR (co->ext.dt->rec)do { result = gfc_expr_walker (&(co->ext.dt->rec), exprfn
, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->advance)do { result = gfc_expr_walker (&(co->ext.dt->advance
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->iostat)do { result = gfc_expr_walker (&(co->ext.dt->iostat
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->size)do { result = gfc_expr_walker (&(co->ext.dt->size),
 exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->iomsg)do { result = gfc_expr_walker (&(co->ext.dt->iomsg)
, exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->id)do { result = gfc_expr_walker (&(co->ext.dt->id), exprfn
, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->pos)do { result = gfc_expr_walker (&(co->ext.dt->pos), exprfn
, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->asynchronous)do { result = gfc_expr_walker (&(co->ext.dt->asynchronous
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->blank)do { result = gfc_expr_walker (&(co->ext.dt->blank)
, exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->decimal)do { result = gfc_expr_walker (&(co->ext.dt->decimal
), exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->delim)do { result = gfc_expr_walker (&(co->ext.dt->delim)
, exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->pad)do { result = gfc_expr_walker (&(co->ext.dt->pad), exprfn
, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->round)do { result = gfc_expr_walker (&(co->ext.dt->round)
, exprfn, data); if (result) return result; } while (0);
     WALK_SUBEXPR (co->ext.dt->sign)do { result = gfc_expr_walker (&(co->ext.dt->sign),
 exprfn, data); if (result) return result; } while (0);
     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);
     break;

   case EXEC_OACC_ATOMIC:
   case EXEC_OMP_ATOMIC:
     in_omp_atomic = true;
     break;

   case EXEC_OMP_PARALLEL:
   case EXEC_OMP_PARALLEL_DO:
   case EXEC_OMP_PARALLEL_DO_SIMD:
   case EXEC_OMP_PARALLEL_LOOP:
   case EXEC_OMP_PARALLEL_MASKED:
   case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
   case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
   case EXEC_OMP_PARALLEL_MASTER:
   case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
   case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
   case EXEC_OMP_PARALLEL_SECTIONS:

     in_omp_workshare = false;

     /* This goto serves as a shortcut to avoid code
 duplication or a larger if or switch statement.  */
     goto check_omp_clauses;

   case EXEC_OMP_WORKSHARE:
   case EXEC_OMP_PARALLEL_WORKSHARE:

     in_omp_workshare = true;

     /* Fall through  */

   case EXEC_OMP_CRITICAL:
   case EXEC_OMP_DISTRIBUTE:
   case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
   case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
   case EXEC_OMP_DISTRIBUTE_SIMD:
   case EXEC_OMP_DO:
   case EXEC_OMP_DO_SIMD:
   case EXEC_OMP_LOOP:
   case EXEC_OMP_ORDERED:
   case EXEC_OMP_SECTIONS:
   case EXEC_OMP_SINGLE:
   case EXEC_OMP_END_SINGLE:
   case EXEC_OMP_SIMD:
   case EXEC_OMP_TASKLOOP:
   case EXEC_OMP_TASKLOOP_SIMD:
   case EXEC_OMP_TARGET:
   case EXEC_OMP_TARGET_DATA:
   case EXEC_OMP_TARGET_ENTER_DATA:
   case EXEC_OMP_TARGET_EXIT_DATA:
   case EXEC_OMP_TARGET_PARALLEL:
   case EXEC_OMP_TARGET_PARALLEL_DO:
   case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
   case EXEC_OMP_TARGET_PARALLEL_LOOP:
   case EXEC_OMP_TARGET_SIMD:
   case EXEC_OMP_TARGET_TEAMS:
   case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
   case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
   case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
   case EXEC_OMP_TARGET_TEAMS_LOOP:
   case EXEC_OMP_TARGET_UPDATE:
   case EXEC_OMP_TASK:
   case EXEC_OMP_TEAMS:
   case EXEC_OMP_TEAMS_DISTRIBUTE:
   case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
   case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
   case EXEC_OMP_TEAMS_LOOP:

     /* Come to this label only from the
 EXEC_OMP_PARALLEL_* cases above.  */

   check_omp_clauses:

     if (co->ext.omp_clauses)
{
  gfc_omp_namelist *n;
  static int list_types[]
    = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
	OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
  size_t idx;
  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);
  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);
  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);
  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);
  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);
  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);
  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);
  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);
  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
);
  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);
  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);
  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);
  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);
  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);
  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);
  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
);
  for (idx = 0; idx < OMP_IF_LAST; idx++)
    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);
  for (idx = 0; idx < ARRAY_SIZE (list_types)(sizeof (list_types) / sizeof ((list_types)[0])); idx++)
    for (n = co->ext.omp_clauses->lists[list_types[idx]];
	 n; n = n->next)
      WALK_SUBEXPR (n->expr)do { result = gfc_expr_walker (&(n->expr), exprfn, data
); if (result) return result; } while (0);
}
     break;
   default:
     break;
   }

 WALK_SUBEXPR (co->expr1)do { result = gfc_expr_walker (&(co->expr1), exprfn, data
); if (result) return result; } while (0);
 WALK_SUBEXPR (co->expr2)do { result = gfc_expr_walker (&(co->expr2), exprfn, data
); if (result) return result; } while (0);
 WALK_SUBEXPR (co->expr3)do { result = gfc_expr_walker (&(co->expr3), exprfn, data
); if (result) return result; } while (0);
 WALK_SUBEXPR (co->expr4)do { result = gfc_expr_walker (&(co->expr4), exprfn, data
); if (result) return result; } while (0);
 for (b = co->block; b; b = b->block)
   {
     WALK_SUBEXPR (b->expr1)do { result = gfc_expr_walker (&(b->expr1), exprfn, data
); if (result) return result; } while (0);
     WALK_SUBEXPR (b->expr2)do { result = gfc_expr_walker (&(b->expr2), exprfn, data
); if (result) return result; } while (0);
     WALK_SUBCODE (b->next)do { result = gfc_code_walker (&(b->next), codefn, exprfn
, data); if (result) return result; } while (0);
   }

 if (co->op == EXEC_FORALL)
   forall_level --;

 if (co->op == EXEC_DO)
   doloop_level --;

 if (co->op == EXEC_IF)
   if_level --;

 if (co->op == EXEC_SELECT)
   select_level --;

 in_omp_workshare = saved_in_omp_workshare;
 in_omp_atomic = saved_in_omp_atomic;
 in_where = saved_in_where;
}
  }
return 0;
5711}

5713/* As a post-resolution step, check that all global symbols which are
 not declared in the source file match in their call signatures.
 We do this by looping over the code (and expressions). The first call
 we happen to find is assumed to be canonical.  */


5719/* Common tests for argument checking for both functions and subroutines.  */

5721static int
5722check_externals_procedure (gfc_symbol *sym, locus *loc,
	   gfc_actual_arglist *actual)
5724{
gfc_gsymbol *gsym;
gfc_symbol *def_sym = NULL__null;

if (sym == NULL__null || sym->attr.is_bind_c)
  return 0;

if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
  return 0;

if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
  return 0;

gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
if (gsym == NULL__null)
  return 0;

if (gsym->ns)
  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);

if (def_sym)
  {
    gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
    return 0;
  }

/* First time we have seen this procedure called. Let's create an
   "interface" from the call and put it into a new namespace.  */
gfc_namespace *save_ns;
gfc_symbol *new_sym;

gsym->where = *loc;
save_ns = gfc_current_ns;
gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
gsym->ns->proc_name = sym;

gfc_get_symbol (sym->name, gsym->ns, &new_sym);
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));
new_sym->attr = sym->attr;
new_sym->attr.if_source = IFSRC_DECL;
gfc_current_ns = gsym->ns;

gfc_get_formal_from_actual_arglist (new_sym, actual);
new_sym->declared_at = *loc;
gfc_current_ns = save_ns;

return 0;

5772}

5774/* Callback for calls of external routines.  */

5776static int
5777check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
      void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
5779{
gfc_code *co = *c;
gfc_symbol *sym;
locus *loc;
gfc_actual_arglist *actual;

if (co->op != EXEC_CALL)
  return 0;

sym = co->resolved_sym;
loc = &co->loc;
actual = co->ext.actual;

return check_externals_procedure (sym, loc, actual);

5794}

5796/* Callback for external functions.  */

5798static int
5799check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
      void *data ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
5801{
gfc_expr *e = *ep;
gfc_symbol *sym;
locus *loc;
gfc_actual_arglist *actual;

if (e->expr_type != EXPR_FUNCTION)
  return 0;

sym = e->value.function.esym;
if (sym == NULL__null)
  return 0;

loc = &e->where;
actual = e->value.function.actual;

return check_externals_procedure (sym, loc, actual);
5818}

5820/* Function to check if any interface clashes with a global
 identifier, to be invoked via gfc_traverse_ns.  */

5823static void
5824check_against_globals (gfc_symbol *sym)
5825{
gfc_gsymbol *gsym;
gfc_symbol *def_sym = NULL__null;
const char *sym_name;
char buf  [200];

if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE
    || sym->attr.generic || sym->error)
  return;

if (sym->binding_label)
  sym_name = sym->binding_label;
else
  sym_name = sym->name;

gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name);
if (gsym && gsym->ns)
  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);

if (!def_sym || def_sym->error || def_sym->attr.generic)
  return;

buf[0] = 0;
gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf),
	  NULL__null, NULL__null, NULL__null);
if (buf[0] != 0)
  {
    gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at,
   &sym->declared_at);
    sym->error = 1;
    def_sym->error = 1;
  }

5858}

5860/* Do the code-walkling part for gfc_check_externals.  */

5862static void
5863gfc_check_externals0 (gfc_namespace *ns)
5864{
gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL__null);

for (ns = ns->contained; ns; ns = ns->sibling)
  {
    if (ns->code == NULL__null || ns->code->op != EXEC_BLOCK)
gfc_check_externals0 (ns);
  }

5873}

5875/* Called routine.  */

5877void
5878gfc_check_externals (gfc_namespace *ns)
5879{
gfc_clear_error ();

/* Turn errors into warnings if the user indicated this.  */

if (!pedanticglobal_options.x_pedantic && flag_allow_argument_mismatchglobal_options.x_flag_allow_argument_mismatch)
  gfc_errors_to_warnings (true);

gfc_check_externals0 (ns);
gfc_traverse_ns (ns, check_against_globals);

gfc_errors_to_warnings (false);
5891}

5893/* Callback function. If there is a call to a subroutine which is
 neither pure nor implicit_pure, unset the implicit_pure flag for
 the caller and return -1.  */

5897static int
5898implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
    void *sym_data)
5900{
gfc_code *co = *c;
gfc_symbol *caller_sym;
symbol_attribute *a;

if (co->op != EXEC_CALL || co->resolved_sym == NULL__null)
  return 0;

a = &co->resolved_sym->attr;
if (a->intrinsic || a->pure || a->implicit_pure)
  return 0;

caller_sym = (gfc_symbol *) sym_data;
gfc_unset_implicit_pure (caller_sym);
return 1;
5915}

5917/* Callback function. If there is a call to a function which is
 neither pure nor implicit_pure, unset the implicit_pure flag for
 the caller and return 1.  */

5921static int
5922implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED__attribute__ ((__unused__)), void *sym_data)
5923{
gfc_expr *expr = *e;
gfc_symbol *caller_sym;
gfc_symbol *sym;
symbol_attribute *a;

if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
  return 0;

sym = expr->symtree->n.sym;
a = &sym->attr;
if (a->pure || a->implicit_pure)
  return 0;

caller_sym = (gfc_symbol *) sym_data;
gfc_unset_implicit_pure (caller_sym);
return 1;
5940}

5942/* Go through all procedures in the namespace and unset the
 implicit_pure attribute for any procedure that calls something not
 pure or implicit pure.  */

5946bool
5947gfc_fix_implicit_pure (gfc_namespace *ns)
5948{
bool changed = false;
gfc_symbol *proc = ns->proc_name;

if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
    && ns->code
    && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr,
	  (void *) ns->proc_name))
  changed = true;

for (ns = ns->contained; ns; ns = ns->sibling)
  {
    if (gfc_fix_implicit_pure (ns))
changed = true;
  }

return changed;
5965}