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

Bug Summary

File:	build/gcc/fortran/resolve.cc
Warning:	line 3337, column 2 Forming reference to null pointer
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 resolve.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-Xpc6iL.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc
1/* Perform type resolution on the various structures.
 Copyright (C) 2001-2023 Free Software Foundation, Inc.
 Contributed by Andy Vaught

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 "bitmap.h"
26#include "gfortran.h"
27#include "arith.h"  /* For gfc_compare_expr().  */
28#include "dependency.h"
29#include "data.h"
30#include "target-memory.h" /* for gfc_simplify_transfer */
31#include "constructor.h"

33/* Types used in equivalence statements.  */

35enum seq_type
36{
SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38};

40/* Stack to keep track of the nesting of blocks as we move through the
 code.  See resolve_branch() and gfc_resolve_code().  */

43typedef struct code_stack
44{
struct gfc_code *head, *current;
struct code_stack *prev;

/* This bitmap keeps track of the targets valid for a branch from
   inside this block except for END {IF|SELECT}s of enclosing
   blocks.  */
bitmap reachable_labels;
52}
53code_stack;

55static code_stack *cs_base = NULL__null;


58/* Nonzero if we're inside a FORALL or DO CONCURRENT block.  */

60static int forall_flag;
61int gfc_do_concurrent_flag;

63/* True when we are resolving an expression that is an actual argument to
 a procedure.  */
65static bool actual_arg = false;
66/* True when we are resolving an expression that is the first actual argument
 to a procedure.  */
68static bool first_actual_arg = false;


71/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */

73static int omp_workshare_flag;

75/* True if we are processing a formal arglist. The corresponding function
 resets the flag each time that it is read.  */
77static bool formal_arg_flag = false;

79/* True if we are resolving a specification expression.  */
80static bool specification_expr = false;

82/* The id of the last entry seen.  */
83static int current_entry_id;

85/* We use bitmaps to determine if a branch target is valid.  */
86static bitmap_obstack labels_obstack;

88/* True when simplifying a EXPR_VARIABLE argument to an inquiry function.  */
89static bool inquiry_argument = false;


92bool
93gfc_is_formal_arg (void)
94{
return formal_arg_flag;
96}

98/* Is the symbol host associated?  */
99static bool
100is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
101{
for (ns = ns->parent; ns; ns = ns->parent)
  {
    if (sym->ns == ns)
return true;
  }

return false;
109}

111/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
 an ABSTRACT derived-type.  If where is not NULL, an error message with that
 locus is printed, optionally using name.  */

115static bool
116resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
117{
if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
  {
    if (where)
{
 if (name)
   gfc_error ("%qs at %L is of the ABSTRACT type %qs",
       name, where, ts->u.derived->name);
 else
   gfc_error ("ABSTRACT type %qs used at %L",
       ts->u.derived->name, where);
}

    return false;
  }

return true;
134}


137static bool
138check_proc_interface (gfc_symbol *ifc, locus *where)
139{
/* Several checks for F08:C1216.  */
if (ifc->attr.procedure)
  {
    gfc_error ("Interface %qs at %L is declared "
 "in a later PROCEDURE statement", ifc->name, where);
    return false;
  }
if (ifc->generic)
  {
    /* For generic interfaces, check if there is
a specific procedure with the same name.  */
    gfc_interface *gen = ifc->generic;
    while (gen && strcmp (gen->sym->name, ifc->name) != 0)
gen = gen->next;
    if (!gen)
{
 gfc_error ("Interface %qs at %L may not be generic",
     ifc->name, where);
 return false;
}
  }
if (ifc->attr.proc == PROC_ST_FUNCTION)
  {
    gfc_error ("Interface %qs at %L may not be a statement function",
 ifc->name, where);
    return false;
  }
if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
    || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
  ifc->attr.intrinsic = 1;
if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
  {
    gfc_error ("Intrinsic procedure %qs not allowed in "
 "PROCEDURE statement at %L", ifc->name, where);
    return false;
  }
if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
  {
    gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
    return false;
  }
return true;
182}


185static void resolve_symbol (gfc_symbol *sym);


188/* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */

190static bool
191resolve_procedure_interface (gfc_symbol *sym)
192{
gfc_symbol *ifc = sym->ts.interface;

if (!ifc)
  return true;

if (ifc == sym)
  {
    gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
 sym->name, &sym->declared_at);
    return false;
  }
if (!check_proc_interface (ifc, &sym->declared_at))
  return false;

if (ifc->attr.if_source || ifc->attr.intrinsic)
  {
    /* Resolve interface and copy attributes.  */
    resolve_symbol (ifc);
    if (ifc->attr.intrinsic)
gfc_resolve_intrinsic (ifc, &ifc->declared_at);

    if (ifc->result)
{
 sym->ts = ifc->result->ts;
 sym->attr.allocatable = ifc->result->attr.allocatable;
 sym->attr.pointer = ifc->result->attr.pointer;
 sym->attr.dimension = ifc->result->attr.dimension;
 sym->attr.class_ok = ifc->result->attr.class_ok;
 sym->as = gfc_copy_array_spec (ifc->result->as);
 sym->result = sym;
}
    else
{
 sym->ts = ifc->ts;
 sym->attr.allocatable = ifc->attr.allocatable;
 sym->attr.pointer = ifc->attr.pointer;
 sym->attr.dimension = ifc->attr.dimension;
 sym->attr.class_ok = ifc->attr.class_ok;
 sym->as = gfc_copy_array_spec (ifc->as);
}
    sym->ts.interface = ifc;
    sym->attr.function = ifc->attr.function;
    sym->attr.subroutine = ifc->attr.subroutine;

    sym->attr.pure = ifc->attr.pure;
    sym->attr.elemental = ifc->attr.elemental;
    sym->attr.contiguous = ifc->attr.contiguous;
    sym->attr.recursive = ifc->attr.recursive;
    sym->attr.always_explicit = ifc->attr.always_explicit;
    sym->attr.ext_attr |= ifc->attr.ext_attr;
    sym->attr.is_bind_c = ifc->attr.is_bind_c;
    /* Copy char length.  */
    if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
     && !gfc_resolve_expr (sym->ts.u.cl->length))
   return false;
}
  }

return true;
255}


258/* Resolve types of formal argument lists.  These have to be done early so that
 the formal argument lists of module procedures can be copied to the
 containing module before the individual procedures are resolved
 individually.  We also resolve argument lists of procedures in interface
 blocks because they are self-contained scoping units.

 Since a dummy argument cannot be a non-dummy procedure, the only
 resort left for untyped names are the IMPLICIT types.  */

267void
268gfc_resolve_formal_arglist (gfc_symbol *proc)
269{
gfc_formal_arglist *f;
gfc_symbol *sym;
bool saved_specification_expr;
int i;

if (proc->result != NULL__null)
  sym = proc->result;
else
  sym = proc;

if (gfc_elemental (proc)
    || sym->attr.pointer || sym->attr.allocatable
    || (sym->as && sym->as->rank != 0))
  {
    proc->attr.always_explicit = 1;
    sym->attr.always_explicit = 1;
  }

formal_arg_flag = true;

for (f = proc->formal; f; f = f->next)
  {
    gfc_array_spec *as;

    sym = f->sym;

    if (sym == NULL__null)
{
 /* Alternate return placeholder.  */
 if (gfc_elemental (proc))
   gfc_error ("Alternate return specifier in elemental subroutine "
       "%qs at %L is not allowed", proc->name,
       &proc->declared_at);
 if (proc->attr.function)
   gfc_error ("Alternate return specifier in function "
       "%qs at %L is not allowed", proc->name,
       &proc->declared_at);
 continue;
}
    else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
      && !resolve_procedure_interface (sym))
return;

    if (strcmp (proc->name, sym->name) == 0)
      {
        gfc_error ("Self-referential argument "
                   "%qs at %L is not allowed", sym->name,
                   &proc->declared_at);
        return;
      }

    if (sym->attr.if_source != IFSRC_UNKNOWN)
gfc_resolve_formal_arglist (sym);

    if (sym->attr.subroutine || sym->attr.external)
{
 if (sym->attr.flavor == FL_UNKNOWN)
   gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
}
    else
{
 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
     && (!sym->attr.function || sym->result == sym))
   gfc_set_default_type (sym, 1, sym->ns);
}

    as = sym->ts.type == BT_CLASS && sym->attr.class_ok
  ? CLASS_DATA (sym)sym->ts.u.derived->components->as : sym->as;

    saved_specification_expr = specification_expr;
    specification_expr = true;
    gfc_resolve_array_spec (as, 0);
    specification_expr = saved_specification_expr;

    /* We can't tell if an array with dimension (:) is assumed or deferred
shape until we know if it has the pointer or allocatable attributes.
    */
    if (as && as->rank > 0 && as->type == AS_DEFERRED
 && ((sym->ts.type != BT_CLASS
      && !(sym->attr.pointer || sym->attr.allocatable))
            || (sym->ts.type == BT_CLASS
  && !(CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer
       || CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable)))
 && sym->attr.flavor != FL_PROCEDURE)
{
 as->type = AS_ASSUMED_SHAPE;
 for (i = 0; i < as->rank; i++)
   as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 1);
}

    if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
 || (as && as->type == AS_ASSUMED_RANK)
 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
     && (CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer
  || CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable
  || CLASS_DATA (sym)sym->ts.u.derived->components->attr.target))
 || sym->attr.optional)
{
 proc->attr.always_explicit = 1;
 if (proc->result)
   proc->result->attr.always_explicit = 1;
}

    /* If the flavor is unknown at this point, it has to be a variable.
A procedure specification would have already set the type.  */

    if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);

    if (gfc_pure (proc))
{
 if (sym->attr.flavor == FL_PROCEDURE)
   {
     /* F08:C1279.  */
     if (!gfc_pure (sym))
{
  gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
	    "also be PURE", sym->name, &sym->declared_at);
  continue;
}
   }
 else if (!sym->attr.pointer)
   {
     if (proc->attr.function && sym->attr.intent != INTENT_IN)
{
  if (sym->attr.value)
    gfc_notify_std (GFC_STD_F2008(1<<7), "Argument %qs"
		    " of pure function %qs at %L with VALUE "
		    "attribute but without INTENT(IN)",
		    sym->name, proc->name, &sym->declared_at);
  else
    gfc_error ("Argument %qs of pure function %qs at %L must "
	       "be INTENT(IN) or VALUE", sym->name, proc->name,
	       &sym->declared_at);
}

     if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
{
  if (sym->attr.value)
    gfc_notify_std (GFC_STD_F2008(1<<7), "Argument %qs"
		    " of pure subroutine %qs at %L with VALUE "
		    "attribute but without INTENT", sym->name,
		    proc->name, &sym->declared_at);
  else
    gfc_error ("Argument %qs of pure subroutine %qs at %L "
	       "must have its INTENT specified or have the "
	       "VALUE attribute", sym->name, proc->name,
	       &sym->declared_at);
}
   }

 /* F08:C1278a.  */
 if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
   {
     gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
	 " may not be polymorphic", sym->name, proc->name,
	 &sym->declared_at);
     continue;
   }
}

    if (proc->attr.implicit_pure)
{
 if (sym->attr.flavor == FL_PROCEDURE)
   {
     if (!gfc_pure (sym))
proc->attr.implicit_pure = 0;
   }
 else if (!sym->attr.pointer)
   {
     if (proc->attr.function && sym->attr.intent != INTENT_IN
  && !sym->value)
proc->attr.implicit_pure = 0;

     if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
  && !sym->value)
proc->attr.implicit_pure = 0;
   }
}

    if (gfc_elemental (proc))
{
 /* F08:C1289.  */
 if (sym->attr.codimension
     || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
  && CLASS_DATA (sym)sym->ts.u.derived->components->attr.codimension))
   {
     gfc_error ("Coarray dummy argument %qs at %L to elemental "
	 "procedure", sym->name, &sym->declared_at);
     continue;
   }

 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
	  && CLASS_DATA (sym)sym->ts.u.derived->components->as))
   {
     gfc_error ("Argument %qs of elemental procedure at %L must "
	 "be scalar", sym->name, &sym->declared_at);
     continue;
   }

 if (sym->attr.allocatable
     || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
  && CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable))
   {
     gfc_error ("Argument %qs of elemental procedure at %L cannot "
	 "have the ALLOCATABLE attribute", sym->name,
	 &sym->declared_at);
     continue;
   }

 if (sym->attr.pointer
     || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
  && CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer))
   {
     gfc_error ("Argument %qs of elemental procedure at %L cannot "
	 "have the POINTER attribute", sym->name,
	 &sym->declared_at);
     continue;
   }

 if (sym->attr.flavor == FL_PROCEDURE)
   {
     gfc_error ("Dummy procedure %qs not allowed in elemental "
	 "procedure %qs at %L", sym->name, proc->name,
	 &sym->declared_at);
     continue;
   }

 /* Fortran 2008 Corrigendum 1, C1290a.  */
 if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
   {
     gfc_error ("Argument %qs of elemental procedure %qs at %L must "
	 "have its INTENT specified or have the VALUE "
	 "attribute", sym->name, proc->name,
	 &sym->declared_at);
     continue;
   }
}

    /* Each dummy shall be specified to be scalar.  */
    if (proc->attr.proc == PROC_ST_FUNCTION)
{
 if (sym->as != NULL__null)
   {
     /* F03:C1263 (R1238) The function-name and each dummy-arg-name
 shall be specified, explicitly or implicitly, to be scalar.  */
     gfc_error ("Argument %qs of statement function %qs at %L "
	 "must be scalar", sym->name, proc->name,
	 &proc->declared_at);
     continue;
   }

 if (sym->ts.type == BT_CHARACTER)
   {
     gfc_charlen *cl = sym->ts.u.cl;
     if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
  gfc_error ("Character-valued argument %qs of statement "
	     "function at %L must have constant length",
	     sym->name, &sym->declared_at);
  continue;
}
   }
}
  }
formal_arg_flag = false;
537}


540/* Work function called when searching for symbols that have argument lists
 associated with them.  */

543static void
544find_arglists (gfc_symbol *sym)
545{
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
    || gfc_fl_struct (sym->attr.flavor)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
 == FL_UNION || (sym->attr.flavor) == FL_STRUCT) || sym->attr.intrinsic)
  return;

gfc_resolve_formal_arglist (sym);
551}


554/* Given a namespace, resolve all formal argument lists within the namespace.
*/

557static void
558resolve_formal_arglists (gfc_namespace *ns)
559{
if (ns == NULL__null)
  return;

gfc_traverse_ns (ns, find_arglists);
564}


567static void
568resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
569{
bool t;

if (sym && sym->attr.flavor == FL_PROCEDURE
    && sym->ns->parent
    && sym->ns->parent->proc_name
    && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
    && !strcmp (sym->name, sym->ns->parent->proc_name->name))
  gfc_error ("Contained procedure %qs at %L has the same name as its "
      "encompassing procedure", sym->name, &sym->declared_at);

/* If this namespace is not a function or an entry master function,
   ignore it.  */
if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
    || sym->attr.entry_master)
  return;

if (!sym->result)
  return;

/* Try to find out of what the return type is.  */
if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL__null)
  {
    t = gfc_set_default_type (sym->result, 0, ns);

    if (!t && !sym->result->attr.untyped)
{
 if (sym->result == sym)
   gfc_error ("Contained function %qs at %L has no IMPLICIT type",
       sym->name, &sym->declared_at);
 else if (!sym->result->attr.proc_pointer)
   gfc_error ("Result %qs of contained function %qs at %L has "
       "no IMPLICIT type", sym->result->name, sym->name,
       &sym->result->declared_at);
 sym->result->attr.untyped = 1;
}
  }

/* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
   type, lists the only ways a character length value of * can be used:
   dummy arguments of procedures, named constants, function results and
   in allocate statements if the allocate_object is an assumed length dummy
   in external functions.  Internal function results and results of module
   procedures are not on this list, ergo, not permitted.  */

if (sym->result->ts.type == BT_CHARACTER)
  {
    gfc_charlen *cl = sym->result->ts.u.cl;
    if ((!cl || !cl->length) && !sym->result->ts.deferred)
{
 /* See if this is a module-procedure and adapt error message
    accordingly.  */
 bool module_proc;
 gcc_assert (ns->parent && ns->parent->proc_name)((void)(!(ns->parent && ns->parent->proc_name
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 622, __FUNCTION__), 0 : 0));
 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);

 gfc_error (module_proc
     ? G_("Character-valued module procedure %qs at %L""Character-valued module procedure %qs at %L" " must not be assumed length"
	  " must not be assumed length")"Character-valued module procedure %qs at %L" " must not be assumed length"
     : G_("Character-valued internal function %qs at %L""Character-valued internal function %qs at %L" " must not be assumed length"
	  " must not be assumed length")"Character-valued internal function %qs at %L" " must not be assumed length",
     sym->name, &sym->declared_at);
}
  }
633}


636/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
 introduce duplicates.  */

639static void
640merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
641{
gfc_formal_arglist *f, *new_arglist;
gfc_symbol *new_sym;

for (; new_args != NULL__null; new_args = new_args->next)
  {
    new_sym = new_args->sym;
    /* See if this arg is already in the formal argument list.  */
    for (f = proc->formal; f; f = f->next)
{
 if (new_sym == f->sym)
   break;
}

    if (f)
continue;

    /* Add a new argument.  Argument order is not important.  */
    new_arglist = gfc_get_formal_arglist ()((gfc_formal_arglist *) xcalloc (1, sizeof (gfc_formal_arglist
)));
    new_arglist->sym = new_sym;
    new_arglist->next = proc->formal;
    proc->formal  = new_arglist;
  }
664}


667/* Flag the arguments that are not present in all entries.  */

669static void
670check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
671{
gfc_formal_arglist *f, *head;
head = new_args;

for (f = proc->formal; f; f = f->next)
  {
    if (f->sym == NULL__null)
continue;

    for (new_args = head; new_args; new_args = new_args->next)
{
 if (new_args->sym == f->sym)
   break;
}

    if (new_args)
continue;

    f->sym->attr.not_always_present = 1;
  }
691}


694/* Resolve alternate entry points.  If a symbol has multiple entry points we
 create a new master symbol for the main routine, and turn the existing
 symbol into an entry point.  */

698static void
699resolve_entries (gfc_namespace *ns)
700{
gfc_namespace *old_ns;
gfc_code *c;
gfc_symbol *proc;
gfc_entry_list *el;
char name[GFC_MAX_SYMBOL_LEN63 + 1];
static int master_count = 0;

if (ns->proc_name == NULL__null)
  return;

/* No need to do anything if this procedure doesn't have alternate entry
   points.  */
if (!ns->entries)
  return;

/* We may already have resolved alternate entry points.  */
if (ns->proc_name->attr.entry_master)
  return;

/* If this isn't a procedure something has gone horribly wrong.  */
gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE)((void)(!(ns->proc_name->attr.flavor == FL_PROCEDURE) ?
 fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 721, __FUNCTION__), 0 : 0));

/* Remember the current namespace.  */
old_ns = gfc_current_ns;

gfc_current_ns = ns;

/* Add the main entry point to the list of entry points.  */
el = gfc_get_entry_list ()((gfc_entry_list *) xcalloc (1, sizeof (gfc_entry_list)));
el->sym = ns->proc_name;
el->id = 0;
el->next = ns->entries;
ns->entries = el;
ns->proc_name->attr.entry = 1;

/* If it is a module function, it needs to be in the right namespace
   so that gfc_get_fake_result_decl can gather up the results. The
   need for this arose in get_proc_name, where these beasts were
   left in their own namespace, to keep prior references linked to
   the entry declaration.*/
if (ns->proc_name->attr.function
    && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
  el->sym->ns = ns;

/* Do the same for entries where the master is not a module
   procedure.  These are retained in the module namespace because
   of the module procedure declaration.  */
for (el = el->next; el; el = el->next)
  if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
 && el->sym->attr.mod_proc)
    el->sym->ns = ns;
el = ns->entries;

/* Add an entry statement for it.  */
c = gfc_get_code (EXEC_ENTRY);
c->ext.entry = el;
c->next = ns->code;
ns->code = c;

/* Create a new symbol for the master function.  */
/* Give the internal function a unique name (within this file).
   Also include the function name so the user has some hope of figuring
   out what is going on.  */
snprintf (name, GFC_MAX_SYMBOL_LEN63, "master.%d.%s",
   master_count++, ns->proc_name->name);
gfc_get_ha_symbol (name, &proc);
gcc_assert (proc != NULL)((void)(!(proc != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 767, __FUNCTION__), 0 : 0));

gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL__null);
if (ns->proc_name->attr.subroutine)
  gfc_add_subroutine (&proc->attr, proc->name, NULL__null);
else
  {
    gfc_symbol *sym;
    gfc_typespec *ts, *fts;
    gfc_array_spec *as, *fas;
    gfc_add_function (&proc->attr, proc->name, NULL__null);
    proc->result = proc;
    fas = ns->entries->sym->as;
    fas = fas ? fas : ns->entries->sym->result->as;
    fts = &ns->entries->sym->result->ts;
    if (fts->type == BT_UNKNOWN)
fts = gfc_get_default_type (ns->entries->sym->result->name, NULL__null);
    for (el = ns->entries->next; el; el = el->next)
{
 ts = &el->sym->result->ts;
 as = el->sym->as;
 as = as ? as : el->sym->result->as;
 if (ts->type == BT_UNKNOWN)
   ts = gfc_get_default_type (el->sym->result->name, NULL__null);

 if (! gfc_compare_types (ts, fts)
     || (el->sym->result->attr.dimension
  != ns->entries->sym->result->attr.dimension)
     || (el->sym->result->attr.pointer
  != ns->entries->sym->result->attr.pointer))
   break;
 else if (as && fas && ns->entries->sym->result != el->sym->result
      && gfc_compare_array_spec (as, fas) == 0)
   gfc_error ("Function %s at %L has entries with mismatched "
       "array specifications", ns->entries->sym->name,
       &ns->entries->sym->declared_at);
 /* The characteristics need to match and thus both need to have
    the same string length, i.e. both len=*, or both len=4.
    Having both len=<variable> is also possible, but difficult to
    check at compile time.  */
 else if (ts->type == BT_CHARACTER
   && (el->sym->result->attr.allocatable
       != ns->entries->sym->result->attr.allocatable))
   {
     gfc_error ("Function %s at %L has entry %s with mismatched "
	 "characteristics", ns->entries->sym->name,
	 &ns->entries->sym->declared_at, el->sym->name);
     goto cleanup;
   }
 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
   && (((ts->u.cl->length && !fts->u.cl->length)
	||(!ts->u.cl->length && fts->u.cl->length))
       || (ts->u.cl->length
	   && ts->u.cl->length->expr_type
	      != fts->u.cl->length->expr_type)
       || (ts->u.cl->length
	   && ts->u.cl->length->expr_type == EXPR_CONSTANT
           && mpz_cmp__gmpz_cmp (ts->u.cl->length->value.integer,
		       fts->u.cl->length->value.integer) != 0)))
   gfc_notify_std (GFC_STD_GNU(1<<5), "Function %s at %L with "
	    "entries returning variables of different "
	    "string lengths", ns->entries->sym->name,
	    &ns->entries->sym->declared_at);
}

    if (el == NULL__null)
{
 sym = ns->entries->sym->result;
 /* All result types the same.  */
 proc->ts = *fts;
 if (sym->attr.dimension)
   gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL__null);
 if (sym->attr.pointer)
   gfc_add_pointer (&proc->attr, NULL__null);
}
    else
{
 /* Otherwise the result will be passed through a union by
    reference.  */
 proc->attr.mixed_entry_master = 1;
 for (el = ns->entries; el; el = el->next)
   {
     sym = el->sym->result;
     if (sym->attr.dimension)
{
  if (el == ns->entries)
    gfc_error ("FUNCTION result %s cannot be an array in "
	       "FUNCTION %s at %L", sym->name,
	       ns->entries->sym->name, &sym->declared_at);
  else
    gfc_error ("ENTRY result %s cannot be an array in "
	       "FUNCTION %s at %L", sym->name,
	       ns->entries->sym->name, &sym->declared_at);
}
     else if (sym->attr.pointer)
{
  if (el == ns->entries)
    gfc_error ("FUNCTION result %s cannot be a POINTER in "
	       "FUNCTION %s at %L", sym->name,
	       ns->entries->sym->name, &sym->declared_at);
  else
    gfc_error ("ENTRY result %s cannot be a POINTER in "
	       "FUNCTION %s at %L", sym->name,
	       ns->entries->sym->name, &sym->declared_at);
}
     else
{
  ts = &sym->ts;
  if (ts->type == BT_UNKNOWN)
    ts = gfc_get_default_type (sym->name, NULL__null);
  switch (ts->type)
    {
    case BT_INTEGER:
      if (ts->kind == gfc_default_integer_kind)
	sym = NULL__null;
      break;
    case BT_REAL:
      if (ts->kind == gfc_default_real_kind
	  || ts->kind == gfc_default_double_kind)
	sym = NULL__null;
      break;
    case BT_COMPLEX:
      if (ts->kind == gfc_default_complex_kind)
	sym = NULL__null;
      break;
    case BT_LOGICAL:
      if (ts->kind == gfc_default_logical_kind)
	sym = NULL__null;
      break;
    case BT_UNKNOWN:
      /* We will issue error elsewhere.  */
      sym = NULL__null;
      break;
    default:
      break;
    }
  if (sym)
    {
      if (el == ns->entries)
	gfc_error ("FUNCTION result %s cannot be of type %s "
		   "in FUNCTION %s at %L", sym->name,
		   gfc_typename (ts), ns->entries->sym->name,
		   &sym->declared_at);
      else
	gfc_error ("ENTRY result %s cannot be of type %s "
		   "in FUNCTION %s at %L", sym->name,
		   gfc_typename (ts), ns->entries->sym->name,
		   &sym->declared_at);
    }
}
   }
}
  }

921cleanup:
proc->attr.access = ACCESS_PRIVATE;
proc->attr.entry_master = 1;

/* Merge all the entry point arguments.  */
for (el = ns->entries; el; el = el->next)
  merge_argument_lists (proc, el->sym->formal);

/* Check the master formal arguments for any that are not
   present in all entry points.  */
for (el = ns->entries; el; el = el->next)
  check_argument_lists (proc, el->sym->formal);

/* Use the master function for the function body.  */
ns->proc_name = proc;

/* Finalize the new symbols.  */
gfc_commit_symbols ();

/* Restore the original namespace.  */
gfc_current_ns = old_ns;
942}


945/* Resolve common variables.  */
946static void
947resolve_common_vars (gfc_common_head *common_block, bool named_common)
948{
gfc_symbol *csym = common_block->head;
gfc_gsymbol *gsym;

for (; csym; csym = csym->common_next)
  {
    gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
    if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
{
 if (csym->common_block)
   gfc_error_now ("Global entity %qs at %L cannot appear in a "
	   "COMMON block at %L", gsym->name,
	   &gsym->where, &csym->common_block->where);
 else
   gfc_error_now ("Global entity %qs at %L cannot appear in a "
	   "COMMON block", gsym->name, &gsym->where);
}

    /* gfc_add_in_common may have been called before, but the reported errors
have been ignored to continue parsing.
We do the checks again here.  */
    if (!csym->attr.use_assoc)
{
 gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
 gfc_notify_std (GFC_STD_F2018_OBS(1<<10), "COMMON block at %L",
	  &common_block->where);
}

    if (csym->value || csym->attr.data)
{
 if (!csym->ns->is_block_data)
   gfc_notify_std (GFC_STD_GNU(1<<5), "Variable %qs at %L is in COMMON "
	    "but only in BLOCK DATA initialization is "
	    "allowed", csym->name, &csym->declared_at);
 else if (!named_common)
   gfc_notify_std (GFC_STD_GNU(1<<5), "Initialized variable %qs at %L is "
	    "in a blank COMMON but initialization is only "
	    "allowed in named common blocks", csym->name,
	    &csym->declared_at);
}

    if (UNLIMITED_POLY (csym)(csym != __null && csym->ts.type == BT_CLASS &&
 csym->ts.u.derived->components && csym->ts.
u.derived->components->ts.u.derived && csym->
ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
))
gfc_error_now ("%qs at %L cannot appear in COMMON "
       "[F2008:C5100]", csym->name, &csym->declared_at);

    if (csym->ts.type != BT_DERIVED)
continue;

    if (!(csym->ts.u.derived->attr.sequence
   || csym->ts.u.derived->attr.is_bind_c))
gfc_error_now ("Derived type variable %qs in COMMON at %L "
       "has neither the SEQUENCE nor the BIND(C) "
       "attribute", csym->name, &csym->declared_at);
    if (csym->ts.u.derived->attr.alloc_comp)
gfc_error_now ("Derived type variable %qs in COMMON at %L "
       "has an ultimate component that is "
       "allocatable", csym->name, &csym->declared_at);
    if (gfc_has_default_initializer (csym->ts.u.derived))
gfc_error_now ("Derived type variable %qs in COMMON at %L "
       "may not have default initializer", csym->name,
       &csym->declared_at);

    if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
  }
1013}

1015/* Resolve common blocks.  */
1016static void
1017resolve_common_blocks (gfc_symtree *common_root)
1018{
gfc_symbol *sym;
gfc_gsymbol * gsym;

if (common_root == NULL__null)
  return;

if (common_root->left)
  resolve_common_blocks (common_root->left);
if (common_root->right)
  resolve_common_blocks (common_root->right);

resolve_common_vars (common_root->n.common, true);

/* The common name is a global name - in Fortran 2003 also if it has a
   C binding name, since Fortran 2008 only the C binding name is a global
   identifier.  */
if (!common_root->n.common->binding_label
    || gfc_notification_std (GFC_STD_F2008(1<<7)))
  {
    gsym = gfc_find_gsymbol (gfc_gsym_root,
	       common_root->n.common->name);

    if (gsym && gfc_notification_std (GFC_STD_F2008(1<<7))
 && gsym->type == GSYM_COMMON
 && ((common_root->n.common->binding_label
      && (!gsym->binding_label
   || strcmp (common_root->n.common->binding_label,
	      gsym->binding_label) != 0))
     || (!common_root->n.common->binding_label
  && gsym->binding_label)))
{
 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
     "identifier and must thus have the same binding name "
     "as the same-named COMMON block at %L: %s vs %s",
     common_root->n.common->name, &common_root->n.common->where,
     &gsym->where,
     common_root->n.common->binding_label
     ? common_root->n.common->binding_label : "(blank)",
     gsym->binding_label ? gsym->binding_label : "(blank)");
 return;
}

    if (gsym && gsym->type != GSYM_COMMON
 && !common_root->n.common->binding_label)
{
 gfc_error ("COMMON block %qs at %L uses the same global identifier "
     "as entity at %L",
     common_root->n.common->name, &common_root->n.common->where,
     &gsym->where);
 return;
}
    if (gsym && gsym->type != GSYM_COMMON)
{
 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
     "%L sharing the identifier with global non-COMMON-block "
     "entity at %L", common_root->n.common->name,
     &common_root->n.common->where, &gsym->where);
 return;
}
    if (!gsym)
{
 gsym = gfc_get_gsymbol (common_root->n.common->name, false);
 gsym->type = GSYM_COMMON;
 gsym->where = common_root->n.common->where;
 gsym->defined = 1;
}
    gsym->used = 1;
  }

if (common_root->n.common->binding_label)
  {
    gsym = gfc_find_gsymbol (gfc_gsym_root,
	       common_root->n.common->binding_label);
    if (gsym && gsym->type != GSYM_COMMON)
{
 gfc_error ("COMMON block at %L with binding label %qs uses the same "
     "global identifier as entity at %L",
     &common_root->n.common->where,
     common_root->n.common->binding_label, &gsym->where);
 return;
}
    if (!gsym)
{
 gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
 gsym->type = GSYM_COMMON;
 gsym->where = common_root->n.common->where;
 gsym->defined = 1;
}
    gsym->used = 1;
  }

gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
if (sym == NULL__null)
  return;

if (sym->attr.flavor == FL_PARAMETER)
  gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
      sym->name, &common_root->n.common->where, &sym->declared_at);

if (sym->attr.external)
  gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
      sym->name, &common_root->n.common->where);

if (sym->attr.intrinsic)
  gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
      sym->name, &common_root->n.common->where);
else if (sym->attr.result
  || gfc_is_function_return_value (sym, gfc_current_ns))
  gfc_notify_std (GFC_STD_F2003(1<<4), "COMMON block %qs at %L "
    "that is also a function result", sym->name,
    &common_root->n.common->where);
else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
  && sym->attr.proc != PROC_ST_FUNCTION)
  gfc_notify_std (GFC_STD_F2003(1<<4), "COMMON block %qs at %L "
    "that is also a global procedure", sym->name,
    &common_root->n.common->where);
1135}


1138/* Resolve contained function types.  Because contained functions can call one
 another, they have to be worked out before any of the contained procedures
 can be resolved.

 The good news is that if a function doesn't already have a type, the only
 way it can get one is through an IMPLICIT type or a RESULT variable, because
 by definition contained functions are contained namespace they're contained
 in, not in a sibling or parent namespace.  */

1147static void
1148resolve_contained_functions (gfc_namespace *ns)
1149{
gfc_namespace *child;
gfc_entry_list *el;

resolve_formal_arglists (ns);

for (child = ns->contained; child; child = child->sibling)
  {
    /* Resolve alternate entry points first.  */
    resolve_entries (child);

    /* Then check function return types.  */
    resolve_contained_fntype (child->proc_name, child);
    for (el = child->entries; el; el = el->next)
resolve_contained_fntype (el->sym, child);
  }
1165}



1169/* A Parameterized Derived Type constructor must contain values for
 the PDT KIND parameters or they must have a default initializer.
 Go through the constructor picking out the KIND expressions,
 storing them in 'param_list' and then call gfc_get_pdt_instance
 to obtain the PDT instance.  */

1175static gfc_actual_arglist *param_list, *param_tail, *param;

1177static bool
1178get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1179{
param = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
if (!param_list)
  param_list = param_tail = param;
else
  {
    param_tail->next = param;
    param_tail = param_tail->next;
  }

param_tail->name = c->name;
if (expr)
  param_tail->expr = gfc_copy_expr (expr);
else if (c->initializer)
  param_tail->expr = gfc_copy_expr (c->initializer);
else
  {
    param_tail->spec_type = SPEC_ASSUMED;
    if (c->attr.pdt_kind)
{
 gfc_error ("The KIND parameter %qs in the PDT constructor "
     "at %C has no value", param->name);
 return false;
}
  }

return true;
1206}

1208static bool
1209get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
     gfc_symbol *derived)
1211{
gfc_constructor *cons = NULL__null;
gfc_component *comp;
bool t = true;

if (expr && expr->expr_type == EXPR_STRUCTURE)
  cons = gfc_constructor_first (expr->value.constructor);
else if (constr)
  cons = *constr;
gcc_assert (cons)((void)(!(cons) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 1220, __FUNCTION__), 0 : 0));

comp = derived->components;

for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
  {
    if (cons->expr
 && cons->expr->expr_type == EXPR_STRUCTURE
 && comp->ts.type == BT_DERIVED)
{
 t = get_pdt_constructor (cons->expr, NULL__null, comp->ts.u.derived);
 if (!t)
   return t;
}
    else if (comp->ts.type == BT_DERIVED)
{
 t = get_pdt_constructor (NULL__null, &cons, comp->ts.u.derived);
 if (!t)
   return t;
}
   else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
      && derived->attr.pdt_template)
{
 t = get_pdt_spec_expr (comp, cons->expr);
 if (!t)
   return t;
}
  }
return t;
1249}


1252static bool resolve_fl_derived0 (gfc_symbol *sym);
1253static bool resolve_fl_struct (gfc_symbol *sym);


1256/* Resolve all of the elements of a structure constructor and make sure that
 the types are correct. The 'init' flag indicates that the given
 constructor is an initializer.  */

1260static bool
1261resolve_structure_cons (gfc_expr *expr, int init)
1262{
gfc_constructor *cons;
gfc_component *comp;
bool t;
symbol_attribute a;

t = true;

if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
  {
    if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
      resolve_fl_derived0 (expr->ts.u.derived);
    else
      resolve_fl_struct (expr->ts.u.derived);

    /* If this is a Parameterized Derived Type template, find the
instance corresponding to the PDT kind parameters.  */
    if (expr->ts.u.derived->attr.pdt_template)
{
 param_list = NULL__null;
 t = get_pdt_constructor (expr, NULL__null, expr->ts.u.derived);
 if (!t)
   return t;
 gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL__null);

 expr->param_list = gfc_copy_actual_arglist (param_list);

 if (param_list)
   gfc_free_actual_arglist (param_list);

 if (!expr->ts.u.derived->attr.pdt_type)
   return false;
}
  }

/* A constructor may have references if it is the result of substituting a
   parameter variable.  In this case we just pull out the component we
   want.  */
if (expr->ref)
  comp = expr->ref->u.c.sym->components;
else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
   || expr->ts.type == BT_UNION)
  && expr->ts.u.derived)
  comp = expr->ts.u.derived->components;
else
  return false;

cons = gfc_constructor_first (expr->value.constructor);

for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
  {
    int rank;

    if (!cons->expr)
continue;

    /* Unions use an EXPR_NULL contrived expression to tell the translation
       phase to generate an initializer of the appropriate length.
       Ignore it here.  */
    if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
      continue;

    if (!gfc_resolve_expr (cons->expr))
{
 t = false;
 continue;
}

    rank = comp->as ? comp->as->rank : 0;
    if (comp->ts.type == BT_CLASS
 && !comp->ts.u.derived->attr.unlimited_polymorphic
 && CLASS_DATA (comp)comp->ts.u.derived->components->as)
rank = CLASS_DATA (comp)comp->ts.u.derived->components->as->rank;

    if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
 && (comp->attr.allocatable || cons->expr->rank))
{
 gfc_error ("The rank of the element in the structure "
     "constructor at %L does not match that of the "
     "component (%d/%d)", &cons->expr->where,
     cons->expr->rank, rank);
 t = false;
}

    /* If we don't have the right type, try to convert it.  */

    if (!comp->attr.proc_pointer &&
 !gfc_compare_types (&cons->expr->ts, &comp->ts))
{
 if (strcmp (comp->name, "_extends") == 0)
   {
     /* Can afford to be brutal with the _extends initializer.
 The derived type can get lost because it is PRIVATE
 but it is not usage constrained by the standard.  */
     cons->expr->ts = comp->ts;
   }
 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
   {
     gfc_error ("The element in the structure constructor at %L, "
	 "for pointer component %qs, is %s but should be %s",
	 &cons->expr->where, comp->name,
	 gfc_basic_typename (cons->expr->ts.type),
	 gfc_basic_typename (comp->ts.type));
     t = false;
   }
 else
   {
     bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
     if (t)
t = t2;
   }
}

    /* For strings, the length of the constructor should be the same as
the one of the structure, ensure this if the lengths are known at
 compile time and when we are dealing with PARAMETER or structure
constructors.  */
    if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
 && comp->ts.u.cl->length
 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
 && mpz_cmp__gmpz_cmp (cons->expr->ts.u.cl->length->value.integer,
      comp->ts.u.cl->length->value.integer) != 0)
{
 if (comp->attr.pointer)
   {
     HOST_WIDE_INTlong la, lb;
     la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
     lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
     gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
	 "component %qs in constructor at %L",
	 la, lb, comp->name, &cons->expr->where);
     t = false;
   }

 if (cons->expr->expr_type == EXPR_VARIABLE
     && cons->expr->rank != 0
     && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
   {
     /* Wrap the parameter in an array constructor (EXPR_ARRAY)
 to make use of the gfc_resolve_character_array_constructor
 machinery.  The expression is later simplified away to
 an array of string literals.  */
     gfc_expr *para = cons->expr;
     cons->expr = gfc_get_expr ();
     cons->expr->ts = para->ts;
     cons->expr->where = para->where;
     cons->expr->expr_type = EXPR_ARRAY;
     cons->expr->rank = para->rank;
     cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
     gfc_constructor_append_expr (&cons->expr->value.constructor,
			   para, &cons->expr->where);
   }

 if (cons->expr->expr_type == EXPR_ARRAY)
   {
     /* Rely on the cleanup of the namespace to deal correctly with
 the old charlen.  (There was a block here that attempted to
 remove the charlen but broke the chain in so doing.)  */
     cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
     cons->expr->ts.u.cl->length_from_typespec = true;
     cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
     gfc_resolve_character_array_constructor (cons->expr);
   }
}

    if (cons->expr->expr_type == EXPR_NULL
 && !(comp->attr.pointer || comp->attr.allocatable
      || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
      || (comp->ts.type == BT_CLASS
   && (CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer
       || CLASS_DATA (comp)comp->ts.u.derived->components->attr.allocatable))))
{
 t = false;
 gfc_error ("The NULL in the structure constructor at %L is "
     "being applied to component %qs, which is neither "
     "a POINTER nor ALLOCATABLE", &cons->expr->where,
     comp->name);
}

    if (comp->attr.proc_pointer && comp->ts.interface)
{
 /* Check procedure pointer interface.  */
 gfc_symbol *s2 = NULL__null;
 gfc_component *c2;
 const char *name;
 char err[200];

 c2 = gfc_get_proc_ptr_comp (cons->expr);
 if (c2)
   {
     s2 = c2->ts.interface;
     name = c2->name;
   }
 else if (cons->expr->expr_type == EXPR_FUNCTION)
   {
     s2 = cons->expr->symtree->n.sym->result;
     name = cons->expr->symtree->n.sym->result->name;
   }
 else if (cons->expr->expr_type != EXPR_NULL)
   {
     s2 = cons->expr->symtree->n.sym;
     name = cons->expr->symtree->n.sym->name;
   }

 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
			     err, sizeof (err), NULL__null, NULL__null))
   {
     gfc_error_opt (0, "Interface mismatch for procedure-pointer "
	     "component %qs in structure constructor at %L:"
	     " %s", comp->name, &cons->expr->where, err);
     return false;
   }
}

    /* Validate shape, except for dynamic or PDT arrays.  */
    if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
 && comp->as && !comp->attr.allocatable && !comp->attr.pointer
 && !comp->attr.pdt_array)
{
 mpz_t len;
 mpz_init__gmpz_init (len);
 for (int n = 0; n < rank; n++)
   {
     if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
  || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
{
  gfc_error ("Bad array spec of component %qs referenced in "
	     "structure constructor at %L",
	     comp->name, &cons->expr->where);
  t = false;
  break;
};
     if (cons->expr->shape == NULL__null)
continue;
     mpz_set_ui__gmpz_set_ui (len, 1);
     mpz_add__gmpz_add (len, len, comp->as->upper[n]->value.integer);
     mpz_sub__gmpz_sub (len, len, comp->as->lower[n]->value.integer);
     if (mpz_cmp__gmpz_cmp (cons->expr->shape[n], len) != 0)
{
  gfc_error ("The shape of component %qs in the structure "
	     "constructor at %L differs from the shape of the "
	     "declared component for dimension %d (%ld/%ld)",
	     comp->name, &cons->expr->where, n+1,
	     mpz_get_si__gmpz_get_si (cons->expr->shape[n]),
	     mpz_get_si__gmpz_get_si (len));
  t = false;
}
   }
 mpz_clear__gmpz_clear (len);
}

    if (!comp->attr.pointer || comp->attr.proc_pointer
 || cons->expr->expr_type == EXPR_NULL)
continue;

    a = gfc_expr_attr (cons->expr);

    if (!a.pointer && !a.target)
{
 t = false;
 gfc_error ("The element in the structure constructor at %L, "
     "for pointer component %qs should be a POINTER or "
     "a TARGET", &cons->expr->where, comp->name);
}

    if (init)
{
 /* F08:C461. Additional checks for pointer initialization.  */
 if (a.allocatable)
   {
     t = false;
     gfc_error ("Pointer initialization target at %L "
	 "must not be ALLOCATABLE", &cons->expr->where);
   }
 if (!a.save)
   {
     t = false;
     gfc_error ("Pointer initialization target at %L "
	 "must have the SAVE attribute", &cons->expr->where);
   }
}

    /* F2003, C1272 (3).  */
    bool impure = cons->expr->expr_type == EXPR_VARIABLE
    && (gfc_impure_variable (cons->expr->symtree->n.sym)
	|| gfc_is_coindexed (cons->expr));
    if (impure && gfc_pure (NULL__null))
{
 t = false;
 gfc_error ("Invalid expression in the structure constructor for "
     "pointer component %qs at %L in PURE procedure",
     comp->name, &cons->expr->where);
}

    if (impure)
gfc_unset_implicit_pure (NULL__null);
  }

return t;
1563}


1566/****************** Expression name resolution ******************/

1568/* Returns 0 if a symbol was not declared with a type or
 attribute declaration statement, nonzero otherwise.  */

1571static int
1572was_declared (gfc_symbol *sym)
1573{
symbol_attribute a;

a = sym->attr;

if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
  return 1;

if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
    || a.optional || a.pointer || a.save || a.target || a.volatile_
    || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
    || a.asynchronous || a.codimension)
  return 1;

return 0;
1588}


1591/* Determine if a symbol is generic or not.  */

1593static int
1594generic_sym (gfc_symbol *sym)
1595{
gfc_symbol *s;

if (sym->attr.generic ||
    (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
  return 1;

if (was_declared (sym) || sym->ns->parent == NULL__null)
  return 0;

gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);

if (s != NULL__null)
  {
    if (s == sym)
return 0;
    else
return generic_sym (s);
  }

return 0;
1616}


1619/* Determine if a symbol is specific or not.  */

1621static int
1622specific_sym (gfc_symbol *sym)
1623{
gfc_symbol *s;

if (sym->attr.if_source == IFSRC_IFBODY
    || sym->attr.proc == PROC_MODULE
    || sym->attr.proc == PROC_INTERNAL
    || sym->attr.proc == PROC_ST_FUNCTION
    || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
    || sym->attr.external)
  return 1;

if (was_declared (sym) || sym->ns->parent == NULL__null)
  return 0;

gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);

return (s == NULL__null) ? 0 : specific_sym (s);
1640}


1643/* Figure out if the procedure is specific, generic or unknown.  */

1645enum proc_type
1646{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };

1648static proc_type
1649procedure_kind (gfc_symbol *sym)
1650{
if (generic_sym (sym))
  return PTYPE_GENERIC;

if (specific_sym (sym))
  return PTYPE_SPECIFIC;

return PTYPE_UNKNOWN;
1658}

1660/* Check references to assumed size arrays.  The flag need_full_assumed_size
 is nonzero when matching actual arguments.  */

1663static int need_full_assumed_size = 0;

1665static bool
1666check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1667{
if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
    return false;

/* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
   What should it be?  */
if (e->ref
    && e->ref->u.ar.as
    && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL__null)
    && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
    && (e->ref->u.ar.type == AR_FULL))
  {
    gfc_error ("The upper bound in the last dimension must "
 "appear in the reference to the assumed size "
 "array %qs at %L", sym->name, &e->where);
    return true;
  }
return false;
1685}


1688/* Look for bad assumed size array references in argument expressions
of elemental and array valued intrinsic procedures.  Since this is
called from procedure resolution functions, it only recurses at
operators.  */

1693static bool
1694resolve_assumed_size_actual (gfc_expr *e)
1695{
if (e == NULL__null)
 return false;

switch (e->expr_type)
  {
  case EXPR_VARIABLE:
    if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
return true;
    break;

  case EXPR_OP:
    if (resolve_assumed_size_actual (e->value.op.op1)
 || resolve_assumed_size_actual (e->value.op.op2))
return true;
    break;

  default:
    break;
  }
return false;
1716}


1719/* Check a generic procedure, passed as an actual argument, to see if
 there is a matching specific name.  If none, it is an error, and if
 more than one, the reference is ambiguous.  */
1722static int
1723count_specific_procs (gfc_expr *e)
1724{
int n;
gfc_interface *p;
gfc_symbol *sym;

n = 0;
sym = e->symtree->n.sym;

for (p = sym->generic; p; p = p->next)
  if (strcmp (sym->name, p->sym->name) == 0)
    {
e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
		       sym->name);
n++;
    }

if (n > 1)
  gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
      &e->where);

if (n == 0)
  gfc_error ("GENERIC procedure %qs is not allowed as an actual "
      "argument at %L", sym->name, &e->where);

return n;
1749}


1752/* See if a call to sym could possibly be a not allowed RECURSION because of
 a missing RECURSIVE declaration.  This means that either sym is the current
 context itself, or sym is the parent of a contained procedure calling its
 non-RECURSIVE containing procedure.
 This also works if sym is an ENTRY.  */

1758static bool
1759is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1760{
gfc_symbol* proc_sym;
gfc_symbol* context_proc;
gfc_namespace* real_context;

if (sym->attr.flavor == FL_PROGRAM
    || gfc_fl_struct (sym->attr.flavor)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
 == FL_UNION || (sym->attr.flavor) == FL_STRUCT))
  return false;

/* If we've got an ENTRY, find real procedure.  */
if (sym->attr.entry && sym->ns->entries)
  proc_sym = sym->ns->entries->sym;
else
  proc_sym = sym;

/* If sym is RECURSIVE, all is well of course.  */
if (proc_sym->attr.recursive || flag_recursiveglobal_options.x_flag_recursive)
  return false;

/* Find the context procedure's "real" symbol if it has entries.
   We look for a procedure symbol, so recurse on the parents if we don't
   find one (like in case of a BLOCK construct).  */
for (real_context = context; ; real_context = real_context->parent)
  {
    /* We should find something, eventually!  */
    gcc_assert (real_context)((void)(!(real_context) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 1785, __FUNCTION__), 0 : 0));

    context_proc = (real_context->entries ? real_context->entries->sym
			    : real_context->proc_name);

    /* In some special cases, there may not be a proc_name, like for this
invalid code:
real(bad_kind()) function foo () ...
when checking the call to bad_kind ().
In these cases, we simply return here and assume that the
call is ok.  */
    if (!context_proc)
return false;

    if (context_proc->attr.flavor != FL_LABEL)
break;
  }

/* A call from sym's body to itself is recursion, of course.  */
if (context_proc == proc_sym)
  return true;

/* The same is true if context is a contained procedure and sym the
   containing one.  */
if (context_proc->attr.contained)
  {
    gfc_symbol* parent_proc;

    gcc_assert (context->parent)((void)(!(context->parent) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 1813, __FUNCTION__), 0 : 0));
    parent_proc = (context->parent->entries ? context->parent->entries->sym
			      : context->parent->proc_name);

    if (parent_proc == proc_sym)
return true;
  }

return false;
1822}


1825/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
 its typespec and formal argument list.  */

1828bool
1829gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1830{
gfc_intrinsic_sym* isym = NULL__null;
const char* symstd;

if (sym->resolve_symbol_called >= 2)
  return true;

sym->resolve_symbol_called = 2;

/* Already resolved.  */
if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
  return true;

/* We already know this one is an intrinsic, so we don't call
   gfc_is_intrinsic for full checking but rather use gfc_find_function and
   gfc_find_subroutine directly to check whether it is a function or
   subroutine.  */

if (sym->intmod_sym_id && sym->attr.subroutine)
  {
    gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
    isym = gfc_intrinsic_subroutine_by_id (id);
  }
else if (sym->intmod_sym_id)
  {
    gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
    isym = gfc_intrinsic_function_by_id (id);
  }
else if (!sym->attr.subroutine)
  isym = gfc_find_function (sym->name);

if (isym && !sym->attr.subroutine)
  {
    if (sym->ts.type != BT_UNKNOWN && warn_surprisingglobal_options.x_warn_surprising
 && !sym->attr.implicit_type)
gfc_warning (OPT_Wsurprising,
     "Type specified for intrinsic function %qs at %L is"
      " ignored", sym->name, &sym->declared_at);

    if (!sym->attr.function &&
 !gfc_add_function(&sym->attr, sym->name, loc))
return false;

    sym->ts = isym->ts;
  }
else if (isym || (isym = gfc_find_subroutine (sym->name)))
  {
    if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
{
 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
      " specifier", sym->name, &sym->declared_at);
 return false;
}

    if (!sym->attr.subroutine &&
 !gfc_add_subroutine(&sym->attr, sym->name, loc))
return false;
  }
else
  {
    gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
 &sym->declared_at);
    return false;
  }

gfc_copy_formal_args_intr (sym, isym, NULL__null);

sym->attr.pure = isym->pure;
sym->attr.elemental = isym->elemental;

/* Check it is actually available in the standard settings.  */
if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
  {
    gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
 "available in the current standard settings but %s. Use "
 "an appropriate %<-std=*%> option or enable "
 "%<-fall-intrinsics%> in order to use it.",
 sym->name, &sym->declared_at, symstd);
    return false;
  }

return true;
1912}


1915/* Resolve a procedure expression, like passing it to a called procedure or as
 RHS for a procedure pointer assignment.  */

1918static bool
1919resolve_procedure_expression (gfc_expr* expr)
1920{
gfc_symbol* sym;

if (expr->expr_type != EXPR_VARIABLE)
  return true;
gcc_assert (expr->symtree)((void)(!(expr->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 1925, __FUNCTION__), 0 : 0));

sym = expr->symtree->n.sym;

if (sym->attr.intrinsic)
  gfc_resolve_intrinsic (sym, &expr->where);

if (sym->attr.flavor != FL_PROCEDURE
    || (sym->attr.function && sym->result == sym))
  return true;

/* A non-RECURSIVE procedure that is used as procedure expression within its
   own body is in danger of being called recursively.  */
if (is_illegal_recursion (sym, gfc_current_ns))
  gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
 " itself recursively.  Declare it RECURSIVE or use"
 " %<-frecursive%>", sym->name, &expr->where);

return true;
1944}


1947/* Check that name is not a derived type.  */

1949static bool
1950is_dt_name (const char *name)
1951{
gfc_symbol *dt_list, *dt_first;

dt_list = dt_first = gfc_derived_types;
for (; dt_list; dt_list = dt_list->dt_next)
  {
    if (strcmp(dt_list->name, name) == 0)
return true;
    if (dt_first == dt_list->dt_next)
break;
  }
return false;
1963}


1966/* Resolve an actual argument list.  Most of the time, this is just
 resolving the expressions in the list.
 The exception is that we sometimes have to decide whether arguments
 that look like procedure arguments are really simple variable
 references.  */

1972static bool
1973resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
	bool no_formal_args)
1975{
gfc_symbol *sym;
gfc_symtree *parent_st;
gfc_expr *e;
gfc_component *comp;
int save_need_full_assumed_size;
bool return_value = false;
bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;

actual_arg = true;
first_actual_arg = true;

for (; arg; arg = arg->next)
  {
    e = arg->expr;
    if (e == NULL__null)
{
 /* Check the label is a valid branching target.  */
 if (arg->label)
   {
     if (arg->label->defined == ST_LABEL_UNKNOWN)
{
  gfc_error ("Label %d referenced at %L is never defined",
	     arg->label->value, &arg->label->where);
  goto cleanup;
}
   }
 first_actual_arg = false;
 continue;
}

    if (e->expr_type == EXPR_VARIABLE
   && e->symtree->n.sym->attr.generic
   && no_formal_args
   && count_specific_procs (e) != 1)
goto cleanup;

    if (e->ts.type != BT_PROCEDURE)
{
 save_need_full_assumed_size = need_full_assumed_size;
 if (e->expr_type != EXPR_VARIABLE)
   need_full_assumed_size = 0;
 if (!gfc_resolve_expr (e))
   goto cleanup;
 need_full_assumed_size = save_need_full_assumed_size;
 goto argument_list;
}

    /* See if the expression node should really be a variable reference.  */

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

    if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
{
 gfc_error ("Derived type %qs is used as an actual "
     "argument at %L", sym->name, &e->where);
 goto cleanup;
}

    if (sym->attr.flavor == FL_PROCEDURE
 || sym->attr.intrinsic
 || sym->attr.external)
{
 int actual_ok;

 /* If a procedure is not already determined to be something else
    check if it is intrinsic.  */
 if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
   sym->attr.intrinsic = 1;

 if (sym->attr.proc == PROC_ST_FUNCTION)
   {
     gfc_error ("Statement function %qs at %L is not allowed as an "
	 "actual argument", sym->name, &e->where);
   }

 actual_ok = gfc_intrinsic_actual_ok (sym->name,
			       sym->attr.subroutine);
 if (sym->attr.intrinsic && actual_ok == 0)
   {
     gfc_error ("Intrinsic %qs at %L is not allowed as an "
	 "actual argument", sym->name, &e->where);
   }

 if (sym->attr.contained && !sym->attr.use_assoc
     && sym->ns->proc_name->attr.flavor != FL_MODULE)
   {
     if (!gfc_notify_std (GFC_STD_F2008(1<<7), "Internal procedure %qs is"
		   " used as actual argument at %L",
		   sym->name, &e->where))
goto cleanup;
   }

 if (sym->attr.elemental && !sym->attr.intrinsic)
   {
     gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
	 "allowed as an actual argument at %L", sym->name,
	 &e->where);
   }

 /* Check if a generic interface has a specific procedure
   with the same name before emitting an error.  */
 if (sym->attr.generic && count_specific_procs (e) != 1)
   goto cleanup;

 /* Just in case a specific was found for the expression.  */
 sym = e->symtree->n.sym;

 /* If the symbol is the function that names the current (or
    parent) scope, then we really have a variable reference.  */

 if (gfc_is_function_return_value (sym, sym->ns))
   goto got_variable;

 /* If all else fails, see if we have a specific intrinsic.  */
 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
   {
     gfc_intrinsic_sym *isym;

     isym = gfc_find_function (sym->name);
     if (isym == NULL__null || !isym->specific)
{
  gfc_error ("Unable to find a specific INTRINSIC procedure "
	     "for the reference %qs at %L", sym->name,
	     &e->where);
  goto cleanup;
}
     sym->ts = isym->ts;
     sym->attr.intrinsic = 1;
     sym->attr.function = 1;
   }

 if (!gfc_resolve_expr (e))
   goto cleanup;
 goto argument_list;
}

    /* See if the name is a module procedure in a parent unit.  */

    if (was_declared (sym) || sym->ns->parent == NULL__null)
goto got_variable;

    if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
 gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
 goto cleanup;
}

    if (parent_st == NULL__null)
goto got_variable;

    sym = parent_st->n.sym;
    e->symtree = parent_st;		/* Point to the right thing.  */

    if (sym->attr.flavor == FL_PROCEDURE
 || sym->attr.intrinsic
 || sym->attr.external)
{
 if (!gfc_resolve_expr (e))
   goto cleanup;
 goto argument_list;
}

  got_variable:
    e->expr_type = EXPR_VARIABLE;
    e->ts = sym->ts;
    if ((sym->as != NULL__null && sym->ts.type != BT_CLASS)
 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
     && CLASS_DATA (sym)sym->ts.u.derived->components->as))
{
 e->rank = sym->ts.type == BT_CLASS
    ? CLASS_DATA (sym)sym->ts.u.derived->components->as->rank : sym->as->rank;
 e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
 e->ref->type = REF_ARRAY;
 e->ref->u.ar.type = AR_FULL;
 e->ref->u.ar.as = sym->ts.type == BT_CLASS
	    ? CLASS_DATA (sym)sym->ts.u.derived->components->as : sym->as;
}

    /* Expressions are assigned a default ts.type of BT_PROCEDURE in
primary.cc (match_actual_arg). If above code determines that it
is a  variable instead, it needs to be resolved as it was not
done at the beginning of this function.  */
    save_need_full_assumed_size = need_full_assumed_size;
    if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
    if (!gfc_resolve_expr (e))
goto cleanup;
    need_full_assumed_size = save_need_full_assumed_size;

  argument_list:
    /* Check argument list functions %VAL, %LOC and %REF.  There is
nothing to do for %REF.  */
    if (arg->name && arg->name[0] == '%')
{
 if (strcmp ("%VAL", arg->name) == 0)
   {
     if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
{
  gfc_error ("By-value argument at %L is not of numeric "
	     "type", &e->where);
  goto cleanup;
}

     if (e->rank)
{
  gfc_error ("By-value argument at %L cannot be an array or "
	     "an array section", &e->where);
  goto cleanup;
}

     /* Intrinsics are still PROC_UNKNOWN here.  However,
 since same file external procedures are not resolvable
 in gfortran, it is a good deal easier to leave them to
 intrinsic.cc.  */
     if (ptype != PROC_UNKNOWN
  && ptype != PROC_DUMMY
  && ptype != PROC_EXTERNAL
  && ptype != PROC_MODULE)
{
  gfc_error ("By-value argument at %L is not allowed "
	     "in this context", &e->where);
  goto cleanup;
}
   }

 /* Statement functions have already been excluded above.  */
 else if (strcmp ("%LOC", arg->name) == 0
   && e->ts.type == BT_PROCEDURE)
   {
     if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
{
  gfc_error ("Passing internal procedure at %L by location "
	     "not allowed", &e->where);
  goto cleanup;
}
   }
}

    comp = gfc_get_proc_ptr_comp(e);
    if (e->expr_type == EXPR_VARIABLE
 && comp && comp->attr.elemental)
{
   gfc_error ("ELEMENTAL procedure pointer component %qs is not "
       "allowed as an actual argument at %L", comp->name,
       &e->where);
}

    /* Fortran 2008, C1237.  */
    if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
 && gfc_has_ultimate_pointer (e))
{
 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
     "component", &e->where);
 goto cleanup;
}

    first_actual_arg = false;
  }

return_value = true;

2237cleanup:
actual_arg = actual_arg_sav;
first_actual_arg = first_actual_arg_sav;

return return_value;
2242}


2245/* Do the checks of the actual argument list that are specific to elemental
 procedures.  If called with c == NULL, we have a function, otherwise if
 expr == NULL, we have a subroutine.  */

2249static bool
2250resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2251{
gfc_actual_arglist *arg0;
gfc_actual_arglist *arg;
gfc_symbol *esym = NULL__null;
gfc_intrinsic_sym *isym = NULL__null;
gfc_expr *e = NULL__null;
gfc_intrinsic_arg *iformal = NULL__null;
gfc_formal_arglist *eformal = NULL__null;
bool formal_optional = false;
bool set_by_optional = false;
int i;
int rank = 0;

/* Is this an elemental procedure?  */
if (expr && expr->value.function.actual != NULL__null)
  {
    if (expr->value.function.esym != NULL__null
 && expr->value.function.esym->attr.elemental)
{
 arg0 = expr->value.function.actual;
 esym = expr->value.function.esym;
}
    else if (expr->value.function.isym != NULL__null
      && expr->value.function.isym->elemental)
{
 arg0 = expr->value.function.actual;
 isym = expr->value.function.isym;
}
    else
return true;
  }
else if (c && c->ext.actual != NULL__null)
  {
    arg0 = c->ext.actual;

    if (c->resolved_sym)
esym = c->resolved_sym;
    else
esym = c->symtree->n.sym;
    gcc_assert (esym)((void)(!(esym) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 2290, __FUNCTION__), 0 : 0));

    if (!esym->attr.elemental)
return true;
  }
else
  return true;

/* The rank of an elemental is the rank of its array argument(s).  */
for (arg = arg0; arg; arg = arg->next)
  {
    if (arg->expr != NULL__null && arg->expr->rank != 0)
{
 rank = arg->expr->rank;
 if (arg->expr->expr_type == EXPR_VARIABLE
     && arg->expr->symtree->n.sym->attr.optional)
   set_by_optional = true;

 /* Function specific; set the result rank and shape.  */
 if (expr)
   {
     expr->rank = rank;
     if (!expr->shape && arg->expr->shape)
{
  expr->shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
  for (i = 0; i < rank; i++)
    mpz_init_set__gmpz_init_set (expr->shape[i], arg->expr->shape[i]);
}
   }
 break;
}
  }

/* If it is an array, it shall not be supplied as an actual argument
   to an elemental procedure unless an array of the same rank is supplied
   as an actual argument corresponding to a nonoptional dummy argument of
   that elemental procedure(12.4.1.5).  */
formal_optional = false;
if (isym)
  iformal = isym->formal;
else
  eformal = esym->formal;

for (arg = arg0; arg; arg = arg->next)
  {
    if (eformal)
{
 if (eformal->sym && eformal->sym->attr.optional)
   formal_optional = true;
 eformal = eformal->next;
}
    else if (isym && iformal)
{
 if (iformal->optional)
   formal_optional = true;
 iformal = iformal->next;
}
    else if (isym)
formal_optional = true;

    if (pedanticglobal_options.x_pedantic && arg->expr != NULL__null
 && arg->expr->expr_type == EXPR_VARIABLE
 && arg->expr->symtree->n.sym->attr.optional
 && formal_optional
 && arg->expr->rank
 && (set_by_optional || arg->expr->rank != rank)
 && !(isym && isym->id == GFC_ISYM_CONVERSION))
{
 bool t = false;
 gfc_actual_arglist *a;

 /* Scan the argument list for a non-optional argument with the
    same rank as arg.  */
 for (a = arg0; a; a = a->next)
   if (a != arg
&& a->expr->rank == arg->expr->rank
&& !a->expr->symtree->n.sym->attr.optional)
     {
t = true;
break;
     }

 if (!t)
   gfc_warning (OPT_Wpedantic,
	 "%qs at %L is an array and OPTIONAL; If it is not "
	 "present, then it cannot be the actual argument of "
	 "an ELEMENTAL procedure unless there is a non-optional"
	 " argument with the same rank "
	 "(Fortran 2018, 15.5.2.12)",
	 arg->expr->symtree->n.sym->name, &arg->expr->where);
}
  }

for (arg = arg0; arg; arg = arg->next)
  {
    if (arg->expr == NULL__null || arg->expr->rank == 0)
continue;

    /* Being elemental, the last upper bound of an assumed size array
argument must be present.  */
    if (resolve_assumed_size_actual (arg->expr))
return false;

    /* Elemental procedure's array actual arguments must conform.  */
    if (e != NULL__null)
{
 if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")gettext ("elemental procedure")))
   return false;
}
    else
e = arg->expr;
  }

/* INTENT(OUT) is only allowed for subroutines; if any actual argument
   is an array, the intent inout/out variable needs to be also an array.  */
if (rank > 0 && esym && expr == NULL__null)
  for (eformal = esym->formal, arg = arg0; arg && eformal;
arg = arg->next, eformal = eformal->next)
    if (eformal->sym
 && (eformal->sym->attr.intent == INTENT_OUT
     || eformal->sym->attr.intent == INTENT_INOUT)
 && arg->expr && arg->expr->rank == 0)
{
 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
     "ELEMENTAL subroutine %qs is a scalar, but another "
     "actual argument is an array", &arg->expr->where,
     (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
     : "INOUT", eformal->sym->name, esym->name);
 return false;
}
return true;
2421}


2424/* This function does the checking of references to global procedures
 as defined in sections 18.1 and 14.1, respectively, of the Fortran
 77 and 95 standards.  It checks for a gsymbol for the name, making
 one if it does not already exist.  If it already exists, then the
 reference being resolved must correspond to the type of gsymbol.
 Otherwise, the new symbol is equipped with the attributes of the
 reference.  The corresponding code that is called in creating
 global entities is parse.cc.

 In addition, for all but -std=legacy, the gsymbols are used to
 check the interfaces of external procedures from the same file.
 The namespace of the gsymbol is resolved and then, once this is
 done the interface is checked.  */


2439static bool
2440not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2441{
if (!gsym_ns->proc_name->attr.recursive)
  return true;

if (sym->ns == gsym_ns)
  return false;

if (sym->ns->parent && sym->ns->parent == gsym_ns)
  return false;

return true;
2452}

2454static bool
2455not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
2456{
if (gsym_ns->entries)
  {
    gfc_entry_list *entry = gsym_ns->entries;

    for (; entry; entry = entry->next)
{
 if (strcmp (sym->name, entry->sym->name) == 0)
   {
     if (strcmp (gsym_ns->proc_name->name,
	  sym->ns->proc_name->name) == 0)
return false;

     if (sym->ns->parent
  && strcmp (gsym_ns->proc_name->name,
	     sym->ns->parent->proc_name->name) == 0)
return false;
   }
}
  }
return true;
2477}


2480/* Check for the requirement of an explicit interface. F08:12.4.2.2.  */

2482bool
2483gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2484{
gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);

for ( ; arg; arg = arg->next)
  {
    if (!arg->sym)
continue;

    if (arg->sym->attr.allocatable)  /* (2a)  */
{
 strncpy (errmsg, _("allocatable argument")gettext ("allocatable argument"), err_len);
 return true;
}
    else if (arg->sym->attr.asynchronous)
{
 strncpy (errmsg, _("asynchronous argument")gettext ("asynchronous argument"), err_len);
 return true;
}
    else if (arg->sym->attr.optional)
{
 strncpy (errmsg, _("optional argument")gettext ("optional argument"), err_len);
 return true;
}
    else if (arg->sym->attr.pointer)
{
 strncpy (errmsg, _("pointer argument")gettext ("pointer argument"), err_len);
 return true;
}
    else if (arg->sym->attr.target)
{
 strncpy (errmsg, _("target argument")gettext ("target argument"), err_len);
 return true;
}
    else if (arg->sym->attr.value)
{
 strncpy (errmsg, _("value argument")gettext ("value argument"), err_len);
 return true;
}
    else if (arg->sym->attr.volatile_)
{
 strncpy (errmsg, _("volatile argument")gettext ("volatile argument"), err_len);
 return true;
}
    else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE)  /* (2b)  */
{
 strncpy (errmsg, _("assumed-shape argument")gettext ("assumed-shape argument"), err_len);
 return true;
}
    else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK)  /* TS 29113, 6.2.  */
{
 strncpy (errmsg, _("assumed-rank argument")gettext ("assumed-rank argument"), err_len);
 return true;
}
    else if (arg->sym->attr.codimension)  /* (2c)  */
{
 strncpy (errmsg, _("coarray argument")gettext ("coarray argument"), err_len);
 return true;
}
    else if (false)  /* (2d) TODO: parametrized derived type  */
{
 strncpy (errmsg, _("parametrized derived type argument")gettext ("parametrized derived type argument"), err_len);
 return true;
}
    else if (arg->sym->ts.type == BT_CLASS)  /* (2e)  */
{
 strncpy (errmsg, _("polymorphic argument")gettext ("polymorphic argument"), err_len);
 return true;
}
    else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
{
 strncpy (errmsg, _("NO_ARG_CHECK attribute")gettext ("NO_ARG_CHECK attribute"), err_len);
 return true;
}
    else if (arg->sym->ts.type == BT_ASSUMED)
{
 /* As assumed-type is unlimited polymorphic (cf. above).
    See also TS 29113, Note 6.1.  */
 strncpy (errmsg, _("assumed-type argument")gettext ("assumed-type argument"), err_len);
 return true;
}
  }

if (sym->attr.function)
  {
    gfc_symbol *res = sym->result ? sym->result : sym;

    if (res->attr.dimension)  /* (3a)  */
{
 strncpy (errmsg, _("array result")gettext ("array result"), err_len);
 return true;
}
    else if (res->attr.pointer || res->attr.allocatable)  /* (3b)  */
{
 strncpy (errmsg, _("pointer or allocatable result")gettext ("pointer or allocatable result"), err_len);
 return true;
}
    else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
      && res->ts.u.cl->length
      && res->ts.u.cl->length->expr_type != EXPR_CONSTANT)  /* (3c)  */
{
 strncpy (errmsg, _("result with non-constant character length")gettext ("result with non-constant character length"), err_len);
 return true;
}
  }

if (sym->attr.elemental && !sym->attr.intrinsic)  /* (4)  */
  {
    strncpy (errmsg, _("elemental procedure")gettext ("elemental procedure"), err_len);
    return true;
  }
else if (sym->attr.is_bind_c)  /* (5)  */
  {
    strncpy (errmsg, _("bind(c) procedure")gettext ("bind(c) procedure"), err_len);
    return true;
  }

return false;
2601}


2604static void
2605resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2606{
gfc_gsymbol * gsym;
gfc_namespace *ns;
enum gfc_symbol_type type;
char reason[200];

type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;

gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
	  sym->binding_label != NULL__null);

if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
  gfc_global_used (gsym, where);

if ((sym->attr.if_source == IFSRC_UNKNOWN
     || sym->attr.if_source == IFSRC_IFBODY)
    && gsym->type != GSYM_UNKNOWN
    && !gsym->binding_label
    && gsym->ns
    && gsym->ns->proc_name
    && not_in_recursive (sym, gsym->ns)
    && not_entry_self_reference (sym, gsym->ns))
  {
    gfc_symbol *def_sym;
    def_sym = gsym->ns->proc_name;

    if (gsym->ns->resolved != -1)
{

 /* Resolve the gsymbol namespace if needed.  */
 if (!gsym->ns->resolved)
   {
     gfc_symbol *old_dt_list;

     /* Stash away derived types so that the backend_decls
 do not get mixed up.  */
     old_dt_list = gfc_derived_types;
     gfc_derived_types = NULL__null;

     gfc_resolve (gsym->ns);

     /* Store the new derived types with the global namespace.  */
     if (gfc_derived_types)
gsym->ns->derived_types = gfc_derived_types;

     /* Restore the derived types of this namespace.  */
     gfc_derived_types = old_dt_list;
   }

 /* Make sure that translation for the gsymbol occurs before
    the procedure currently being resolved.  */
 ns = gfc_global_ns_list;
 for (; ns && ns != gsym->ns; ns = ns->sibling)
   {
     if (ns->sibling == gsym->ns)
{
  ns->sibling = gsym->ns->sibling;
  gsym->ns->sibling = gfc_global_ns_list;
  gfc_global_ns_list = gsym->ns;
  break;
}
   }

 /* This can happen if a binding name has been specified.  */
 if (gsym->binding_label && gsym->sym_name != def_sym->name)
   gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);

 if (def_sym->attr.entry_master || def_sym->attr.entry)
   {
     gfc_entry_list *entry;
     for (entry = gsym->ns->entries; entry; entry = entry->next)
if (strcmp (entry->sym->name, sym->name) == 0)
  {
    def_sym = entry->sym;
    break;
  }
   }
}

    if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
{
 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
     sym->name, &sym->declared_at, gfc_typename (&sym->ts),
     gfc_typename (&def_sym->ts));
 goto done;
}

    if (sym->attr.if_source == IFSRC_UNKNOWN
 && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
{
 gfc_error ("Explicit interface required for %qs at %L: %s",
     sym->name, &sym->declared_at, reason);
 goto done;
}

    bool bad_result_characteristics;
    if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
		   reason, sizeof(reason), NULL__null, NULL__null,
		   &bad_result_characteristics))
{
 /* Turn erros into warnings with -std=gnu and -std=legacy,
    unless a function returns a wrong type, which can lead
    to all kinds of ICEs and wrong code.  */

 if (!pedanticglobal_options.x_pedantic && (gfc_option.allow_std & GFC_STD_GNU(1<<5))
     && !bad_result_characteristics)
   gfc_errors_to_warnings (true);

 gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
     sym->name, &sym->declared_at, reason);
 sym->error = 1;
 gfc_errors_to_warnings (false);
 goto done;
}
  }

2722done:

if (gsym->type == GSYM_UNKNOWN)
  {
    gsym->type = type;
    gsym->where = *where;
  }

gsym->used = 1;
2731}


2734/************* Function resolution *************/

2736/* Resolve a function call known to be generic.
 Section 14.1.2.4.1.  */

2739static match
2740resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2741{
gfc_symbol *s;

if (sym->attr.generic)
  {
    s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
    if (s != NULL__null)
{
 expr->value.function.name = s->name;
 expr->value.function.esym = s;

 if (s->ts.type != BT_UNKNOWN)
   expr->ts = s->ts;
 else if (s->result != NULL__null && s->result->ts.type != BT_UNKNOWN)
   expr->ts = s->result->ts;

 if (s->as != NULL__null)
   expr->rank = s->as->rank;
 else if (s->result != NULL__null && s->result->as != NULL__null)
   expr->rank = s->result->as->rank;

 gfc_set_sym_referenced (expr->value.function.esym);

 return MATCH_YES;
}

    /* TODO: Need to search for elemental references in generic
interface.  */
  }

if (sym->attr.intrinsic)
  return gfc_intrinsic_func_interface (expr, 0);

return MATCH_NO;
2775}


2778static bool
2779resolve_generic_f (gfc_expr *expr)
2780{
gfc_symbol *sym;
match m;
gfc_interface *intr = NULL__null;

sym = expr->symtree->n.sym;

for (;;)
  {
    m = resolve_generic_f0 (expr, sym);
    if (m == MATCH_YES)
return true;
    else if (m == MATCH_ERROR)
return false;

2795generic:
    if (!intr)
for (intr = sym->generic; intr; intr = intr->next)
 if (gfc_fl_struct (intr->sym->attr.flavor)((intr->sym->attr.flavor) == FL_DERIVED || (intr->sym
->attr.flavor) == FL_UNION || (intr->sym->attr.flavor
) == FL_STRUCT))
   break;

    if (sym->ns->parent == NULL__null)
break;
    gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

    if (sym == NULL__null)
break;
    if (!generic_sym (sym))
goto generic;
  }

/* Last ditch attempt.  See if the reference is to an intrinsic
   that possesses a matching interface.  14.1.2.4  */
if (sym  && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
  {
    if (gfc_init_expr_flag)
gfc_error ("Function %qs in initialization expression at %L "
   "must be an intrinsic function",
   expr->symtree->n.sym->name, &expr->where);
    else
gfc_error ("There is no specific function for the generic %qs "
   "at %L", expr->symtree->n.sym->name, &expr->where);
    return false;
  }

if (intr)
  {
    if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL__null,
				 NULL__null, false))
return false;
    if (!gfc_use_derived (expr->ts.u.derived))
return false;
    return resolve_structure_cons (expr, 0);
  }

m = gfc_intrinsic_func_interface (expr, 0);
if (m == MATCH_YES)
  return true;

if (m == MATCH_NO)
  gfc_error ("Generic function %qs at %L is not consistent with a "
      "specific intrinsic interface", expr->symtree->n.sym->name,
      &expr->where);

return false;
2845}


2848/* Resolve a function call known to be specific.  */

2850static match
2851resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2852{
match m;

if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
  {
    if (sym->attr.dummy)
{
 sym->attr.proc = PROC_DUMMY;
 goto found;
}

    sym->attr.proc = PROC_EXTERNAL;
    goto found;
  }

if (sym->attr.proc == PROC_MODULE
    || sym->attr.proc == PROC_ST_FUNCTION
    || sym->attr.proc == PROC_INTERNAL)
  goto found;

if (sym->attr.intrinsic)
  {
    m = gfc_intrinsic_func_interface (expr, 1);
    if (m == MATCH_YES)
return MATCH_YES;
    if (m == MATCH_NO)
gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
   "with an intrinsic", sym->name, &expr->where);

    return MATCH_ERROR;
  }

return MATCH_NO;

2886found:
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);

if (sym->result)
  expr->ts = sym->result->ts;
else
  expr->ts = sym->ts;
expr->value.function.name = sym->name;
expr->value.function.esym = sym;
/* Prevent crash when sym->ts.u.derived->components is not set due to previous
   error(s).  */
if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)sym->ts.u.derived->components)
  return MATCH_ERROR;
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components->as)
  expr->rank = CLASS_DATA (sym)sym->ts.u.derived->components->as->rank;
else if (sym->as != NULL__null)
  expr->rank = sym->as->rank;

return MATCH_YES;
2905}


2908static bool
2909resolve_specific_f (gfc_expr *expr)
2910{
gfc_symbol *sym;
match m;

sym = expr->symtree->n.sym;

for (;;)
  {
    m = resolve_specific_f0 (sym, expr);
    if (m == MATCH_YES)
return true;
    if (m == MATCH_ERROR)
return false;

    if (sym->ns->parent == NULL__null)
break;

    gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

    if (sym == NULL__null)
break;
  }

gfc_error ("Unable to resolve the specific function %qs at %L",
    expr->symtree->n.sym->name, &expr->where);

return true;
2937}

2939/* Recursively append candidate SYM to CANDIDATES.  Store the number of
 candidates in CANDIDATES_LEN.  */

2942static void
2943lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
		       char **&candidates,
		       size_t &candidates_len)
2946{
gfc_symtree *p;

if (sym == NULL__null)
  return;
if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
    && sym->n.sym->attr.flavor == FL_PROCEDURE)
  vec_push (candidates, candidates_len, sym->name);

p = sym->left;
if (p)
  lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);

p = sym->right;
if (p)
  lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
2962}


2965/* Lookup function FN fuzzily, taking names in SYMROOT into account.  */

2967const char*
2968gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
2969{
char **candidates = NULL__null;
size_t candidates_len = 0;
lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
return gfc_closest_fuzzy_match (fn, candidates);
2974}


2977/* Resolve a procedure call not known to be generic nor specific.  */

2979static bool
2980resolve_unknown_f (gfc_expr *expr)
2981{
gfc_symbol *sym;
gfc_typespec *ts;

sym = expr->symtree->n.sym;

if (sym->attr.dummy)
  {
    sym->attr.proc = PROC_DUMMY;
    expr->value.function.name = sym->name;
    goto set_type;
  }

/* See if we have an intrinsic function reference.  */

if (gfc_is_intrinsic (sym, 0, expr->where))
  {
    if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
return true;
    return false;
  }

/* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr.  */
/* Intrinsics were handled above, only non-intrinsics left here.  */
if (sym->attr.flavor == FL_PROCEDURE
    && sym->attr.implicit_type
    && sym->ns
    && sym->ns->has_implicit_none_export)
  {
 gfc_error ("Missing explicit declaration with EXTERNAL attribute "
     "for symbol %qs at %L", sym->name, &sym->declared_at);
 sym->error = 1;
 return false;
  }

/* The reference is to an external name.  */

sym->attr.proc = PROC_EXTERNAL;
expr->value.function.name = sym->name;
expr->value.function.esym = expr->symtree->n.sym;

if (sym->as != NULL__null)
  expr->rank = sym->as->rank;

/* Type of the expression is either the type of the symbol or the
   default type of the symbol.  */

3028set_type:
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);

if (sym->ts.type != BT_UNKNOWN)
  expr->ts = sym->ts;
else
  {
    ts = gfc_get_default_type (sym->name, sym->ns);

    if (ts->type == BT_UNKNOWN)
{
 const char *guessed
   = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
 if (guessed)
   gfc_error ("Function %qs at %L has no IMPLICIT type"
       "; did you mean %qs?",
       sym->name, &expr->where, guessed);
 else
   gfc_error ("Function %qs at %L has no IMPLICIT type",
       sym->name, &expr->where);
 return false;
}
    else
expr->ts = *ts;
  }

return true;
3055}


3058/* Return true, if the symbol is an external procedure.  */
3059static bool
3060is_external_proc (gfc_symbol *sym)
3061{
if (!sym->attr.dummy && !sym->attr.contained
&& !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.proc_pointer
&& !sym->attr.use_assoc
&& sym->name)
  return true;

return false;
3071}


3074/* Figure out if a function reference is pure or not.  Also set the name
 of the function for a potential error message.  Return nonzero if the
 function is PURE, zero if not.  */
3077static int
3078pure_stmt_function (gfc_expr *, gfc_symbol *);

3080int
3081gfc_pure_function (gfc_expr *e, const char **name)
3082{
int pure;
gfc_component *comp;

*name = NULL__null;

if (e->symtree != NULL__null
      && e->symtree->n.sym != NULL__null
      && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
  return pure_stmt_function (e, e->symtree->n.sym);

comp = gfc_get_proc_ptr_comp (e);
if (comp)
  {
    pure = gfc_pure (comp->ts.interface);
    *name = comp->name;
  }
else if (e->value.function.esym)
  {
    pure = gfc_pure (e->value.function.esym);
    *name = e->value.function.esym->name;
  }
else if (e->value.function.isym)
  {
    pure = e->value.function.isym->pure
    || e->value.function.isym->elemental;
    *name = e->value.function.isym->name;
  }
else
  {
    /* Implicit functions are not pure.  */
    pure = 0;
    *name = e->value.function.name;
  }

return pure;
3118}


3121/* Check if the expression is a reference to an implicitly pure function.  */

3123int
3124gfc_implicit_pure_function (gfc_expr *e)
3125{
gfc_component *comp = gfc_get_proc_ptr_comp (e);
if (comp)
  return gfc_implicit_pure (comp->ts.interface);
else if (e->value.function.esym)
  return gfc_implicit_pure (e->value.function.esym);
else
  return 0;
3133}


3136static bool
3137impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
 int *f ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3139{
const char *name;

/* Don't bother recursing into other statement functions
   since they will be checked individually for purity.  */
if (e->expr_type != EXPR_FUNCTION
|| !e->symtree
|| e->symtree->n.sym == sym
|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
  return false;

return gfc_pure_function (e, &name) ? false : true;
3151}


3154static int
3155pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3156{
return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3158}


3161/* Check if an impure function is allowed in the current context. */

3163static bool check_pure_function (gfc_expr *e)
3164{
const char *name = NULL__null;
if (!gfc_pure_function (e, &name) && name)
  {
    if (forall_flag)
{
 gfc_error ("Reference to impure function %qs at %L inside a "
     "FORALL %s", name, &e->where,
     forall_flag == 2 ? "mask" : "block");
 return false;
}
    else if (gfc_do_concurrent_flag)
{
 gfc_error ("Reference to impure function %qs at %L inside a "
     "DO CONCURRENT %s", name, &e->where,
     gfc_do_concurrent_flag == 2 ? "mask" : "block");
 return false;
}
    else if (gfc_pure (NULL__null))
{
 gfc_error ("Reference to impure function %qs at %L "
     "within a PURE procedure", name, &e->where);
 return false;
}
    if (!gfc_implicit_pure_function (e))
gfc_unset_implicit_pure (NULL__null);
  }
return true;
3192}


3195/* Update current procedure's array_outer_dependency flag, considering
 a call to procedure SYM.  */

3198static void
3199update_current_proc_array_outer_dependency (gfc_symbol *sym)
3200{
/* Check to see if this is a sibling function that has not yet
   been resolved.  */
gfc_namespace *sibling = gfc_current_ns->sibling;
for (; sibling; sibling = sibling->sibling)
  {
    if (sibling->proc_name == sym)
{
 gfc_resolve (sibling);
 break;
}
  }

/* If SYM has references to outer arrays, so has the procedure calling
   SYM.  If SYM is a procedure pointer, we can assume the worst.  */
if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
    && gfc_current_ns->proc_name)
  gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3218}


3221/* Resolve a function call, which means resolving the arguments, then figuring
 out which entity the name refers to.  */

3224static bool
3225resolve_function (gfc_expr *expr)
3226{
gfc_actual_arglist *arg;
gfc_symbol *sym;
bool t;
int temp;
procedure_type p = PROC_INTRINSIC;
bool no_formal_args;

sym = NULL__null;
1
Null pointer value stored to 'sym'→
if (expr->symtree)
2
←
Assuming field 'symtree' is null→
3
←
Taking false branch→
  sym = expr->symtree->n.sym;

/* If this is a procedure pointer component, it has already been resolved.  */
if (gfc_is_proc_ptr_comp (expr))
4
←
Assuming the condition is false→
  return true;

/* Avoid re-resolving the arguments of caf_get, which can lead to inserting
   another caf_get.  */
if (sym4.1
'sym' is null
 && sym->attr.intrinsic
    && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
 || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
  return true;

if (expr->ref)
5
←
Assuming field 'ref' is null→
  {
    gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
 &expr->where);
    return false;
  }

if (sym5.1
'sym' is null
 && sym->attr.intrinsic
    && !gfc_resolve_intrinsic (sym, &expr->where))
  return false;

if (sym5.2
'sym' is null
 && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
  {
    gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
    return false;
  }

/* If this is a deferred TBP with an abstract interface (which may
   of course be referenced), expr->value.function.esym will be set.  */
if (sym5.3
'sym' is null
 && sym->attr.abstract && !expr->value.function.esym)
  {
    gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
 sym->name, &expr->where);
    return false;
  }

/* If this is a deferred TBP with an abstract interface, its result
   cannot be an assumed length character (F2003: C418).  */
if (sym5.4
'sym' is null
 && sym->attr.abstract && sym->attr.function
    && sym->result->ts.u.cl
    && sym->result->ts.u.cl->length == NULL__null
    && !sym->result->ts.deferred)
  {
    gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
 "character length result (F2008: C418)", sym->name,
 &sym->declared_at);
    return false;
  }

/* Switch off assumed size checking and do this again for certain kinds
   of procedure, once the procedure itself is resolved.  */
need_full_assumed_size++;

if (expr->symtree && expr->symtree->n.sym)
6
←
Assuming field 'symtree' is null→
  p = expr->symtree->n.sym->attr.proc;

if (expr->value.function.isym && expr->value.function.isym->inquiry)
7
←
Assuming field 'isym' is null→
  inquiry_argument = true;
no_formal_args = sym7.1
'sym' is null
 && is_external_proc (sym)
		       && gfc_sym_get_dummy_args (sym) == NULL__null;

if (!resolve_actual_arglist (expr->value.function.actual,
8
←
Assuming the condition is false→
9
←
Taking false branch→
	       p, no_formal_args))
  {
    inquiry_argument = false;
    return false;
  }

inquiry_argument = false;

/* Resume assumed_size checking.  */
need_full_assumed_size--;

/* If the procedure is external, check for usage.  */
if (sym9.1
'sym' is null
 && is_external_proc (sym))
  resolve_global_procedure (sym, &expr->where, 0);

if (sym9.2
'sym' is null
 && sym->ts.type == BT_CHARACTER
    && sym->ts.u.cl
    && sym->ts.u.cl->length == NULL__null
    && !sym->attr.dummy
    && !sym->ts.deferred
    && expr->value.function.esym == NULL__null
    && !sym->attr.contained)
  {
    /* Internal procedures are taken care of in resolve_contained_fntype.  */
    gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
 "be used at %L since it is not a dummy argument",
 sym->name, &expr->where);
    return false;
  }

/* See if function is already resolved.  */

if (expr->value.function.name != NULL__null
10
←
Assuming field 'name' is not equal to NULL→
    || expr->value.function.isym != NULL__null)
  {
    if (expr->ts.type == BT_UNKNOWN)
11
←
Assuming field 'type' is equal to BT_UNKNOWN→
12
←
Taking true branch→
expr->ts = sym->ts;
13
←
Forming reference to null pointer
    t = true;
  }
else
  {
    /* Apply the rules of section 14.1.2.  */

    switch (procedure_kind (sym))
{
case PTYPE_GENERIC:
 t = resolve_generic_f (expr);
 break;

case PTYPE_SPECIFIC:
 t = resolve_specific_f (expr);
 break;

case PTYPE_UNKNOWN:
 t = resolve_unknown_f (expr);
 break;

default:
 gfc_internal_error ("resolve_function(): bad function type");
}
  }

/* If the expression is still a function (it might have simplified),
   then we check to see if we are calling an elemental function.  */

if (expr->expr_type != EXPR_FUNCTION)
  return t;

/* Walk the argument list looking for invalid BOZ.  */
for (arg = expr->value.function.actual; arg; arg = arg->next)
  if (arg->expr && arg->expr->ts.type == BT_BOZ)
    {
gfc_error ("A BOZ literal constant at %L cannot appear as an "
   "actual argument in a function reference",
   &arg->expr->where);
return false;
    }

temp = need_full_assumed_size;
need_full_assumed_size = 0;

if (!resolve_elemental_actual (expr, NULL__null))
  return false;

if (omp_workshare_flag
    && expr->value.function.esym
    && ! gfc_elemental (expr->value.function.esym))
  {
    gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
 "in WORKSHARE construct", expr->value.function.esym->name,
 &expr->where);
    t = false;
  }

3395#define GENERIC_ID expr->value.function.isym->id
else if (expr->value.function.actual != NULL__null
  && expr->value.function.isym != NULL__null
  && GENERIC_ID != GFC_ISYM_LBOUND
  && GENERIC_ID != GFC_ISYM_LCOBOUND
  && GENERIC_ID != GFC_ISYM_UCOBOUND
  && GENERIC_ID != GFC_ISYM_LEN
  && GENERIC_ID != GFC_ISYM_LOC
  && GENERIC_ID != GFC_ISYM_C_LOC
  && GENERIC_ID != GFC_ISYM_PRESENT)
  {
    /* Array intrinsics must also have the last upper bound of an
assumed size array argument.  UBOUND and SIZE have to be
excluded from the check if the second argument is anything
than a constant.  */

    for (arg = expr->value.function.actual; arg; arg = arg->next)
{
 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
     && arg == expr->value.function.actual
     && arg->next != NULL__null && arg->next->expr)
   {
     if (arg->next->expr->expr_type != EXPR_CONSTANT)
break;

     if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
break;

     if ((int)mpz_get_si__gmpz_get_si (arg->next->expr->value.integer)
	< arg->expr->rank)
break;
   }

 if (arg->expr != NULL__null
     && arg->expr->rank > 0
     && resolve_assumed_size_actual (arg->expr))
   return false;
}
  }
3434#undef GENERIC_ID

need_full_assumed_size = temp;

if (!check_pure_function(expr))
  t = false;

/* Functions without the RECURSIVE attribution are not allowed to
 * call themselves.  */
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
  {
    gfc_symbol *esym;
    esym = expr->value.function.esym;

    if (is_illegal_recursion (esym, gfc_current_ns))
    {
if (esym->attr.entry && esym->ns->entries)
 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
     " function %qs is not RECURSIVE",
     esym->name, &expr->where, esym->ns->entries->sym->name);
else
 gfc_error ("Function %qs at %L cannot be called recursively, as it"
     " is not RECURSIVE", esym->name, &expr->where);

t = false;
    }
  }

/* Character lengths of use associated functions may contains references to
   symbols not referenced from the current program unit otherwise.  Make sure
   those symbols are marked as referenced.  */

if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
    && expr->value.function.esym->attr.use_assoc)
  {
    gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
  }

/* Make sure that the expression has a typespec that works.  */
if (expr->ts.type == BT_UNKNOWN)
  {
    if (expr->symtree->n.sym->result
   && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
   && !expr->symtree->n.sym->result->attr.proc_pointer)
expr->ts = expr->symtree->n.sym->result->ts;
  }

/* These derived types with an incomplete namespace, arising from use
   association, cause gfc_get_derived_vtab to segfault. If the function
   namespace does not suffice, something is badly wrong.  */
if (expr->ts.type == BT_DERIVED
    && !expr->ts.u.derived->ns->proc_name)
  {
    gfc_symbol *der;
    gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
    if (der)
{
 expr->ts.u.derived->refs--;
 expr->ts.u.derived = der;
 der->refs++;
}
    else
expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
  }

if (!expr->ref && !expr->value.function.isym)
  {
    if (expr->value.function.esym)
update_current_proc_array_outer_dependency (expr->value.function.esym);
    else
update_current_proc_array_outer_dependency (sym);
  }
else if (expr->ref)
  /* typebound procedure: Assume the worst.  */
  gfc_current_ns->proc_name->attr.array_outer_dependency = 1;

if (expr->value.function.esym
    && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
  gfc_warning (OPT_Wdeprecated_declarations,
 "Using function %qs at %L is deprecated",
 sym->name, &expr->where);
return t;
3516}


3519/************* Subroutine resolution *************/

3521static bool
3522pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3523{
if (gfc_pure (sym))
  return true;

if (forall_flag)
  {
    gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
 name, loc);
    return false;
  }
else if (gfc_do_concurrent_flag)
  {
    gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
 "PURE", name, loc);
    return false;
  }
else if (gfc_pure (NULL__null))
  {
    gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
    return false;
  }

gfc_unset_implicit_pure (NULL__null);
return true;
3547}


3550static match
3551resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3552{
gfc_symbol *s;

if (sym->attr.generic)
  {
    s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
    if (s != NULL__null)
{
 c->resolved_sym = s;
 if (!pure_subroutine (s, s->name, &c->loc))
   return MATCH_ERROR;
 return MATCH_YES;
}

    /* TODO: Need to search for elemental references in generic interface.  */
  }

if (sym->attr.intrinsic)
  return gfc_intrinsic_sub_interface (c, 0);

return MATCH_NO;
3573}


3576static bool
3577resolve_generic_s (gfc_code *c)
3578{
gfc_symbol *sym;
match m;

sym = c->symtree->n.sym;

for (;;)
  {
    m = resolve_generic_s0 (c, sym);
    if (m == MATCH_YES)
return true;
    else if (m == MATCH_ERROR)
return false;

3592generic:
    if (sym->ns->parent == NULL__null)
break;
    gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

    if (sym == NULL__null)
break;
    if (!generic_sym (sym))
goto generic;
  }

/* Last ditch attempt.  See if the reference is to an intrinsic
   that possesses a matching interface.  14.1.2.4  */
sym = c->symtree->n.sym;

if (!gfc_is_intrinsic (sym, 1, c->loc))
  {
    gfc_error ("There is no specific subroutine for the generic %qs at %L",
 sym->name, &c->loc);
    return false;
  }

m = gfc_intrinsic_sub_interface (c, 0);
if (m == MATCH_YES)
  return true;
if (m == MATCH_NO)
  gfc_error ("Generic subroutine %qs at %L is not consistent with an "
      "intrinsic subroutine interface", sym->name, &c->loc);

return false;
3622}


3625/* Resolve a subroutine call known to be specific.  */

3627static match
3628resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3629{
match m;

if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
  {
    if (sym->attr.dummy)
{
 sym->attr.proc = PROC_DUMMY;
 goto found;
}

    sym->attr.proc = PROC_EXTERNAL;
    goto found;
  }

if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
  goto found;

if (sym->attr.intrinsic)
  {
    m = gfc_intrinsic_sub_interface (c, 1);
    if (m == MATCH_YES)
return MATCH_YES;
    if (m == MATCH_NO)
gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
   "with an intrinsic", sym->name, &c->loc);

    return MATCH_ERROR;
  }

return MATCH_NO;

3661found:
gfc_procedure_use (sym, &c->ext.actual, &c->loc);

c->resolved_sym = sym;
if (!pure_subroutine (sym, sym->name, &c->loc))
  return MATCH_ERROR;

return MATCH_YES;
3669}


3672static bool
3673resolve_specific_s (gfc_code *c)
3674{
gfc_symbol *sym;
match m;

sym = c->symtree->n.sym;

for (;;)
  {
    m = resolve_specific_s0 (c, sym);
    if (m == MATCH_YES)
return true;
    if (m == MATCH_ERROR)
return false;

    if (sym->ns->parent == NULL__null)
break;

    gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

    if (sym == NULL__null)
break;
  }

sym = c->symtree->n.sym;
gfc_error ("Unable to resolve the specific subroutine %qs at %L",
    sym->name, &c->loc);

return false;
3702}


3705/* Resolve a subroutine call not known to be generic nor specific.  */

3707static bool
3708resolve_unknown_s (gfc_code *c)
3709{
gfc_symbol *sym;

sym = c->symtree->n.sym;

if (sym->attr.dummy)
  {
    sym->attr.proc = PROC_DUMMY;
    goto found;
  }

/* See if we have an intrinsic function reference.  */

if (gfc_is_intrinsic (sym, 1, c->loc))
  {
    if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
return true;
    return false;
  }

/* The reference is to an external name.  */

3731found:
gfc_procedure_use (sym, &c->ext.actual, &c->loc);

c->resolved_sym = sym;

return pure_subroutine (sym, sym->name, &c->loc);
3737}


3740/* Resolve a subroutine call.  Although it was tempting to use the same code
 for functions, subroutines and functions are stored differently and this
 makes things awkward.  */

3744static bool
3745resolve_call (gfc_code *c)
3746{
bool t;
procedure_type ptype = PROC_INTRINSIC;
gfc_symbol *csym, *sym;
bool no_formal_args;

csym = c->symtree ? c->symtree->n.sym : NULL__null;

if (csym && csym->ts.type != BT_UNKNOWN)
  {
    gfc_error ("%qs at %L has a type, which is not consistent with "
 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
    return false;
  }

if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
  {
    gfc_symtree *st;
    gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
    sym = st ? st->n.sym : NULL__null;
    if (sym && csym != sym
     && sym->ns == gfc_current_ns
     && sym->attr.flavor == FL_PROCEDURE
     && sym->attr.contained)
{
 sym->refs++;
 if (csym->attr.generic)
   c->symtree->n.sym = sym;
 else
   c->symtree = st;
 csym = c->symtree->n.sym;
}
  }

/* If this ia a deferred TBP, c->expr1 will be set.  */
if (!c->expr1 && csym)
  {
    if (csym->attr.abstract)
{
 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
    csym->name, &c->loc);
 return false;
}

    /* Subroutines without the RECURSIVE attribution are not allowed to
call themselves.  */
    if (is_illegal_recursion (csym, gfc_current_ns))
{
 if (csym->attr.entry && csym->ns->entries)
   gfc_error ("ENTRY %qs at %L cannot be called recursively, "
       "as subroutine %qs is not RECURSIVE",
       csym->name, &c->loc, csym->ns->entries->sym->name);
 else
   gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
       "as it is not RECURSIVE", csym->name, &c->loc);

 t = false;
}
  }

/* Switch off assumed size checking and do this again for certain kinds
   of procedure, once the procedure itself is resolved.  */
need_full_assumed_size++;

if (csym)
  ptype = csym->attr.proc;

no_formal_args = csym && is_external_proc (csym)
	&& gfc_sym_get_dummy_args (csym) == NULL__null;
if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
  return false;

/* Resume assumed_size checking.  */
need_full_assumed_size--;

/* If external, check for usage.  */
if (csym && is_external_proc (csym))
  resolve_global_procedure (csym, &c->loc, 1);

t = true;
if (c->resolved_sym == NULL__null)
  {
    c->resolved_isym = NULL__null;
    switch (procedure_kind (csym))
{
case PTYPE_GENERIC:
 t = resolve_generic_s (c);
 break;

case PTYPE_SPECIFIC:
 t = resolve_specific_s (c);
 break;

case PTYPE_UNKNOWN:
 t = resolve_unknown_s (c);
 break;

default:
 gfc_internal_error ("resolve_subroutine(): bad function type");
}
  }

/* Some checks of elemental subroutine actual arguments.  */
if (!resolve_elemental_actual (NULL__null, c))
  return false;

if (!c->expr1)
  update_current_proc_array_outer_dependency (csym);
else
  /* Typebound procedure: Assume the worst.  */
  gfc_current_ns->proc_name->attr.array_outer_dependency = 1;

if (c->resolved_sym
    && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
  gfc_warning (OPT_Wdeprecated_declarations,
 "Using subroutine %qs at %L is deprecated",
 c->resolved_sym->name, &c->loc);

return t;
3865}


3868/* Compare the shapes of two arrays that have non-NULL shapes.  If both
 op1->shape and op2->shape are non-NULL return true if their shapes
 match.  If both op1->shape and op2->shape are non-NULL return false
 if their shapes do not match.  If either op1->shape or op2->shape is
 NULL, return true.  */

3874static bool
3875compare_shapes (gfc_expr *op1, gfc_expr *op2)
3876{
bool t;
int i;

t = true;

if (op1->shape != NULL__null && op2->shape != NULL__null)
  {
    for (i = 0; i < op1->rank; i++)
{
 if (mpz_cmp__gmpz_cmp (op1->shape[i], op2->shape[i]) != 0)
  {
    gfc_error ("Shapes for operands at %L and %L are not conformable",
	&op1->where, &op2->where);
    t = false;
    break;
  }
}
  }

return t;
3897}

3899/* Convert a logical operator to the corresponding bitwise intrinsic call.
 For example A .AND. B becomes IAND(A, B).  */
3901static gfc_expr *
3902logical_to_bitwise (gfc_expr *e)
3903{
gfc_expr *tmp, *op1, *op2;
gfc_isym_id isym;
gfc_actual_arglist *args = NULL__null;

gcc_assert (e->expr_type == EXPR_OP)((void)(!(e->expr_type == EXPR_OP) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 3908, __FUNCTION__), 0 : 0));

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

switch (e->value.op.op)
  {
  case INTRINSIC_NOT:
    isym = GFC_ISYM_NOT;
    break;
  case INTRINSIC_AND:
    isym = GFC_ISYM_IAND;
    break;
  case INTRINSIC_OR:
    isym = GFC_ISYM_IOR;
    break;
  case INTRINSIC_NEQV:
    isym = GFC_ISYM_IEOR;
    break;
  case INTRINSIC_EQV:
    /* "Bitwise eqv" is just the complement of NEQV === IEOR.
Change the old expression to NEQV, which will get replaced by IEOR,
and wrap it in NOT.  */
    tmp = gfc_copy_expr (e);
    tmp->value.op.op = INTRINSIC_NEQV;
    tmp = logical_to_bitwise (tmp);
    isym = GFC_ISYM_NOT;
    op1 = tmp;
    op2 = NULL__null;
    break;
  default:
    gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
  }

/* Inherit the original operation's operands as arguments.  */
args = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
args->expr = op1;
if (op2)
  {
    args->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
    args->next->expr = op2;
  }

/* Convert the expression to a function call.  */
e->expr_type = EXPR_FUNCTION;
e->value.function.actual = args;
e->value.function.isym = gfc_intrinsic_function_by_id (isym);
e->value.function.name = e->value.function.isym->name;
e->value.function.esym = NULL__null;

/* Make up a pre-resolved function call symtree if we need to.  */
if (!e->symtree || !e->symtree->n.sym)
  {
    gfc_symbol *sym;
    gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
    sym = e->symtree->n.sym;
    sym->result = sym;
    sym->attr.flavor = FL_PROCEDURE;
    sym->attr.function = 1;
    sym->attr.elemental = 1;
    sym->attr.pure = 1;
    sym->attr.referenced = 1;
    gfc_intrinsic_symbol (sym)sym->module = gfc_get_string ("(intrinsic)");
    gfc_commit_symbol (sym);
  }

args->name = e->value.function.isym->formal->name;
if (e->value.function.isym->formal->next)
  args->next->name = e->value.function.isym->formal->next->name;

return e;
3980}

3982/* Recursively append candidate UOP to CANDIDATES.  Store the number of
 candidates in CANDIDATES_LEN.  */
3984static void
3985lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
		  char **&candidates,
		  size_t &candidates_len)
3988{
gfc_symtree *p;

if (uop == NULL__null)
  return;

/* Not sure how to properly filter here.  Use all for a start.
   n.uop.op is NULL for empty interface operators (is that legal?) disregard
   these as i suppose they don't make terribly sense.  */

if (uop->n.uop->op != NULL__null)
  vec_push (candidates, candidates_len, uop->name);

p = uop->left;
if (p)
  lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);

p = uop->right;
if (p)
  lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4008}

4010/* Lookup user-operator OP fuzzily, taking names in UOP into account.  */

4012static const char*
4013lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4014{
char **candidates = NULL__null;
size_t candidates_len = 0;
lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
return gfc_closest_fuzzy_match (op, candidates);
4019}


4022/* Callback finding an impure function as an operand to an .and. or
 .or.  expression.  Remember the last function warned about to
 avoid double warnings when recursing.  */

4026static int
4027impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
	  void *data)
4029{
gfc_expr *f = *e;
const char *name;
static gfc_expr *last = NULL__null;
bool *found = (bool *) data;

if (f->expr_type == EXPR_FUNCTION)
  {
    *found = 1;
    if (f != last && !gfc_pure_function (f, &name)
 && !gfc_implicit_pure_function (f))
{
 if (name)
   gfc_warning (OPT_Wfunction_elimination,
	 "Impure function %qs at %L might not be evaluated",
	 name, &f->where);
 else
   gfc_warning (OPT_Wfunction_elimination,
	 "Impure function at %L might not be evaluated",
	 &f->where);
}
    last = f;
  }

return 0;
4054}

4056/* Return true if TYPE is character based, false otherwise.  */

4058static int
4059is_character_based (bt type)
4060{
return type == BT_CHARACTER || type == BT_HOLLERITH;
4062}


4065/* If expression is a hollerith, convert it to character and issue a warning
 for the conversion.  */

4068static void
4069convert_hollerith_to_character (gfc_expr *e)
4070{
if (e->ts.type == BT_HOLLERITH)
  {
    gfc_typespec t;
    gfc_clear_ts (&t);
    t.type = BT_CHARACTER;
    t.kind = e->ts.kind;
    gfc_convert_type_warn (e, &t, 2, 1);
  }
4079}

4081/* Convert to numeric and issue a warning for the conversion.  */

4083static void
4084convert_to_numeric (gfc_expr *a, gfc_expr *b)
4085{
gfc_typespec t;
gfc_clear_ts (&t);
t.type = b->ts.type;
t.kind = b->ts.kind;
gfc_convert_type_warn (a, &t, 2, 1);
4091}

4093/* Resolve an operator expression node.  This can involve replacing the
 operation with a user defined function call.  */

4096static bool
4097resolve_operator (gfc_expr *e)
4098{
gfc_expr *op1, *op2;
/* One error uses 3 names; additional space for wording (also via gettext). */
char msg[3*GFC_MAX_SYMBOL_LEN63 + 1 + 50];
bool dual_locus_error;
bool t = true;

/* Resolve all subnodes-- give them types.  */

switch (e->value.op.op)
  {
  default:
    if (!gfc_resolve_expr (e->value.op.op2))
t = false;

  /* Fall through.  */

  case INTRINSIC_NOT:
  case INTRINSIC_UPLUS:
  case INTRINSIC_UMINUS:
  case INTRINSIC_PARENTHESES:
    if (!gfc_resolve_expr (e->value.op.op1))
return false;
    if (e->value.op.op1
 && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
{
 gfc_error ("BOZ literal constant at %L cannot be an operand of "
     "unary operator %qs", &e->value.op.op1->where,
     gfc_op2string (e->value.op.op));
 return false;
}
    break;
  }

/* Typecheck the new node.  */

op1 = e->value.op.op1;
op2 = e->value.op.op2;
if (op1 == NULL__null && op2 == NULL__null)
  return false;
/* Error out if op2 did not resolve. We already diagnosed op1.  */
if (t == false)
  return false;

dual_locus_error = false;

/* op1 and op2 cannot both be BOZ.  */
if (op1 && op1->ts.type == BT_BOZ
    && op2 && op2->ts.type == BT_BOZ)
  {
    gfc_error ("Operands at %L and %L cannot appear as operands of "
 "binary operator %qs", &op1->where, &op2->where,
 gfc_op2string (e->value.op.op));
    return false;
  }

if ((op1 && op1->expr_type == EXPR_NULL)
    || (op2 && op2->expr_type == EXPR_NULL))
  {
    snprintf (msg, sizeof (msg),
_("Invalid context for NULL() pointer at %%L")gettext ("Invalid context for NULL() pointer at %%L"));
    goto bad_op;
  }

switch (e->value.op.op)
  {
  case INTRINSIC_UPLUS:
  case INTRINSIC_UMINUS:
    if (op1->ts.type == BT_INTEGER
 || op1->ts.type == BT_REAL
 || op1->ts.type == BT_COMPLEX)
{
 e->ts = op1->ts;
 break;
}

    snprintf (msg, sizeof (msg),
_("Operand of unary numeric operator %%<%s%%> at %%L is %s")gettext ("Operand of unary numeric operator %%<%s%%> at %%L is %s"
),
gfc_op2string (e->value.op.op), gfc_typename (e));
    goto bad_op;

  case INTRINSIC_PLUS:
  case INTRINSIC_MINUS:
  case INTRINSIC_TIMES:
  case INTRINSIC_DIVIDE:
  case INTRINSIC_POWER:
    if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
 gfc_type_convert_binary (e, 1);
 break;
}

    if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
snprintf (msg, sizeof (msg),
  _("Unexpected derived-type entities in binary intrinsic "gettext ("Unexpected derived-type entities in binary intrinsic "
 "numeric operator %%<%s%%> at %%L")
  "numeric operator %%<%s%%> at %%L")gettext ("Unexpected derived-type entities in binary intrinsic "
 "numeric operator %%<%s%%> at %%L"),
      gfc_op2string (e->value.op.op));
    else
snprintf (msg, sizeof(msg),
  _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s")gettext ("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"
),
  gfc_op2string (e->value.op.op), gfc_typename (op1),
      gfc_typename (op2));
    goto bad_op;

  case INTRINSIC_CONCAT:
    if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
 && op1->ts.kind == op2->ts.kind)
{
 e->ts.type = BT_CHARACTER;
 e->ts.kind = op1->ts.kind;
 break;
}

    snprintf (msg, sizeof (msg),
_("Operands of string concatenation operator at %%L are %s/%s")gettext ("Operands of string concatenation operator at %%L are %s/%s"
),
gfc_typename (op1), gfc_typename (op2));
    goto bad_op;

  case INTRINSIC_AND:
  case INTRINSIC_OR:
  case INTRINSIC_EQV:
  case INTRINSIC_NEQV:
    if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
{
 e->ts.type = BT_LOGICAL;
 e->ts.kind = gfc_kind_max (op1, op2);
 if (op1->ts.kind < e->ts.kind)
   gfc_convert_type (op1, &e->ts, 2);
 else if (op2->ts.kind < e->ts.kind)
   gfc_convert_type (op2, &e->ts, 2);

 if (flag_frontend_optimizeglobal_options.x_flag_frontend_optimize &&
   (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
   {
     /* Warn about short-circuiting
        with impure function as second operand.  */
     bool op2_f = false;
     gfc_expr_walker (&op2, impure_function_callback, &op2_f);
   }
 break;
}

    /* Logical ops on integers become bitwise ops with -fdec.  */
    else if (flag_decglobal_options.x_flag_dec
      && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
{
 e->ts.type = BT_INTEGER;
 e->ts.kind = gfc_kind_max (op1, op2);
 if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
   gfc_convert_type (op1, &e->ts, 1);
 if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
   gfc_convert_type (op2, &e->ts, 1);
 e = logical_to_bitwise (e);
 goto simplify_op;
}

    snprintf (msg, sizeof (msg),
_("Operands of logical operator %%<%s%%> at %%L are %s/%s")gettext ("Operands of logical operator %%<%s%%> at %%L are %s/%s"
),
gfc_op2string (e->value.op.op), gfc_typename (op1),
gfc_typename (op2));

    goto bad_op;

  case INTRINSIC_NOT:
    /* Logical ops on integers become bitwise ops with -fdec.  */
    if (flag_decglobal_options.x_flag_dec && op1->ts.type == BT_INTEGER)
{
 e->ts.type = BT_INTEGER;
 e->ts.kind = op1->ts.kind;
 e = logical_to_bitwise (e);
 goto simplify_op;
}

    if (op1->ts.type == BT_LOGICAL)
{
 e->ts.type = BT_LOGICAL;
 e->ts.kind = op1->ts.kind;
 break;
}

    snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s")gettext ("Operand of .not. operator at %%L is %s"),
gfc_typename (op1));
    goto bad_op;

  case INTRINSIC_GT:
  case INTRINSIC_GT_OS:
  case INTRINSIC_GE:
  case INTRINSIC_GE_OS:
  case INTRINSIC_LT:
  case INTRINSIC_LT_OS:
  case INTRINSIC_LE:
  case INTRINSIC_LE_OS:
    if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
 strcpy (msg, _("COMPLEX quantities cannot be compared at %L")gettext ("COMPLEX quantities cannot be compared at %L"));
 goto bad_op;
}

    /* Fall through.  */

  case INTRINSIC_EQ:
  case INTRINSIC_EQ_OS:
  case INTRINSIC_NE:
  case INTRINSIC_NE_OS:

    if (flag_decglobal_options.x_flag_dec
 && is_character_based (op1->ts.type)
 && is_character_based (op2->ts.type))
{
 convert_hollerith_to_character (op1);
 convert_hollerith_to_character (op2);
}

    if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
 && op1->ts.kind == op2->ts.kind)
{
 e->ts.type = BT_LOGICAL;
 e->ts.kind = gfc_default_logical_kind;
 break;
}

    /* If op1 is BOZ, then op2 is not!.  Try to convert to type of op2.  */
    if (op1->ts.type == BT_BOZ)
{
 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear ""BOZ literal constant near %L cannot appear " "as an operand of a relational operator"
	       "as an operand of a relational operator")"BOZ literal constant near %L cannot appear " "as an operand of a relational operator",
	       &op1->where))
   return false;

 if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
   return false;

 if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
   return false;
}

    /* If op2 is BOZ, then op1 is not!.  Try to convert to type of op2. */
    if (op2->ts.type == BT_BOZ)
{
 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear""BOZ literal constant near %L cannot appear" " as an operand of a relational operator"
	       " as an operand of a relational operator")"BOZ literal constant near %L cannot appear" " as an operand of a relational operator",
		&op2->where))
   return false;

 if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
   return false;

 if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
   return false;
}
    if (flag_decglobal_options.x_flag_dec
 && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
convert_to_numeric (op1, op2);

    if (flag_decglobal_options.x_flag_dec
 && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
convert_to_numeric (op2, op1);

    if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
 gfc_type_convert_binary (e, 1);

 e->ts.type = BT_LOGICAL;
 e->ts.kind = gfc_default_logical_kind;

 if (warn_compare_realsglobal_options.x_warn_compare_reals)
   {
     gfc_intrinsic_op op = e->value.op.op;

     /* Type conversion has made sure that the types of op1 and op2
 agree, so it is only necessary to check the first one.   */
     if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
  && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
      || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
{
  const char *msg;

  if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
    msg = G_("Equality comparison for %s at %L")"Equality comparison for %s at %L";
  else
    msg = G_("Inequality comparison for %s at %L")"Inequality comparison for %s at %L";

  gfc_warning (OPT_Wcompare_reals, msg,
	       gfc_typename (op1), &op1->where);
}
   }

 break;
}

    if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
snprintf (msg, sizeof (msg),
  _("Logicals at %%L must be compared with %s instead of %s")gettext ("Logicals at %%L must be compared with %s instead of %s"
),
  (e->value.op.op == INTRINSIC_EQ
   || e->value.op.op == INTRINSIC_EQ_OS)
  ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
    else
snprintf (msg, sizeof (msg),
  _("Operands of comparison operator %%<%s%%> at %%L are %s/%s")gettext ("Operands of comparison operator %%<%s%%> at %%L are %s/%s"
),
  gfc_op2string (e->value.op.op), gfc_typename (op1),
  gfc_typename (op2));

    goto bad_op;

  case INTRINSIC_USER:
    if (e->value.op.uop->op == NULL__null)
{
 const char *name = e->value.op.uop->name;
 const char *guessed;
 guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
 if (guessed)
   snprintf (msg, sizeof (msg),
      _("Unknown operator %%<%s%%> at %%L; did you mean "gettext ("Unknown operator %%<%s%%> at %%L; did you mean "
 "%%<%s%%>?")
	"%%<%s%%>?")gettext ("Unknown operator %%<%s%%> at %%L; did you mean "
 "%%<%s%%>?"), name, guessed);
 else
   snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L")gettext ("Unknown operator %%<%s%%> at %%L"),
      name);
}
    else if (op2 == NULL__null)
snprintf (msg, sizeof (msg),
  _("Operand of user operator %%<%s%%> at %%L is %s")gettext ("Operand of user operator %%<%s%%> at %%L is %s"
),
  e->value.op.uop->name, gfc_typename (op1));
    else
{
 snprintf (msg, sizeof (msg),
    _("Operands of user operator %%<%s%%> at %%L are %s/%s")gettext ("Operands of user operator %%<%s%%> at %%L are %s/%s"
),
    e->value.op.uop->name, gfc_typename (op1),
    gfc_typename (op2));
 e->value.op.uop->op->sym->attr.referenced = 1;
}

    goto bad_op;

  case INTRINSIC_PARENTHESES:
    e->ts = op1->ts;
    if (e->ts.type == BT_CHARACTER)
e->ts.u.cl = op1->ts.u.cl;
    break;

  default:
    gfc_internal_error ("resolve_operator(): Bad intrinsic");
  }

/* Deal with arrayness of an operand through an operator.  */

switch (e->value.op.op)
  {
  case INTRINSIC_PLUS:
  case INTRINSIC_MINUS:
  case INTRINSIC_TIMES:
  case INTRINSIC_DIVIDE:
  case INTRINSIC_POWER:
  case INTRINSIC_CONCAT:
  case INTRINSIC_AND:
  case INTRINSIC_OR:
  case INTRINSIC_EQV:
  case INTRINSIC_NEQV:
  case INTRINSIC_EQ:
  case INTRINSIC_EQ_OS:
  case INTRINSIC_NE:
  case INTRINSIC_NE_OS:
  case INTRINSIC_GT:
  case INTRINSIC_GT_OS:
  case INTRINSIC_GE:
  case INTRINSIC_GE_OS:
  case INTRINSIC_LT:
  case INTRINSIC_LT_OS:
  case INTRINSIC_LE:
  case INTRINSIC_LE_OS:

    if (op1->rank == 0 && op2->rank == 0)
e->rank = 0;

    if (op1->rank == 0 && op2->rank != 0)
{
 e->rank = op2->rank;

 if (e->shape == NULL__null)
   e->shape = gfc_copy_shape (op2->shape, op2->rank);
}

    if (op1->rank != 0 && op2->rank == 0)
{
 e->rank = op1->rank;

 if (e->shape == NULL__null)
   e->shape = gfc_copy_shape (op1->shape, op1->rank);
}

    if (op1->rank != 0 && op2->rank != 0)
{
 if (op1->rank == op2->rank)
   {
     e->rank = op1->rank;
     if (e->shape == NULL__null)
{
  t = compare_shapes (op1, op2);
  if (!t)
    e->shape = NULL__null;
  else
    e->shape = gfc_copy_shape (op1->shape, op1->rank);
}
   }
 else
   {
     /* Allow higher level expressions to work.  */
     e->rank = 0;

     /* Try user-defined operators, and otherwise throw an error.  */
     dual_locus_error = true;
     snprintf (msg, sizeof (msg),
	_("Inconsistent ranks for operator at %%L and %%L")gettext ("Inconsistent ranks for operator at %%L and %%L"));
     goto bad_op;
   }
}

    break;

  case INTRINSIC_PARENTHESES:
  case INTRINSIC_NOT:
  case INTRINSIC_UPLUS:
  case INTRINSIC_UMINUS:
    /* Simply copy arrayness attribute */
    e->rank = op1->rank;

    if (e->shape == NULL__null)
e->shape = gfc_copy_shape (op1->shape, op1->rank);

    break;

  default:
    break;
  }

4532simplify_op:

/* Attempt to simplify the expression.  */
if (t)
  {
    t = gfc_simplify_expr (e, 0);
    /* Some calls do not succeed in simplification and return false
even though there is no error; e.g. variable references to
PARAMETER arrays.  */
    if (!gfc_is_constant_expr (e))
t = true;
  }
return t;

4546bad_op:

{
  match m = gfc_extend_expr (e);
  if (m == MATCH_YES)
    return true;
  if (m == MATCH_ERROR)
    return false;
}

if (dual_locus_error)
  gfc_error (msg, &op1->where, &op2->where);
else
  gfc_error (msg, &e->where);

return false;
4562}


4565/************** Array resolution subroutines **************/

4567enum compare_result
4568{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };

4570/* Compare two integer expressions.  */

4572static compare_result
4573compare_bound (gfc_expr *a, gfc_expr *b)
4574{
int i;

if (a == NULL__null || a->expr_type != EXPR_CONSTANT
    || b == NULL__null || b->expr_type != EXPR_CONSTANT)
  return CMP_UNKNOWN;

/* If either of the types isn't INTEGER, we must have
   raised an error earlier.  */

if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
  return CMP_UNKNOWN;

i = mpz_cmp__gmpz_cmp (a->value.integer, b->value.integer);

if (i < 0)
  return CMP_LT;
if (i > 0)
  return CMP_GT;
return CMP_EQ;
4594}


4597/* Compare an integer expression with an integer.  */

4599static compare_result
4600compare_bound_int (gfc_expr *a, int b)
4601{
int i;

if (a == NULL__null
    || a->expr_type != EXPR_CONSTANT
    || a->ts.type != BT_INTEGER)
  return CMP_UNKNOWN;

i = mpz_cmp_si (a->value.integer, b)(__builtin_constant_p ((b) >= 0) && (b) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (b)))
 && ((static_cast<unsigned long> (b))) == 0 ? (
(a->value.integer)->_mp_size < 0 ? -1 : (a->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (a->value.integer
,(static_cast<unsigned long> (b)))) : __gmpz_cmp_si (a->
value.integer,b));

if (i < 0)
  return CMP_LT;
if (i > 0)
  return CMP_GT;
return CMP_EQ;
4616}


4619/* Compare an integer expression with a mpz_t.  */

4621static compare_result
4622compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4623{
int i;

if (a == NULL__null
    || a->expr_type != EXPR_CONSTANT
    || a->ts.type != BT_INTEGER)
  return CMP_UNKNOWN;

i = mpz_cmp__gmpz_cmp (a->value.integer, b);

if (i < 0)
  return CMP_LT;
if (i > 0)
  return CMP_GT;
return CMP_EQ;
4638}


4641/* Compute the last value of a sequence given by a triplet.
 Return 0 if it wasn't able to compute the last value, or if the
 sequence if empty, and 1 otherwise.  */

4645static int
4646compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
		gfc_expr *stride, mpz_t last)
4648{
mpz_t rem;

if (start == NULL__null || start->expr_type != EXPR_CONSTANT
    || end == NULL__null || end->expr_type != EXPR_CONSTANT
    || (stride != NULL__null && stride->expr_type != EXPR_CONSTANT))
  return 0;

if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
    || (stride != NULL__null && stride->ts.type != BT_INTEGER))
  return 0;

if (stride == NULL__null || compare_bound_int (stride, 1) == CMP_EQ)
  {
    if (compare_bound (start, end) == CMP_GT)
return 0;
    mpz_set__gmpz_set (last, end->value.integer);
    return 1;
  }

if (compare_bound_int (stride, 0) == CMP_GT)
  {
    /* Stride is positive */
    if (mpz_cmp__gmpz_cmp (start->value.integer, end->value.integer) > 0)
return 0;
  }
else
  {
    /* Stride is negative */
    if (mpz_cmp__gmpz_cmp (start->value.integer, end->value.integer) < 0)
return 0;
  }

mpz_init__gmpz_init (rem);
mpz_sub__gmpz_sub (rem, end->value.integer, start->value.integer);
mpz_tdiv_r__gmpz_tdiv_r (rem, rem, stride->value.integer);
mpz_sub__gmpz_sub (last, end->value.integer, rem);
mpz_clear__gmpz_clear (rem);

return 1;
4688}


4691/* Compare a single dimension of an array reference to the array
 specification.  */

4694static bool
4695check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4696{
mpz_t last_value;

if (ar->dimen_type[i] == DIMEN_STAR)
  {
    gcc_assert (ar->stride[i] == NULL)((void)(!(ar->stride[i] == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 4701, __FUNCTION__), 0 : 0));
    /* This implies [*] as [*:] and [*:3] are not possible.  */
    if (ar->start[i] == NULL__null)
{
 gcc_assert (ar->end[i] == NULL)((void)(!(ar->end[i] == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 4705, __FUNCTION__), 0 : 0));
 return true;
}
  }

4710/* Given start, end and stride values, calculate the minimum and
 maximum referenced indexes.  */

switch (ar->dimen_type[i])
  {
  case DIMEN_VECTOR:
  case DIMEN_THIS_IMAGE:
    break;

  case DIMEN_STAR:
  case DIMEN_ELEMENT:
    if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
{
 if (i < as->rank)
   gfc_warning (0, "Array reference at %L is out of bounds "
	 "(%ld < %ld) in dimension %d", &ar->c_where[i],
	 mpz_get_si__gmpz_get_si (ar->start[i]->value.integer),
	 mpz_get_si__gmpz_get_si (as->lower[i]->value.integer), i+1);
 else
   gfc_warning (0, "Array reference at %L is out of bounds "
	 "(%ld < %ld) in codimension %d", &ar->c_where[i],
	 mpz_get_si__gmpz_get_si (ar->start[i]->value.integer),
	 mpz_get_si__gmpz_get_si (as->lower[i]->value.integer),
	 i + 1 - as->rank);
 return true;
}
    if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
{
 if (i < as->rank)
   gfc_warning (0, "Array reference at %L is out of bounds "
	 "(%ld > %ld) in dimension %d", &ar->c_where[i],
	 mpz_get_si__gmpz_get_si (ar->start[i]->value.integer),
	 mpz_get_si__gmpz_get_si (as->upper[i]->value.integer), i+1);
 else
   gfc_warning (0, "Array reference at %L is out of bounds "
	 "(%ld > %ld) in codimension %d", &ar->c_where[i],
	 mpz_get_si__gmpz_get_si (ar->start[i]->value.integer),
	 mpz_get_si__gmpz_get_si (as->upper[i]->value.integer),
	 i + 1 - as->rank);
 return true;
}

    break;

  case DIMEN_RANGE:
    {
4756#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4757#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])

compare_result comp_start_end = compare_bound (AR_START, AR_END);
compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);

/* Check for zero stride, which is not allowed.  */
if (comp_stride_zero == CMP_EQ)
 {
   gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
   return false;
 }

/* if start == end || (stride > 0 && start < end)
	   || (stride < 0 && start > end),
  then the array section contains at least one element.  In this
  case, there is an out-of-bounds access if
  (start < lower || start > upper).  */
if (comp_start_end == CMP_EQ
   || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL__null)
&& comp_start_end == CMP_LT)
   || (comp_stride_zero == CMP_LT
       && comp_start_end == CMP_GT))
 {
   if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
     {
gfc_warning (0, "Lower array reference at %L is out of bounds "
       "(%ld < %ld) in dimension %d", &ar->c_where[i],
       mpz_get_si__gmpz_get_si (AR_START->value.integer),
       mpz_get_si__gmpz_get_si (as->lower[i]->value.integer), i+1);
return true;
     }
   if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
     {
gfc_warning (0, "Lower array reference at %L is out of bounds "
       "(%ld > %ld) in dimension %d", &ar->c_where[i],
       mpz_get_si__gmpz_get_si (AR_START->value.integer),
       mpz_get_si__gmpz_get_si (as->upper[i]->value.integer), i+1);
return true;
     }
 }

/* If we can compute the highest index of the array section,
  then it also has to be between lower and upper.  */
mpz_init__gmpz_init (last_value);
if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
			    last_value))
 {
   if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
     {
gfc_warning (0, "Upper array reference at %L is out of bounds "
       "(%ld < %ld) in dimension %d", &ar->c_where[i],
       mpz_get_si__gmpz_get_si (last_value),
       mpz_get_si__gmpz_get_si (as->lower[i]->value.integer), i+1);
       mpz_clear__gmpz_clear (last_value);
return true;
     }
   if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
     {
gfc_warning (0, "Upper array reference at %L is out of bounds "
       "(%ld > %ld) in dimension %d", &ar->c_where[i],
       mpz_get_si__gmpz_get_si (last_value),
       mpz_get_si__gmpz_get_si (as->upper[i]->value.integer), i+1);
       mpz_clear__gmpz_clear (last_value);
return true;
     }
 }
mpz_clear__gmpz_clear (last_value);

4825#undef AR_START
4826#undef AR_END
    }
    break;

  default:
    gfc_internal_error ("check_dimension(): Bad array reference");
  }

return true;
4835}


4838/* Compare an array reference with an array specification.  */

4840static bool
4841compare_spec_to_ref (gfc_array_ref *ar)
4842{
gfc_array_spec *as;
int i;

as = ar->as;
i = as->rank - 1;
/* TODO: Full array sections are only allowed as actual parameters.  */
if (as->type == AS_ASSUMED_SIZE
    && (/*ar->type == AR_FULL
 ||*/ (ar->type == AR_SECTION
     && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL__null)))
  {
    gfc_error ("Rightmost upper bound of assumed size array section "
 "not specified at %L", &ar->where);
    return false;
  }

if (ar->type == AR_FULL)
  return true;

if (as->rank != ar->dimen)
  {
    gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
 &ar->where, ar->dimen, as->rank);
    return false;
  }

/* ar->codimen == 0 is a local array.  */
if (as->corank != ar->codimen && ar->codimen != 0)
  {
    gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
 &ar->where, ar->codimen, as->corank);
    return false;
  }

for (i = 0; i < as->rank; i++)
  if (!check_dimension (i, ar, as))
    return false;

/* Local access has no coarray spec.  */
if (ar->codimen != 0)
  for (i = as->rank; i < as->rank + as->corank; i++)
    {
if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
   && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
 {
   gfc_error ("Coindex of codimension %d must be a scalar at %L",
       i + 1 - as->rank, &ar->where);
   return false;
 }
if (!check_dimension (i, ar, as))
 return false;
    }

return true;
4897}


4900/* Resolve one part of an array index.  */

4902static bool
4903gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
     int force_index_integer_kind)
4905{
gfc_typespec ts;

if (index == NULL__null)
  return true;

if (!gfc_resolve_expr (index))
  return false;

if (check_scalar && index->rank != 0)
  {
    gfc_error ("Array index at %L must be scalar", &index->where);
    return false;
  }

if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
  {
    gfc_error ("Array index at %L must be of INTEGER type, found %s",
 &index->where, gfc_basic_typename (index->ts.type));
    return false;
  }

if (index->ts.type == BT_REAL)
  if (!gfc_notify_std (GFC_STD_LEGACY(1<<6), "REAL array index at %L",
	 &index->where))
    return false;

if ((index->ts.kind != gfc_index_integer_kind
     && force_index_integer_kind)
    || index->ts.type != BT_INTEGER)
  {
    gfc_clear_ts (&ts);
    ts.type = BT_INTEGER;
    ts.kind = gfc_index_integer_kind;

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

return true;
4944}

4946/* Resolve one part of an array index.  */

4948bool
4949gfc_resolve_index (gfc_expr *index, int check_scalar)
4950{
return gfc_resolve_index_1 (index, check_scalar, 1);
4952}

4954/* Resolve a dim argument to an intrinsic function.  */

4956bool
4957gfc_resolve_dim_arg (gfc_expr *dim)
4958{
if (dim == NULL__null)
  return true;

if (!gfc_resolve_expr (dim))
  return false;

if (dim->rank != 0)
  {
    gfc_error ("Argument dim at %L must be scalar", &dim->where);
    return false;

  }

if (dim->ts.type != BT_INTEGER)
  {
    gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
    return false;
  }

if (dim->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 (dim, &ts, 2, 0);
  }

return true;
4990}

4992/* Given an expression that contains array references, update those array
 references to point to the right array specifications.  While this is
 filled in during matching, this information is difficult to save and load
 in a module, so we take care of it here.

 The idea here is that the original array reference comes from the
 base symbol.  We traverse the list of reference structures, setting
 the stored reference to references.  Component references can
 provide an additional array specification.  */
5001static void
5002resolve_assoc_var (gfc_symbol* sym, bool resolve_target);

5004static bool
5005find_array_spec (gfc_expr *e)
5006{
gfc_array_spec *as;
gfc_component *c;
gfc_ref *ref;
bool class_as = false;

if (e->symtree->n.sym->assoc)
  {
    if (e->symtree->n.sym->assoc->target)
gfc_resolve_expr (e->symtree->n.sym->assoc->target);
    resolve_assoc_var (e->symtree->n.sym, false);
  }

if (e->symtree->n.sym->ts.type == BT_CLASS)
  {
    as = CLASS_DATA (e->symtree->n.sym)e->symtree->n.sym->ts.u.derived->components->as;
    class_as = true;
  }
else
  as = e->symtree->n.sym->as;

for (ref = e->ref; ref; ref = ref->next)
  switch (ref->type)
    {
    case REF_ARRAY:
if (as == NULL__null)
 {
   locus loc = ref->u.ar.where.lb ? ref->u.ar.where : e->where;
   gfc_error ("Invalid array reference of a non-array entity at %L",
       &loc);
   return false;
 }

ref->u.ar.as = as;
as = NULL__null;
break;

    case REF_COMPONENT:
c = ref->u.c.component;
if (c->attr.dimension)
 {
   if (as != NULL__null && !(class_as && as == c->as))
     gfc_internal_error ("find_array_spec(): unused as(1)");
   as = c->as;
 }

break;

    case REF_SUBSTRING:
    case REF_INQUIRY:
break;
    }

if (as != NULL__null)
  gfc_internal_error ("find_array_spec(): unused as(2)");

return true;
5063}


5066/* Resolve an array reference.  */

5068static bool
5069resolve_array_ref (gfc_array_ref *ar)
5070{
int i, check_scalar;
gfc_expr *e;

for (i = 0; i < ar->dimen + ar->codimen; i++)
  {
    check_scalar = ar->dimen_type[i] == DIMEN_RANGE;

    /* Do not force gfc_index_integer_kind for the start.  We can
       do fine with any integer kind.  This avoids temporary arrays
created for indexing with a vector.  */
    if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
return false;
    if (!gfc_resolve_index (ar->end[i], check_scalar))
return false;
    if (!gfc_resolve_index (ar->stride[i], check_scalar))
return false;

    e = ar->start[i];

    if (ar->dimen_type[i] == DIMEN_UNKNOWN)
switch (e->rank)
 {
 case 0:
   ar->dimen_type[i] = DIMEN_ELEMENT;
   break;

 case 1:
   ar->dimen_type[i] = DIMEN_VECTOR;
   if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->ts.type == BT_DERIVED)
     ar->start[i] = gfc_get_parentheses (e);
   break;

 default:
   gfc_error ("Array index at %L is an array of rank %d",
       &ar->c_where[i], e->rank);
   return false;
 }

    /* Fill in the upper bound, which may be lower than the
specified one for something like a(2:10:5), which is
identical to a(2:7:5).  Only relevant for strides not equal
to one.  Don't try a division by zero.  */
    if (ar->dimen_type[i] == DIMEN_RANGE
 && ar->stride[i] != NULL__null && ar->stride[i]->expr_type == EXPR_CONSTANT
 && mpz_cmp_si (ar->stride[i]->value.integer, 1L)(__builtin_constant_p ((1L) >= 0) && (1L) >= 0 ?
 (__builtin_constant_p ((static_cast<unsigned long> (1L
))) && ((static_cast<unsigned long> (1L))) == 0
 ? ((ar->stride[i]->value.integer)->_mp_size < 0 ?
 -1 : (ar->stride[i]->value.integer)->_mp_size > 0
) : __gmpz_cmp_ui (ar->stride[i]->value.integer,(static_cast
<unsigned long> (1L)))) : __gmpz_cmp_si (ar->stride[
i]->value.integer,1L)) != 0
 && mpz_cmp_si (ar->stride[i]->value.integer, 0L)(__builtin_constant_p ((0L) >= 0) && (0L) >= 0 ?
 (__builtin_constant_p ((static_cast<unsigned long> (0L
))) && ((static_cast<unsigned long> (0L))) == 0
 ? ((ar->stride[i]->value.integer)->_mp_size < 0 ?
 -1 : (ar->stride[i]->value.integer)->_mp_size > 0
) : __gmpz_cmp_ui (ar->stride[i]->value.integer,(static_cast
<unsigned long> (0L)))) : __gmpz_cmp_si (ar->stride[
i]->value.integer,0L)) != 0)
{
 mpz_t size, end;

 if (gfc_ref_dimen_size (ar, i, &size, &end))
   {
     if (ar->end[i] == NULL__null)
{
  ar->end[i] =
    gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
			   &ar->where);
  mpz_set__gmpz_set (ar->end[i]->value.integer, end);
}
     else if (ar->end[i]->ts.type == BT_INTEGER
       && ar->end[i]->expr_type == EXPR_CONSTANT)
{
  mpz_set__gmpz_set (ar->end[i]->value.integer, end);
}
     else
gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 5136, __FUNCTION__));

     mpz_clear__gmpz_clear (size);
     mpz_clear__gmpz_clear (end);
   }
}
  }

if (ar->type == AR_FULL)
  {
    if (ar->as->rank == 0)
ar->type = AR_ELEMENT;

    /* Make sure array is the same as array(:,:), this way
we don't need to special case all the time.  */
    ar->dimen = ar->as->rank;
    for (i = 0; i < ar->dimen; i++)
{
 ar->dimen_type[i] = DIMEN_RANGE;

 gcc_assert (ar->start[i] == NULL)((void)(!(ar->start[i] == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 5156, __FUNCTION__), 0 : 0));
 gcc_assert (ar->end[i] == NULL)((void)(!(ar->end[i] == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 5157, __FUNCTION__), 0 : 0));
 gcc_assert (ar->stride[i] == NULL)((void)(!(ar->stride[i] == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 5158, __FUNCTION__), 0 : 0));
}
  }

/* If the reference type is unknown, figure out what kind it is.  */

if (ar->type == AR_UNKNOWN)
  {
    ar->type = AR_ELEMENT;
    for (i = 0; i < ar->dimen; i++)
if (ar->dimen_type[i] == DIMEN_RANGE
   || ar->dimen_type[i] == DIMEN_VECTOR)
 {
   ar->type = AR_SECTION;
   break;
 }
  }

if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
  return false;

if (ar->as->corank && ar->codimen == 0)
  {
    int n;
    ar->codimen = ar->as->corank;
    for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
ar->dimen_type[n] = DIMEN_THIS_IMAGE;
  }

return true;
5188}


5191bool
5192gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5193{
int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);

if (ref->u.ss.start != NULL__null)
  {
    if (!gfc_resolve_expr (ref->u.ss.start))
return false;

    if (ref->u.ss.start->ts.type != BT_INTEGER)
{
 gfc_error ("Substring start index at %L must be of type INTEGER",
     &ref->u.ss.start->where);
 return false;
}

    if (ref->u.ss.start->rank != 0)
{
 gfc_error ("Substring start index at %L must be scalar",
     &ref->u.ss.start->where);
 return false;
}

    if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
     || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
{
 gfc_error ("Substring start index at %L is less than one",
     &ref->u.ss.start->where);
 return false;
}
  }

if (ref->u.ss.end != NULL__null)
  {
    if (!gfc_resolve_expr (ref->u.ss.end))
return false;

    if (ref->u.ss.end->ts.type != BT_INTEGER)
{
 gfc_error ("Substring end index at %L must be of type INTEGER",
     &ref->u.ss.end->where);
 return false;
}

    if (ref->u.ss.end->rank != 0)
{
 gfc_error ("Substring end index at %L must be scalar",
     &ref->u.ss.end->where);
 return false;
}

    if (ref->u.ss.length != NULL__null
 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
     || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
{
 gfc_error ("Substring end index at %L exceeds the string length",
     &ref->u.ss.start->where);
 return false;
}

    if (compare_bound_mpz_t (ref->u.ss.end,
	       gfc_integer_kinds[k].huge) == CMP_GT
 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
     || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
{
 gfc_error ("Substring end index at %L is too large",
     &ref->u.ss.end->where);
 return false;
}
    /*  If the substring has the same length as the original
 variable, the reference itself can be deleted.  */

    if (ref->u.ss.length != NULL__null
 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
 && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
*equal_length = true;
  }

return true;
5273}


5276/* This function supplies missing substring charlens.  */

5278void
5279gfc_resolve_substring_charlen (gfc_expr *e)
5280{
gfc_ref *char_ref;
gfc_expr *start, *end;
gfc_typespec *ts = NULL__null;
mpz_t diff;

for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
  {
    if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
break;
    if (char_ref->type == REF_COMPONENT)
ts = &char_ref->u.c.component->ts;
  }

if (!char_ref || char_ref->type == REF_INQUIRY)
  return;

gcc_assert (char_ref->next == NULL)((void)(!(char_ref->next == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 5297, __FUNCTION__), 0 : 0));

if (e->ts.u.cl)
  {
    if (e->ts.u.cl->length)
gfc_free_expr (e->ts.u.cl->length);
    else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
return;
  }

if (!e->ts.u.cl)
  e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);

if (char_ref->u.ss.start)
  start = gfc_copy_expr (char_ref->u.ss.start);
else
  start = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null, 1);

if (char_ref->u.ss.end)
  end = gfc_copy_expr (char_ref->u.ss.end);
else if (e->expr_type == EXPR_VARIABLE)
  {
    if (!ts)
ts = &e->symtree->n.sym->ts;
    end = gfc_copy_expr (ts->u.cl->length);
  }
else
  end = NULL__null;

if (!start || !end)
  {
    gfc_free_expr (start);
    gfc_free_expr (end);
    return;
  }

/* Length = (end - start + 1).
   Check first whether it has a constant length.  */
if (gfc_dep_difference (end, start, &diff))
  {
    gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
			     &e->where);

    mpz_add_ui__gmpz_add_ui (len->value.integer, diff, 1);
    mpz_clear__gmpz_clear (diff);
    e->ts.u.cl->length = len;
    /* The check for length < 0 is handled below */
  }
else
  {
    e->ts.u.cl->length = gfc_subtract (end, start);
    e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
		    gfc_get_int_expr (gfc_charlen_int_kind,
				      NULL__null, 1));
  }

/* F2008, 6.4.1:  Both the starting point and the ending point shall
   be within the range 1, 2, ..., n unless the starting point exceeds
   the ending point, in which case the substring has length zero.  */

if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(e->ts.u.cl->length->value.integer)->_mp_size <
? -1 : (e->ts.u.cl->length->value.integer)->_mp_size
 > 0) : __gmpz_cmp_ui (e->ts.u.cl->length->value.
integer,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si
 (e->ts.u.cl->length->value.integer,0)) < 0)
  mpz_set_si__gmpz_set_si (e->ts.u.cl->length->value.integer, 0);

e->ts.u.cl->length->ts.type = BT_INTEGER;
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;

/* Make sure that the length is simplified.  */
gfc_simplify_expr (e->ts.u.cl->length, 1);
gfc_resolve_expr (e->ts.u.cl->length);
5366}


5369/* Resolve subtype references.  */

5371bool
5372gfc_resolve_ref (gfc_expr *expr)
5373{
int current_part_dimension, n_components, seen_part_dimension, dim;
gfc_ref *ref, **prev, *array_ref;
bool equal_length;

for (ref = expr->ref; ref; ref = ref->next)
  if (ref->type == REF_ARRAY && ref->u.ar.as == NULL__null)
    {
if (!find_array_spec (expr))
 return false;
break;
    }

for (prev = &expr->ref; *prev != NULL__null;
     prev = *prev == NULL__null ? prev : &(*prev)->next)
  switch ((*prev)->type)
    {
    case REF_ARRAY:
if (!resolve_array_ref (&(*prev)->u.ar))
 return false;
break;

    case REF_COMPONENT:
    case REF_INQUIRY:
break;

    case REF_SUBSTRING:
equal_length = false;
if (!gfc_resolve_substring (*prev, &equal_length))
 return false;

if (expr->expr_type != EXPR_SUBSTRING && equal_length)
 {
   /* Remove the reference and move the charlen, if any.  */
   ref = *prev;
   *prev = ref->next;
   ref->next = NULL__null;
   expr->ts.u.cl = ref->u.ss.length;
   ref->u.ss.length = NULL__null;
   gfc_free_ref_list (ref);
 }
break;
    }

/* Check constraints on part references.  */

current_part_dimension = 0;
seen_part_dimension = 0;
n_components = 0;
array_ref = NULL__null;

for (ref = expr->ref; ref; ref = ref->next)
  {
    switch (ref->type)
{
case REF_ARRAY:
 array_ref = ref;
 switch (ref->u.ar.type)
   {
   case AR_FULL:
     /* Coarray scalar.  */
     if (ref->u.ar.as->rank == 0)
{
  current_part_dimension = 0;
  break;
}
     /* Fall through.  */
   case AR_SECTION:
     current_part_dimension = 1;
     break;

   case AR_ELEMENT:
     array_ref = NULL__null;
     current_part_dimension = 0;
     break;

   case AR_UNKNOWN:
     gfc_internal_error ("resolve_ref(): Bad array reference");
   }

 break;

case REF_COMPONENT:
 if (current_part_dimension || seen_part_dimension)
   {
     /* F03:C614.  */
     if (ref->u.c.component->attr.pointer
  || ref->u.c.component->attr.proc_pointer
  || (ref->u.c.component->ts.type == BT_CLASS
	&& CLASS_DATA (ref->u.c.component)ref->u.c.component->ts.u.derived->components->attr.pointer))
{
  gfc_error ("Component to the right of a part reference "
	     "with nonzero rank must not have the POINTER "
	     "attribute at %L", &expr->where);
  return false;
}
     else if (ref->u.c.component->attr.allocatable
	|| (ref->u.c.component->ts.type == BT_CLASS
	    && CLASS_DATA (ref->u.c.component)ref->u.c.component->ts.u.derived->components->attr.allocatable))

{
  gfc_error ("Component to the right of a part reference "
	     "with nonzero rank must not have the ALLOCATABLE "
	     "attribute at %L", &expr->where);
  return false;
}
   }

 n_components++;
 break;

case REF_SUBSTRING:
 break;

case REF_INQUIRY:
 /* Implement requirement in note 9.7 of F2018 that the result of the
    LEN inquiry be a scalar.  */
 if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred)
   {
     array_ref->u.ar.type = AR_ELEMENT;
     expr->rank = 0;
     /* INQUIRY_LEN is not evaluated from the rest of the expr
 but directly from the string length. This means that setting
 the array indices to one does not matter but might trigger
 a runtime bounds error. Suppress the check.  */
     expr->no_bounds_check = 1;
     for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
{
  array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
  if (array_ref->u.ar.start[dim])
    gfc_free_expr (array_ref->u.ar.start[dim]);
  array_ref->u.ar.start[dim]
	= gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 1);
  if (array_ref->u.ar.end[dim])
    gfc_free_expr (array_ref->u.ar.end[dim]);
  if (array_ref->u.ar.stride[dim])
    gfc_free_expr (array_ref->u.ar.stride[dim]);
}
   }
 break;
}

    if (((ref->type == REF_COMPONENT && n_components > 1)
  || ref->next == NULL__null)
 && current_part_dimension
 && seen_part_dimension)
{
 gfc_error ("Two or more part references with nonzero rank must "
     "not be specified at %L", &expr->where);
 return false;
}

    if (ref->type == REF_COMPONENT)
{
 if (current_part_dimension)
   seen_part_dimension = 1;

 /* reset to make sure */
 current_part_dimension = 0;
}
  }

return true;
5536}


5539/* Given an expression, determine its shape.  This is easier than it sounds.
 Leaves the shape array NULL if it is not possible to determine the shape.  */

5542static void
5543expression_shape (gfc_expr *e)
5544{
mpz_t array[GFC_MAX_DIMENSIONS15];
int i;

if (e->rank <= 0 || e->shape != NULL__null)
  return;

for (i = 0; i < e->rank; i++)
  if (!gfc_array_dimen_size (e, i, &array[i]))
    goto fail;

e->shape = gfc_get_shape (e->rank)(((mpz_t *) xcalloc (((e->rank)), sizeof (mpz_t))));

memcpy (e->shape, array, e->rank * sizeof (mpz_t));

return;

5561fail:
for (i--; i >= 0; i--)
  mpz_clear__gmpz_clear (array[i]);
5564}


5567/* Given a variable expression node, compute the rank of the expression by
 examining the base symbol and any reference structures it may have.  */

5570void
5571gfc_expression_rank (gfc_expr *e)
5572{
gfc_ref *ref;
int i, rank;

/* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
   could lead to serious confusion...  */
gcc_assert (e->expr_type != EXPR_COMPCALL)((void)(!(e->expr_type != EXPR_COMPCALL) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 5578, __FUNCTION__), 0 : 0));

if (e->ref == NULL__null)
  {
    if (e->expr_type == EXPR_ARRAY)
goto done;
    /* Constructors can have a rank different from one via RESHAPE().  */

    e->rank = ((e->symtree == NULL__null || e->symtree->n.sym->as == NULL__null)
 ? 0 : e->symtree->n.sym->as->rank);
    goto done;
  }

rank = 0;

for (ref = e->ref; ref; ref = ref->next)
  {
    if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
 && ref->u.c.component->attr.function && !ref->next)
rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;

    if (ref->type != REF_ARRAY)
continue;

    if (ref->u.ar.type == AR_FULL)
{
 rank = ref->u.ar.as->rank;
 break;
}

    if (ref->u.ar.type == AR_SECTION)
{
 /* Figure out the rank of the section.  */
 if (rank != 0)
   gfc_internal_error ("gfc_expression_rank(): Two array specs");

 for (i = 0; i < ref->u.ar.dimen; i++)
   if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
     rank++;

 break;
}
  }

e->rank = rank;

5625done:
expression_shape (e);
5627}


5630static void
5631add_caf_get_intrinsic (gfc_expr *e)
5632{
gfc_expr *wrapper, *tmp_expr;
gfc_ref *ref;
int n;

for (ref = e->ref; ref; ref = ref->next)
  if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
    break;
if (ref == NULL__null)
  return;

for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
  if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
    return;

tmp_expr = XCNEW (gfc_expr)((gfc_expr *) xcalloc (1, sizeof (gfc_expr)));
*tmp_expr = *e;
wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
		      "caf_get", tmp_expr->where, 1, tmp_expr);
wrapper->ts = e->ts;
wrapper->rank = e->rank;
if (e->rank)
  wrapper->shape = gfc_copy_shape (e->shape, e->rank);
*e = *wrapper;
free (wrapper);
5657}


5660static void
5661remove_caf_get_intrinsic (gfc_expr *e)
5662{
gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym((void)(!(e->expr_type == EXPR_FUNCTION && e->value
.function.isym && e->value.function.isym->id ==
 GFC_ISYM_CAF_GET) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 5664, __FUNCTION__), 0 : 0))
     && e->value.function.isym->id == GFC_ISYM_CAF_GET)((void)(!(e->expr_type == EXPR_FUNCTION && e->value
.function.isym && e->value.function.isym->id ==
 GFC_ISYM_CAF_GET) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 5664, __FUNCTION__), 0 : 0));
gfc_expr *e2 = e->value.function.actual->expr;
e->value.function.actual->expr = NULL__null;
gfc_free_actual_arglist (e->value.function.actual);
gfc_free_shape (&e->shape, e->rank);
*e = *e2;
free (e2);
5671}


5674/* Resolve a variable expression.  */

5676static bool
5677resolve_variable (gfc_expr *e)
5678{
gfc_symbol *sym;
bool t;

t = true;

if (e->symtree == NULL__null)
  return false;
sym = e->symtree->n.sym;

/* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
   as ts.type is set to BT_ASSUMED in resolve_symbol.  */
if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
  {
    if (!actual_arg || inquiry_argument)
{
 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
     "be used as actual argument", sym->name, &e->where);
 return false;
}
  }
/* TS 29113, 407b.  */
else if (e->ts.type == BT_ASSUMED)
  {
    if (!actual_arg)
{
 gfc_error ("Assumed-type variable %s at %L may only be used "
     "as actual argument", sym->name, &e->where);
 return false;
}
    else if (inquiry_argument && !first_actual_arg)
{
 /* FIXME: It doesn't work reliably as inquiry_argument is not set
    for all inquiry functions in resolve_function; the reason is
    that the function-name resolution happens too late in that
    function.  */
 gfc_error ("Assumed-type variable %s at %L as actual argument to "
     "an inquiry function shall be the first argument",
     sym->name, &e->where);
 return false;
}
  }
/* TS 29113, C535b.  */
else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
    && sym->ts.u.derived && CLASS_DATA (sym)sym->ts.u.derived->components
    && CLASS_DATA (sym)sym->ts.u.derived->components->as
    && CLASS_DATA (sym)sym->ts.u.derived->components->as->type == AS_ASSUMED_RANK)
   || (sym->ts.type != BT_CLASS && sym->as
       && sym->as->type == AS_ASSUMED_RANK))
  && !sym->attr.select_rank_temporary)
  {
    if (!actual_arg
 && !(cs_base && cs_base->current
      && cs_base->current->op == EXEC_SELECT_RANK))
{
 gfc_error ("Assumed-rank variable %s at %L may only be used as "
     "actual argument", sym->name, &e->where);
 return false;
}
    else if (inquiry_argument && !first_actual_arg)
{
 /* FIXME: It doesn't work reliably as inquiry_argument is not set
    for all inquiry functions in resolve_function; the reason is
    that the function-name resolution happens too late in that
    function.  */
 gfc_error ("Assumed-rank variable %s at %L as actual argument "
     "to an inquiry function shall be the first argument",
     sym->name, &e->where);
 return false;
}
  }

if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
    && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
  && e->ref->next == NULL__null))
  {
    gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
 "a subobject reference", sym->name, &e->ref->u.ar.where);
    return false;
  }
/* TS 29113, 407b.  */
else if (e->ts.type == BT_ASSUMED && e->ref
  && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
&& e->ref->next == NULL__null))
  {
    gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
 "reference", sym->name, &e->ref->u.ar.where);
    return false;
  }

/* TS 29113, C535b.  */
if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
&& sym->ts.u.derived && CLASS_DATA (sym)sym->ts.u.derived->components
&& CLASS_DATA (sym)sym->ts.u.derived->components->as
&& CLASS_DATA (sym)sym->ts.u.derived->components->as->type == AS_ASSUMED_RANK)
     || (sym->ts.type != BT_CLASS && sym->as
  && sym->as->type == AS_ASSUMED_RANK))
    && e->ref
    && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
  && e->ref->next == NULL__null))
  {
    gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
 "reference", sym->name, &e->ref->u.ar.where);
    return false;
  }

/* For variables that are used in an associate (target => object) where
   the object's basetype is array valued while the target is scalar,
   the ts' type of the component refs is still array valued, which
   can't be translated that way.  */
if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
    && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
    && sym->assoc->target->ts.u.derived
    && CLASS_DATA (sym->assoc->target)sym->assoc->target->ts.u.derived->components
    && CLASS_DATA (sym->assoc->target)sym->assoc->target->ts.u.derived->components->as)
  {
    gfc_ref *ref = e->ref;
    while (ref)
{
 switch (ref->type)
   {
   case REF_COMPONENT:
     ref->u.c.sym = sym->ts.u.derived;
     /* Stop the loop.  */
     ref = NULL__null;
     break;
   default:
     ref = ref->next;
     break;
   }
}
  }

/* If this is an associate-name, it may be parsed with an array reference
   in error even though the target is scalar.  Fail directly in this case.
   TODO Understand why class scalar expressions must be excluded.  */
if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
  {
    if (sym->ts.type == BT_CLASS)
gfc_fix_class_refs (e);
    if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
return false;
    else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
{
 /* This can happen because the parser did not detect that the
    associate name is an array and the expression had no array
    part_ref.  */
 gfc_ref *ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
 ref->type = REF_ARRAY;
 ref->u.ar.type = AR_FULL;
 if (sym->as)
   {
     ref->u.ar.as = sym->as;
     ref->u.ar.dimen = sym->as->rank;
   }
 ref->next = e->ref;
 e->ref = ref;

}
  }

if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
  sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);

/* On the other hand, the parser may not have known this is an array;
   in this case, we have to add a FULL reference.  */
if (sym->assoc && sym->attr.dimension && !e->ref)
  {
    e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
    e->ref->type = REF_ARRAY;
    e->ref->u.ar.type = AR_FULL;
    e->ref->u.ar.dimen = 0;
  }

/* Like above, but for class types, where the checking whether an array
   ref is present is more complicated.  Furthermore make sure not to add
   the full array ref to _vptr or _len refs.  */
if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
    && CLASS_DATA (sym)sym->ts.u.derived->components
    && CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension
    && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
  {
    gfc_ref *ref, *newref;

    newref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
    newref->type = REF_ARRAY;
    newref->u.ar.type = AR_FULL;
    newref->u.ar.dimen = 0;
    /* Because this is an associate var and the first ref either is a ref to
the _data component or not, no traversal of the ref chain is
needed.  The array ref needs to be inserted after the _data ref,
or when that is not present, which may happend for polymorphic
types, then at the first position.  */
    ref = e->ref;
    if (!ref)
e->ref = newref;
    else if (ref->type == REF_COMPONENT
      && strcmp ("_data", ref->u.c.component->name) == 0)
{
 if (!ref->next || ref->next->type != REF_ARRAY)
   {
     newref->next = ref->next;
     ref->next = newref;
   }
 else
   /* Array ref present already.  */
   gfc_free_ref_list (newref);
}
    else if (ref->type == REF_ARRAY)
/* Array ref present already.  */
gfc_free_ref_list (newref);
    else
{
 newref->next = ref;
 e->ref = newref;
}
  }

if (e->ref && !gfc_resolve_ref (e))
  return false;

if (sym->attr.flavor == FL_PROCEDURE
    && (!sym->attr.function
 || (sym->attr.function && sym->result
     && sym->result->attr.proc_pointer
     && !sym->result->attr.function)))
  {
    e->ts.type = BT_PROCEDURE;
    goto resolve_procedure;
  }

if (sym->ts.type != BT_UNKNOWN)
  gfc_variable_attr (e, &e->ts);
else if (sym->attr.flavor == FL_PROCEDURE
  && sym->attr.function && sym->result
  && sym->result->ts.type != BT_UNKNOWN
  && sym->result->attr.proc_pointer)
  e->ts = sym->result->ts;
else
  {
    /* Must be a simple variable reference.  */
    if (!gfc_set_default_type (sym, 1, sym->ns))
return false;
    e->ts = sym->ts;
  }

if (check_assumed_size_reference (sym, e))
  return false;

/* Deal with forward references to entries during gfc_resolve_code, to
   satisfy, at least partially, 12.5.2.5.  */
if (gfc_current_ns->entries
    && current_entry_id == sym->entry_id
    && cs_base
    && cs_base->current
    && cs_base->current->op != EXEC_ENTRY)
  {
    gfc_entry_list *entry;
    gfc_formal_arglist *formal;
    int n;
    bool seen, saved_specification_expr;

    /* If the symbol is a dummy...  */
    if (sym->attr.dummy && sym->ns == gfc_current_ns)
{
 entry = gfc_current_ns->entries;
 seen = false;

 /* ...test if the symbol is a parameter of previous entries.  */
 for (; entry && entry->id <= current_entry_id; entry = entry->next)
   for (formal = entry->sym->formal; formal; formal = formal->next)
     {
if (formal->sym && sym->name == formal->sym->name)
  {
    seen = true;
    break;
  }
     }

 /*  If it has not been seen as a dummy, this is an error.  */
 if (!seen)
   {
     if (specification_expr)
gfc_error ("Variable %qs, used in a specification expression"
	   ", is referenced at %L before the ENTRY statement "
	   "in which it is a parameter",
	   sym->name, &cs_base->current->loc);
     else
gfc_error ("Variable %qs is used at %L before the ENTRY "
	   "statement in which it is a parameter",
	   sym->name, &cs_base->current->loc);
     t = false;
   }
}

    /* Now do the same check on the specification expressions.  */
    saved_specification_expr = specification_expr;
    specification_expr = true;
    if (sym->ts.type == BT_CHARACTER
 && !gfc_resolve_expr (sym->ts.u.cl->length))
t = false;

    if (sym->as)
for (n = 0; n < sym->as->rank; n++)
 {
    if (!gfc_resolve_expr (sym->as->lower[n]))
      t = false;
    if (!gfc_resolve_expr (sym->as->upper[n]))
      t = false;
 }
    specification_expr = saved_specification_expr;

    if (t)
/* Update the symbol's entry level.  */
sym->entry_id = current_entry_id + 1;
  }

/* If a symbol has been host_associated mark it.  This is used latter,
   to identify if aliasing is possible via host association.  */
if (sym->attr.flavor == FL_VARIABLE
&& gfc_current_ns->parent
&& (gfc_current_ns->parent == sym->ns
     || (gfc_current_ns->parent->parent
    && gfc_current_ns->parent->parent == sym->ns)))
  sym->attr.host_assoc = 1;

if (gfc_current_ns->proc_name
    && sym->attr.dimension
    && (sym->ns != gfc_current_ns
 || sym->attr.use_assoc
 || sym->attr.in_common))
  gfc_current_ns->proc_name->attr.array_outer_dependency = 1;

6011resolve_procedure:
if (t && !resolve_procedure_expression (e))
  t = false;

/* F2008, C617 and C1229.  */
if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
    && gfc_is_coindexed (e))
  {
    gfc_ref *ref, *ref2 = NULL__null;

    for (ref = e->ref; ref; ref = ref->next)
{
 if (ref->type == REF_COMPONENT)
   ref2 = ref;
 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
   break;
}

    for ( ; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
 break;

    /* Expression itself is not coindexed object.  */
    if (ref && e->ts.type == BT_CLASS)
{
 gfc_error ("Polymorphic subobject of coindexed object at %L",
     &e->where);
 t = false;
}

    /* Expression itself is coindexed object.  */
    if (ref == NULL__null)
{
 gfc_component *c;
 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
 for ( ; c; c = c->next)
   if (c->attr.allocatable && c->ts.type == BT_CLASS)
     {
gfc_error ("Coindexed object with polymorphic allocatable "
	 "subcomponent at %L", &e->where);
t = false;
break;
     }
}
  }

if (t)
  gfc_expression_rank (e);

if (t && flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
  add_caf_get_intrinsic (e);

if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
  gfc_warning (OPT_Wdeprecated_declarations,
 "Using variable %qs at %L is deprecated",
 sym->name, &e->where);
/* Simplify cases where access to a parameter array results in a
   single constant.  Suppress errors since those will have been
   issued before, as warnings.  */
if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
  {
    gfc_push_suppress_errors ();
    gfc_simplify_expr (e, 1);
    gfc_pop_suppress_errors ();
  }

return t;
6078}


6081/* Checks to see that the correct symbol has been host associated.
 The only situations where this arises are:
(i)  That in which a twice contained function is parsed after
    the host association is made. On detecting this, change
    the symbol in the expression and convert the array reference
    into an actual arglist if the old symbol is a variable; or
(ii) That in which an external function is typed but not declared
    explcitly to be external. Here, the old symbol is changed
    from a variable to an external function.  */
6090static bool
6091check_host_association (gfc_expr *e)
6092{
gfc_symbol *sym, *old_sym;
gfc_symtree *st;
int n;
gfc_ref *ref;
gfc_actual_arglist *arg, *tail = NULL__null;
bool retval = e->expr_type == EXPR_FUNCTION;

/*  If the expression is the result of substitution in
    interface.cc(gfc_extend_expr) because there is no way in
    which the host association can be wrong.  */
if (e->symtree == NULL__null
|| e->symtree->n.sym == NULL__null
|| e->user_operator)
  return retval;

old_sym = e->symtree->n.sym;

if (gfc_current_ns->parent
&& old_sym->ns != gfc_current_ns)
  {
    /* Use the 'USE' name so that renamed module symbols are
correctly handled.  */
    gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);

    if (sym && old_sym != sym
     && sym->attr.flavor == FL_PROCEDURE
     && sym->attr.contained)
{
 /* Clear the shape, since it might not be valid.  */
 gfc_free_shape (&e->shape, e->rank);

 /* Give the expression the right symtree!  */
 gfc_find_sym_tree (e->symtree->name, NULL__null, 1, &st);
 gcc_assert (st != NULL)((void)(!(st != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 6126, __FUNCTION__), 0 : 0));

 if (old_sym->attr.flavor == FL_PROCEDURE
|| e->expr_type == EXPR_FUNCTION)
	    {
     /* Original was function so point to the new symbol, since
 the actual argument list is already attached to the
 expression.  */
     e->value.function.esym = NULL__null;
     e->symtree = st;
   }
 else
   {
     /* Original was variable so convert array references into
 an actual arglist. This does not need any checking now
 since resolve_function will take care of it.  */
     e->value.function.actual = NULL__null;
     e->expr_type = EXPR_FUNCTION;
     e->symtree = st;

     /* Ambiguity will not arise if the array reference is not
 the last reference.  */
     for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->next == NULL__null)
  break;

     if ((ref == NULL__null || ref->type != REF_ARRAY)
  && sym->attr.proc == PROC_INTERNAL)
{
  gfc_error ("%qs at %L is host associated at %L into "
	     "a contained procedure with an internal "
	     "procedure of the same name", sym->name,
	      &old_sym->declared_at, &e->where);
  return false;
}

     if (ref == NULL__null)
return false;

     gcc_assert (ref->type == REF_ARRAY)((void)(!(ref->type == REF_ARRAY) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 6165, __FUNCTION__), 0 : 0));

     /* Grab the start expressions from the array ref and
 copy them into actual arguments.  */
     for (n = 0; n < ref->u.ar.dimen; n++)
{
  arg = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
  arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
  if (e->value.function.actual == NULL__null)
    tail = e->value.function.actual = arg;
         else
    {
      tail->next = arg;
      tail = arg;
    }
}

     /* Dump the reference list and set the rank.  */
     gfc_free_ref_list (e->ref);
     e->ref = NULL__null;
     e->rank = sym->as ? sym->as->rank : 0;
   }

 gfc_resolve_expr (e);
 sym->refs++;
}
    /* This case corresponds to a call, from a block or a contained
procedure, to an external function, which has not been declared
as being external in the main program but has been typed.  */
    else if (sym && old_sym != sym
      && !e->ref
      && sym->ts.type == BT_UNKNOWN
      && old_sym->ts.type != BT_UNKNOWN
      && sym->attr.flavor == FL_PROCEDURE
      && old_sym->attr.flavor == FL_VARIABLE
      && sym->ns->parent == old_sym->ns
      && sym->ns->proc_name
      && sym->ns->proc_name->attr.proc != PROC_MODULE
      && (sym->ns->proc_name->attr.flavor == FL_LABEL
   || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
{
 old_sym->attr.flavor = FL_PROCEDURE;
 old_sym->attr.external = 1;
 old_sym->attr.function = 1;
 old_sym->result = old_sym;
 gfc_resolve_expr (e);
}
  }
/* This might have changed!  */
return e->expr_type == EXPR_FUNCTION;
6215}


6218static void
6219gfc_resolve_character_operator (gfc_expr *e)
6220{
gfc_expr *op1 = e->value.op.op1;
gfc_expr *op2 = e->value.op.op2;
gfc_expr *e1 = NULL__null;
gfc_expr *e2 = NULL__null;

gcc_assert (e->value.op.op == INTRINSIC_CONCAT)((void)(!(e->value.op.op == INTRINSIC_CONCAT) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 6226, __FUNCTION__), 0 : 0));

if (op1->ts.u.cl && op1->ts.u.cl->length)
  e1 = gfc_copy_expr (op1->ts.u.cl->length);
else if (op1->expr_type == EXPR_CONSTANT)
  e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null,
	   op1->value.character.length);

if (op2->ts.u.cl && op2->ts.u.cl->length)
  e2 = gfc_copy_expr (op2->ts.u.cl->length);
else if (op2->expr_type == EXPR_CONSTANT)
  e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null,
	   op2->value.character.length);

e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);

if (!e1 || !e2)
  {
    gfc_free_expr (e1);
    gfc_free_expr (e2);

    return;
  }

e->ts.u.cl->length = gfc_add (e1, e2);
e->ts.u.cl->length->ts.type = BT_INTEGER;
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
gfc_simplify_expr (e->ts.u.cl->length, 0);
gfc_resolve_expr (e->ts.u.cl->length);

return;
6257}


6260/*  Ensure that an character expression has a charlen and, if possible, a
  length expression.  */

6263static void
6264fixup_charlen (gfc_expr *e)
6265{
/* The cases fall through so that changes in expression type and the need
   for multiple fixes are picked up.  In all circumstances, a charlen should
   be available for the middle end to hang a backend_decl on.  */
switch (e->expr_type)
  {
  case EXPR_OP:
    gfc_resolve_character_operator (e);
    /* FALLTHRU */

  case EXPR_ARRAY:
    if (e->expr_type == EXPR_ARRAY)
gfc_resolve_character_array_constructor (e);
    /* FALLTHRU */

  case EXPR_SUBSTRING:
    if (!e->ts.u.cl && e->ref)
gfc_resolve_substring_charlen (e);
    /* FALLTHRU */

  default:
    if (!e->ts.u.cl)
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);

    break;
  }
6291}


6294/* Update an actual argument to include the passed-object for type-bound
 procedures at the right position.  */

6297static gfc_actual_arglist*
6298update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
     const char *name)
6300{
gcc_assert (argpos > 0)((void)(!(argpos > 0) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 6301, __FUNCTION__), 0 : 0));

if (argpos == 1)
  {
    gfc_actual_arglist* result;

    result = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));
    result->expr = po;
    result->next = lst;
    if (name)
      result->name = name;

    return result;
  }

if (lst)
  lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
else
  lst = update_arglist_pass (NULL__null, po, argpos - 1, name);
return lst;
6321}


6324/* Extract the passed-object from an EXPR_COMPCALL (a copy of it).  */

6326static gfc_expr*
6327extract_compcall_passed_object (gfc_expr* e)
6328{
gfc_expr* po;

if (e->expr_type == EXPR_UNKNOWN)
  {
    gfc_error ("Error in typebound call at %L",
 &e->where);
    return NULL__null;
  }

gcc_assert (e->expr_type == EXPR_COMPCALL)((void)(!(e->expr_type == EXPR_COMPCALL) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.cc"
, 6338, __FUNCTION__), 0 : 0));

if (e->value.compcall.base_object)
  po = gfc_copy_expr (e->value.compcall.base_object);
else
  {
    po = gfc_get_expr ();
    po->expr_type = EXPR_VARIABLE;
    po->symtree = e->symtree;
    po->ref = gfc_copy_ref (e->ref);
    po->where = e->where;
  }

if (!gfc_resolve_expr (po))
  return NULL__null;

return po;
6355}


6358/* Update the arglist of an EXPR_COMPCALL expression to include the
 passed-object.  */

6361static bool
6362update_compcall_arglist (gfc_expr* e)
6363{
gfc_expr* po;
gfc_typebound_proc* tbp;

tbp = e->value.compcall.tbp;

if (tbp->error)
  return false;

po = extract_compcall_passed_object (e);
if (!po)
  return false;

if (tbp->nopass || e->value.compcall.ignore_pass)
  {
    gfc_free_expr (po);
    return true;
  }

if (tbp->pass_arg_num <= 0)
  return false;

e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
				  tbp->pass_arg_num,
				  tbp->pass_arg);

return true;
6390}


6393/* Extract the passed object from a PPC call (a copy of it).  */

6395static gfc_expr*
6396extract_ppc_passed_object (gfc_expr *e)
6397{
gfc_expr *po;
gfc_ref **ref;

po = gfc_get_expr ();
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
po->where = e->where;

/* Remove PPC reference.  */