/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c

Bug Summary

File:	build/gcc/fortran/symbol.c
Warning:	line 4700, column 2 Called C++ object pointer is null
Annotated Source Code

Press '?' to see keyboard shortcuts
Show analyzer invocation
clang -cc1 -cc1 -triple x86_64-unknown-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name symbol.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -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 -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib64/clang/11.0.0 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/backward -internal-isystem /usr/local/include -internal-isystem /usr/lib64/clang/11.0.0/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-error=format-diag -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir /home/marxin/BIG/buildbot/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 -o /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2021-01-16-135054-17580-1/report-7qGR5c.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c
1/* Maintain binary trees of symbols.
 Copyright (C) 2000-2021 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/>.  */


22#include "config.h"
23#include "system.h"
24#include "coretypes.h"
25#include "options.h"
26#include "gfortran.h"
27#include "parse.h"
28#include "match.h"
29#include "constructor.h"


32/* Strings for all symbol attributes.  We use these for dumping the
 parse tree, in error messages, and also when reading and writing
 modules.  */

36const mstring flavors[] =
37{
minit ("UNKNOWN-FL", FL_UNKNOWN){ "UNKNOWN-FL", __null, FL_UNKNOWN }, minit ("PROGRAM", FL_PROGRAM){ "PROGRAM", __null, FL_PROGRAM },
minit ("BLOCK-DATA", FL_BLOCK_DATA){ "BLOCK-DATA", __null, FL_BLOCK_DATA }, minit ("MODULE", FL_MODULE){ "MODULE", __null, FL_MODULE },
minit ("VARIABLE", FL_VARIABLE){ "VARIABLE", __null, FL_VARIABLE }, minit ("PARAMETER", FL_PARAMETER){ "PARAMETER", __null, FL_PARAMETER },
minit ("LABEL", FL_LABEL){ "LABEL", __null, FL_LABEL }, minit ("PROCEDURE", FL_PROCEDURE){ "PROCEDURE", __null, FL_PROCEDURE },
minit ("DERIVED", FL_DERIVED){ "DERIVED", __null, FL_DERIVED }, minit ("NAMELIST", FL_NAMELIST){ "NAMELIST", __null, FL_NAMELIST },
minit ("UNION", FL_UNION){ "UNION", __null, FL_UNION }, minit ("STRUCTURE", FL_STRUCT){ "STRUCTURE", __null, FL_STRUCT },
minit (NULL, -1){ __null, __null, -1 }
45};

47const mstring procedures[] =
48{
  minit ("UNKNOWN-PROC", PROC_UNKNOWN){ "UNKNOWN-PROC", __null, PROC_UNKNOWN },
  minit ("MODULE-PROC", PROC_MODULE){ "MODULE-PROC", __null, PROC_MODULE },
  minit ("INTERNAL-PROC", PROC_INTERNAL){ "INTERNAL-PROC", __null, PROC_INTERNAL },
  minit ("DUMMY-PROC", PROC_DUMMY){ "DUMMY-PROC", __null, PROC_DUMMY },
  minit ("INTRINSIC-PROC", PROC_INTRINSIC){ "INTRINSIC-PROC", __null, PROC_INTRINSIC },
  minit ("EXTERNAL-PROC", PROC_EXTERNAL){ "EXTERNAL-PROC", __null, PROC_EXTERNAL },
  minit ("STATEMENT-PROC", PROC_ST_FUNCTION){ "STATEMENT-PROC", __null, PROC_ST_FUNCTION },
  minit (NULL, -1){ __null, __null, -1 }
57};

59const mstring intents[] =
60{
  minit ("UNKNOWN-INTENT", INTENT_UNKNOWN){ "UNKNOWN-INTENT", __null, INTENT_UNKNOWN },
  minit ("IN", INTENT_IN){ "IN", __null, INTENT_IN },
  minit ("OUT", INTENT_OUT){ "OUT", __null, INTENT_OUT },
  minit ("INOUT", INTENT_INOUT){ "INOUT", __null, INTENT_INOUT },
  minit (NULL, -1){ __null, __null, -1 }
66};

68const mstring access_types[] =
69{
  minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN){ "UNKNOWN-ACCESS", __null, ACCESS_UNKNOWN },
  minit ("PUBLIC", ACCESS_PUBLIC){ "PUBLIC", __null, ACCESS_PUBLIC },
  minit ("PRIVATE", ACCESS_PRIVATE){ "PRIVATE", __null, ACCESS_PRIVATE },
  minit (NULL, -1){ __null, __null, -1 }
74};

76const mstring ifsrc_types[] =
77{
  minit ("UNKNOWN", IFSRC_UNKNOWN){ "UNKNOWN", __null, IFSRC_UNKNOWN },
  minit ("DECL", IFSRC_DECL){ "DECL", __null, IFSRC_DECL },
  minit ("BODY", IFSRC_IFBODY){ "BODY", __null, IFSRC_IFBODY }
81};

83const mstring save_status[] =
84{
  minit ("UNKNOWN", SAVE_NONE){ "UNKNOWN", __null, SAVE_NONE },
  minit ("EXPLICIT-SAVE", SAVE_EXPLICIT){ "EXPLICIT-SAVE", __null, SAVE_EXPLICIT },
  minit ("IMPLICIT-SAVE", SAVE_IMPLICIT){ "IMPLICIT-SAVE", __null, SAVE_IMPLICIT },
88};

90/* Set the mstrings for DTIO procedure names.  */
91const mstring dtio_procs[] =
92{
  minit ("_dtio_formatted_read", DTIO_RF){ "_dtio_formatted_read", __null, DTIO_RF },
  minit ("_dtio_formatted_write", DTIO_WF){ "_dtio_formatted_write", __null, DTIO_WF },
  minit ("_dtio_unformatted_read", DTIO_RUF){ "_dtio_unformatted_read", __null, DTIO_RUF },
  minit ("_dtio_unformatted_write", DTIO_WUF){ "_dtio_unformatted_write", __null, DTIO_WUF },
97};

99/* This is to make sure the backend generates setup code in the correct
 order.  */

102static int next_dummy_order = 1;


105gfc_namespace *gfc_current_ns;
106gfc_namespace *gfc_global_ns_list;

108gfc_gsymbol *gfc_gsym_root = NULL__null;

110gfc_symbol *gfc_derived_types;

112static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL__null };
113static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;


116/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/

118/* The following static variable indicates whether a particular element has
 been explicitly set or not.  */

121static int new_flag[GFC_LETTERS26];


124/* Handle a correctly parsed IMPLICIT NONE.  */

126void
127gfc_set_implicit_none (bool type, bool external, locus *loc)
128{
int i;

if (external)
  gfc_current_ns->has_implicit_none_export = 1;

if (type)
  {
    gfc_current_ns->seen_implicit_none = 1;
    for (i = 0; i < GFC_LETTERS26; i++)
{
 if (gfc_current_ns->set_flag[i])
   {
     gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
	     "IMPLICIT statement", loc);
     return;
   }
 gfc_clear_ts (&gfc_current_ns->default_type[i]);
 gfc_current_ns->set_flag[i] = 1;
}
  }
149}


152/* Reset the implicit range flags.  */

154void
155gfc_clear_new_implicit (void)
156{
int i;

for (i = 0; i < GFC_LETTERS26; i++)
  new_flag[i] = 0;
161}


164/* Prepare for a new implicit range.  Sets flags in new_flag[].  */

166bool
167gfc_add_new_implicit_range (int c1, int c2)
168{
int i;

c1 -= 'a';
c2 -= 'a';

for (i = c1; i <= c2; i++)
  {
    if (new_flag[i])
{
 gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
     i + 'A');
 return false;
}

    new_flag[i] = 1;
  }

return true;
187}


190/* Add a matched implicit range for gfc_set_implicit().  Check if merging
 the new implicit types back into the existing types will work.  */

193bool
194gfc_merge_new_implicit (gfc_typespec *ts)
195{
int i;

if (gfc_current_ns->seen_implicit_none)
  {
    gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
    return false;
  }

for (i = 0; i < GFC_LETTERS26; i++)
  {
    if (new_flag[i])
{
 if (gfc_current_ns->set_flag[i])
   {
     gfc_error ("Letter %qc already has an IMPLICIT type at %C",
	 i + 'A');
     return false;
   }

 gfc_current_ns->default_type[i] = *ts;
 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
 gfc_current_ns->set_flag[i] = 1;
}
  }
return true;
221}


224/* Given a symbol, return a pointer to the typespec for its default type.  */

226gfc_typespec *
227gfc_get_default_type (const char *name, gfc_namespace *ns)
228{
char letter;

letter = name[0];

if (flag_allow_leading_underscoreglobal_options.x_flag_allow_leading_underscore && letter == '_')
  gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
     "gfortran developers, and should not be used for "
     "implicitly typed variables");

if (letter < 'a' || letter > 'z')
  gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name);

if (ns == NULL__null)
  ns = gfc_current_ns;

return &ns->default_type[letter - 'a'];
245}


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

251static void
252lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
		     char **&candidates,
		     size_t &candidates_len)
255{
gfc_symtree *p;

if (sym == NULL__null)
  return;

if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
  vec_push (candidates, candidates_len, sym->name);
p = sym->left;
if (p)
  lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);

p = sym->right;
if (p)
  lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
270}


273/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account.  */

275static const char*
276lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
277{
char **candidates = NULL__null;
size_t candidates_len = 0;
lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
		       candidates_len);
return gfc_closest_fuzzy_match (sym_name, candidates);
283}


286/* Given a pointer to a symbol, set its type according to the first
 letter of its name.  Fails if the letter in question has no default
 type.  */

290bool
291gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
292{
gfc_typespec *ts;

if (sym->ts.type != BT_UNKNOWN)
  gfc_internal_error ("gfc_set_default_type(): symbol already has a type");

ts = gfc_get_default_type (sym->name, ns);

if (ts->type == BT_UNKNOWN)
  {
    if (error_flag && !sym->attr.untyped)
{
 const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
 if (guessed)
   gfc_error ("Symbol %qs at %L has no IMPLICIT type"
       "; did you mean %qs?",
       sym->name, &sym->declared_at, guessed);
 else
   gfc_error ("Symbol %qs at %L has no IMPLICIT type",
       sym->name, &sym->declared_at);
 sym->attr.untyped = 1; /* Ensure we only give an error once.  */
}

    return false;
  }

sym->ts = *ts;
sym->attr.implicit_type = 1;

if (ts->type == BT_CHARACTER && ts->u.cl)
  sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
else if (ts->type == BT_CLASS
  && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
  return false;

if (sym->attr.is_bind_c == 1 && warn_c_binding_typeglobal_options.x_warn_c_binding_type)
  {
    /* BIND(C) variables should not be implicitly declared.  */
    gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) "
       "variable %qs at %L may not be C interoperable",
       sym->name, &sym->declared_at);
    sym->ts.f90_type = sym->ts.type;
  }

if (sym->attr.dummy != 0)
  {
    if (sym->ns->proc_name != NULL__null
 && (sym->ns->proc_name->attr.subroutine != 0
     || sym->ns->proc_name->attr.function != 0)
 && sym->ns->proc_name->attr.is_bind_c != 0
 && warn_c_binding_typeglobal_options.x_warn_c_binding_type)
      {
        /* Dummy args to a BIND(C) routine may not be interoperable if
           they are implicitly typed.  */
        gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable "
	   "%qs at %L may not be C interoperable but it is a "
	   "dummy argument to the BIND(C) procedure %qs at %L",
	   sym->name, &(sym->declared_at),
	   sym->ns->proc_name->name,
                         &(sym->ns->proc_name->declared_at));
        sym->ts.f90_type = sym->ts.type;
      }
  }

return true;
357}


360/* This function is called from parse.c(parse_progunit) to check the
 type of the function is not implicitly typed in the host namespace
 and to implicitly type the function result, if necessary.  */

364void
365gfc_check_function_type (gfc_namespace *ns)
366{
gfc_symbol *proc = ns->proc_name;

if (!proc->attr.contained || proc->result->attr.implicit_type)
  return;

if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL__null)
  {
    if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
{
 if (proc->result != proc)
   {
     proc->ts = proc->result->ts;
     proc->as = gfc_copy_array_spec (proc->result->as);
     proc->attr.dimension = proc->result->attr.dimension;
     proc->attr.pointer = proc->result->attr.pointer;
     proc->attr.allocatable = proc->result->attr.allocatable;
   }
}
    else if (!proc->result->attr.proc_pointer)
{
 gfc_error ("Function result %qs at %L has no IMPLICIT type",
     proc->result->name, &proc->result->declared_at);
 proc->result->attr.untyped = 1;
}
  }
392}


395/******************** Symbol attribute stuff *********************/

397/* This is a generic conflict-checker.  We do this to avoid having a
 single conflict in two places.  */

400#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
401#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
402#define conf_std(a, b, std) if (attr->a && attr->b)\
                            {\
                              a1 = a;\
                              a2 = b;\
                              standard = std;\
                              goto conflict_std;\
                            }

410bool
411gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
412{
static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
  *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
  *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
  *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
  *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
  *privat = "PRIVATE", *recursive = "RECURSIVE",
  *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
  *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
  *function = "FUNCTION", *subroutine = "SUBROUTINE",
  *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
  *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
  *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
  *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
  *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
  *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
  *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
  *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC",
  *pdt_len = "LEN", *pdt_kind = "KIND";
static const char *threadprivate = "THREADPRIVATE";
static const char *omp_declare_target = "OMP DECLARE TARGET";
static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK";
static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
static const char *oacc_declare_create = "OACC DECLARE CREATE";
static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR";
static const char *oacc_declare_device_resident =
				"OACC DECLARE DEVICE_RESIDENT";

const char *a1, *a2;
int standard;

if (attr->artificial)
  return true;

if (where == NULL__null)
  where = &gfc_current_locus;

if (attr->pointer && attr->intent != INTENT_UNKNOWN)
  {
    a1 = pointer;
    a2 = intent;
    standard = GFC_STD_F2003(1<<4);
    goto conflict_std;
  }

if (attr->in_namelist && (attr->allocatable || attr->pointer))
  {
    a1 = in_namelist;
    a2 = attr->allocatable ? allocatable : pointer;
    standard = GFC_STD_F2003(1<<4);
    goto conflict_std;
  }

/* Check for attributes not allowed in a BLOCK DATA.  */
if (gfc_current_state ()(gfc_state_stack->state) == COMP_BLOCK_DATA)
  {
    a1 = NULL__null;

    if (attr->in_namelist)
a1 = in_namelist;
    if (attr->allocatable)
a1 = allocatable;
    if (attr->external)
a1 = external;
    if (attr->optional)
a1 = optional;
    if (attr->access == ACCESS_PRIVATE)
a1 = privat;
    if (attr->access == ACCESS_PUBLIC)
a1 = publik;
    if (attr->intent != INTENT_UNKNOWN)
a1 = intent;

    if (a1 != NULL__null)
{
 gfc_error
   ("%s attribute not allowed in BLOCK DATA program unit at %L",
    a1, where);
 return false;
}
  }

if (attr->save == SAVE_EXPLICIT)
  {
    conf (dummy, save);
    conf (in_common, save);
    conf (result, save);
    conf (automatic, save);

    switch (attr->flavor)
{
 case FL_PROGRAM:
 case FL_BLOCK_DATA:
 case FL_MODULE:
 case FL_LABEL:
 case_fl_structcase FL_DERIVED: case FL_UNION: case FL_STRUCT:
 case FL_PARAMETER:
          a1 = gfc_code2string (flavors, attr->flavor);
          a2 = save;
   goto conflict;
 case FL_NAMELIST:
   gfc_error ("Namelist group name at %L cannot have the "
       "SAVE attribute", where);
   return false;
 case FL_PROCEDURE:
   /* Conflicts between SAVE and PROCEDURE will be checked at
      resolution stage, see "resolve_fl_procedure".  */
 case FL_VARIABLE:
 default:
   break;
}
  }

/* The copying of procedure dummy arguments for module procedures in
   a submodule occur whilst the current state is COMP_CONTAINS. It
   is necessary, therefore, to let this through.  */
if (name && attr->dummy
    && (attr->function || attr->subroutine)
    && gfc_current_state ()(gfc_state_stack->state) == COMP_CONTAINS
    && !(gfc_new_block && gfc_new_block->abr_modproc_decl))
  gfc_error_now ("internal procedure %qs at %L conflicts with "
   "DUMMY argument", name, where);

conf (dummy, entry);
conf (dummy, intrinsic);
conf (dummy, threadprivate);
conf (dummy, omp_declare_target);
conf (dummy, omp_declare_target_link);
conf (pointer, target);
conf (pointer, intrinsic);
conf (pointer, elemental);
conf (pointer, codimension);
conf (allocatable, elemental);

conf (in_common, automatic);
conf (result, automatic);
conf (use_assoc, automatic);
conf (dummy, automatic);

conf (target, external);
conf (target, intrinsic);

if (!attr->if_source)
  conf (external, dimension);   /* See Fortran 95's R504.  */

conf (external, intrinsic);
conf (entry, intrinsic);
conf (abstract, intrinsic);

if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
  conf (external, subroutine);

if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003(1<<4),
			     "Procedure pointer at %C"))
  return false;

conf (allocatable, pointer);
conf_std (allocatable, dummy, GFC_STD_F2003(1<<4));
conf_std (allocatable, function, GFC_STD_F2003(1<<4));
conf_std (allocatable, result, GFC_STD_F2003(1<<4));
conf_std (elemental, recursive, GFC_STD_F2018(1<<9));

conf (in_common, dummy);
conf (in_common, allocatable);
conf (in_common, codimension);
conf (in_common, result);

conf (in_equivalence, use_assoc);
conf (in_equivalence, codimension);
conf (in_equivalence, dummy);
conf (in_equivalence, target);
conf (in_equivalence, pointer);
conf (in_equivalence, function);
conf (in_equivalence, result);
conf (in_equivalence, entry);
conf (in_equivalence, allocatable);
conf (in_equivalence, threadprivate);
conf (in_equivalence, omp_declare_target);
conf (in_equivalence, omp_declare_target_link);
conf (in_equivalence, oacc_declare_create);
conf (in_equivalence, oacc_declare_copyin);
conf (in_equivalence, oacc_declare_deviceptr);
conf (in_equivalence, oacc_declare_device_resident);
conf (in_equivalence, is_bind_c);

conf (dummy, result);
conf (entry, result);
conf (generic, result);
conf (generic, omp_declare_target);
conf (generic, omp_declare_target_link);

conf (function, subroutine);

if (!function && !subroutine)
  conf (is_bind_c, dummy);

conf (is_bind_c, cray_pointer);
conf (is_bind_c, cray_pointee);
conf (is_bind_c, codimension);
conf (is_bind_c, allocatable);
conf (is_bind_c, elemental);

/* Need to also get volatile attr, according to 5.1 of F2003 draft.
   Parameter conflict caught below.  Also, value cannot be specified
   for a dummy procedure.  */

/* Cray pointer/pointee conflicts.  */
conf (cray_pointer, cray_pointee);
conf (cray_pointer, dimension);
conf (cray_pointer, codimension);
conf (cray_pointer, contiguous);
conf (cray_pointer, pointer);
conf (cray_pointer, target);
conf (cray_pointer, allocatable);
conf (cray_pointer, external);
conf (cray_pointer, intrinsic);
conf (cray_pointer, in_namelist);
conf (cray_pointer, function);
conf (cray_pointer, subroutine);
conf (cray_pointer, entry);

conf (cray_pointee, allocatable);
conf (cray_pointee, contiguous);
conf (cray_pointee, codimension);
conf (cray_pointee, intent);
conf (cray_pointee, optional);
conf (cray_pointee, dummy);
conf (cray_pointee, target);
conf (cray_pointee, intrinsic);
conf (cray_pointee, pointer);
conf (cray_pointee, entry);
conf (cray_pointee, in_common);
conf (cray_pointee, in_equivalence);
conf (cray_pointee, threadprivate);
conf (cray_pointee, omp_declare_target);
conf (cray_pointee, omp_declare_target_link);
conf (cray_pointee, oacc_declare_create);
conf (cray_pointee, oacc_declare_copyin);
conf (cray_pointee, oacc_declare_deviceptr);
conf (cray_pointee, oacc_declare_device_resident);

conf (data, dummy);
conf (data, function);
conf (data, result);
conf (data, allocatable);

conf (value, pointer)
conf (value, allocatable)
conf (value, subroutine)
conf (value, function)
conf (value, volatile_)
conf (value, dimension)
conf (value, codimension)
conf (value, external)

conf (codimension, result)

if (attr->value
    && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
  {
    a1 = value;
    a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
    goto conflict;
  }

conf (is_protected, intrinsic)
conf (is_protected, in_common)

conf (asynchronous, intrinsic)
conf (asynchronous, external)

conf (volatile_, intrinsic)
conf (volatile_, external)

if (attr->volatile_ && attr->intent == INTENT_IN)
  {
    a1 = volatile_;
    a2 = intent_in;
    goto conflict;
  }

conf (procedure, allocatable)
conf (procedure, dimension)
conf (procedure, codimension)
conf (procedure, intrinsic)
conf (procedure, target)
conf (procedure, value)
conf (procedure, volatile_)
conf (procedure, asynchronous)
conf (procedure, entry)

conf (proc_pointer, abstract)
conf (proc_pointer, omp_declare_target)
conf (proc_pointer, omp_declare_target_link)

conf (entry, omp_declare_target)
conf (entry, omp_declare_target_link)
conf (entry, oacc_declare_create)
conf (entry, oacc_declare_copyin)
conf (entry, oacc_declare_deviceptr)
conf (entry, oacc_declare_device_resident)

conf (pdt_kind, allocatable)
conf (pdt_kind, pointer)
conf (pdt_kind, dimension)
conf (pdt_kind, codimension)

conf (pdt_len, allocatable)
conf (pdt_len, pointer)
conf (pdt_len, dimension)
conf (pdt_len, codimension)

if (attr->access == ACCESS_PRIVATE)
  {
    a1 = privat;
    conf2 (pdt_kind);
    conf2 (pdt_len);
  }

a1 = gfc_code2string (flavors, attr->flavor);

if (attr->in_namelist
    && attr->flavor != FL_VARIABLE
    && attr->flavor != FL_PROCEDURE
    && attr->flavor != FL_UNKNOWN)
  {
    a2 = in_namelist;
    goto conflict;
  }

switch (attr->flavor)
  {
  case FL_PROGRAM:
  case FL_BLOCK_DATA:
  case FL_MODULE:
  case FL_LABEL:
    conf2 (codimension);
    conf2 (dimension);
    conf2 (dummy);
    conf2 (volatile_);
    conf2 (asynchronous);
    conf2 (contiguous);
    conf2 (pointer);
    conf2 (is_protected);
    conf2 (target);
    conf2 (external);
    conf2 (intrinsic);
    conf2 (allocatable);
    conf2 (result);
    conf2 (in_namelist);
    conf2 (optional);
    conf2 (function);
    conf2 (subroutine);
    conf2 (threadprivate);
    conf2 (omp_declare_target);
    conf2 (omp_declare_target_link);
    conf2 (oacc_declare_create);
    conf2 (oacc_declare_copyin);
    conf2 (oacc_declare_deviceptr);
    conf2 (oacc_declare_device_resident);

    if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
{
 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
   name, where);
 return false;
}

    if (attr->is_bind_c)
{
 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
 return false;
}

    break;

  case FL_VARIABLE:
    break;

  case FL_NAMELIST:
    conf2 (result);
    break;

  case FL_PROCEDURE:
    /* Conflicts with INTENT, SAVE and RESULT will be checked
at resolution stage, see "resolve_fl_procedure".  */

    if (attr->subroutine)
{
 a1 = subroutine;
 conf2 (target);
 conf2 (allocatable);
 conf2 (volatile_);
 conf2 (asynchronous);
 conf2 (in_namelist);
 conf2 (codimension);
 conf2 (dimension);
 conf2 (function);
 if (!attr->proc_pointer)
   conf2 (threadprivate);
}

    /* Procedure pointers in COMMON blocks are allowed in F03,
     * but forbidden per F08:C5100.  */
    if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008(1<<7)))
conf2 (in_common);

    conf2 (omp_declare_target_link);

    switch (attr->proc)
{
case PROC_ST_FUNCTION:
 conf2 (dummy);
 conf2 (target);
 break;

case PROC_MODULE:
 conf2 (dummy);
 break;

case PROC_DUMMY:
 conf2 (result);
 conf2 (threadprivate);
 break;

default:
 break;
}

    break;

  case_fl_structcase FL_DERIVED: case FL_UNION: case FL_STRUCT:
    conf2 (dummy);
    conf2 (pointer);
    conf2 (target);
    conf2 (external);
    conf2 (intrinsic);
    conf2 (allocatable);
    conf2 (optional);
    conf2 (entry);
    conf2 (function);
    conf2 (subroutine);
    conf2 (threadprivate);
    conf2 (result);
    conf2 (omp_declare_target);
    conf2 (omp_declare_target_link);
    conf2 (oacc_declare_create);
    conf2 (oacc_declare_copyin);
    conf2 (oacc_declare_deviceptr);
    conf2 (oacc_declare_device_resident);

    if (attr->intent != INTENT_UNKNOWN)
{
 a2 = intent;
 goto conflict;
}
    break;

  case FL_PARAMETER:
    conf2 (external);
    conf2 (intrinsic);
    conf2 (optional);
    conf2 (allocatable);
    conf2 (function);
    conf2 (subroutine);
    conf2 (entry);
    conf2 (contiguous);
    conf2 (pointer);
    conf2 (is_protected);
    conf2 (target);
    conf2 (dummy);
    conf2 (in_common);
    conf2 (value);
    conf2 (volatile_);
    conf2 (asynchronous);
    conf2 (threadprivate);
    conf2 (value);
    conf2 (codimension);
    conf2 (result);
    if (!attr->is_iso_c)
conf2 (is_bind_c);
    break;

  default:
    break;
  }

return true;

902conflict:
if (name == NULL__null)
  gfc_error ("%s attribute conflicts with %s attribute at %L",
      a1, a2, where);
else
  gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
      a1, a2, name, where);

return false;

912conflict_std:
if (name == NULL__null)
  {
    return gfc_notify_std (standard, "%s attribute conflicts "
                           "with %s attribute at %L", a1, a2,
                           where);
  }
else
  {
    return gfc_notify_std (standard, "%s attribute conflicts "
	     "with %s attribute in %qs at %L",
                           a1, a2, name, where);
  }
925}

927#undef conf
928#undef conf2
929#undef conf_std


932/* Mark a symbol as referenced.  */

934void
935gfc_set_sym_referenced (gfc_symbol *sym)
936{

if (sym->attr.referenced)
  return;

sym->attr.referenced = 1;

/* Remember which order dummy variables are accessed in.  */
if (sym->attr.dummy)
  sym->dummy_order = next_dummy_order++;
946}


949/* Common subroutine called by attribute changing subroutines in order
 to prevent them from changing a symbol that has been
 use-associated.  Returns zero if it is OK to change the symbol,
 nonzero if not.  */

954static int
955check_used (symbol_attribute *attr, const char *name, locus *where)
956{

if (attr->use_assoc == 0)
  return 0;

if (where == NULL__null)
  where = &gfc_current_locus;

if (name == NULL__null)
  gfc_error ("Cannot change attributes of USE-associated symbol at %L",
      where);
else
  gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
      name, where);

return 1;
972}


975/* Generate an error because of a duplicate attribute.  */

977static void
978duplicate_attr (const char *attr, locus *where)
979{

if (where == NULL__null)
  where = &gfc_current_locus;

gfc_error ("Duplicate %s attribute specified at %L", attr, where);
985}


988bool
989gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
       locus *where ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
991{
attr->ext_attr |= 1 << ext_attr;
return true;
994}


997/* Called from decl.c (attr_decl1) to check attributes, when declared
 separately.  */

1000bool
1001gfc_add_attribute (symbol_attribute *attr, locus *where)
1002{
if (check_used (attr, NULL__null, where))
  return false;

return gfc_check_conflict (attr, NULL__null, where);
1007}


1010bool
1011gfc_add_allocatable (symbol_attribute *attr, locus *where)
1012{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->allocatable && ! gfc_submodule_procedure(attr)(gfc_state_stack->previous && gfc_state_stack->
previous->previous && gfc_state_stack->previous
->previous->state == COMP_SUBMODULE && attr->
module_procedure))
  {
    duplicate_attr ("ALLOCATABLE", where);
    return false;
  }

if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
    && !gfc_find_state (COMP_INTERFACE))
  {
    gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
 where);
    return false;
  }

attr->allocatable = 1;
return gfc_check_conflict (attr, NULL__null, where);
1033}


1036bool
1037gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
1038{
if (check_used (attr, name, where))
  return false;

if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY(1<<6),
"Duplicate AUTOMATIC attribute specified at %L", where))
  return false;

attr->automatic = 1;
return gfc_check_conflict (attr, name, where);
1048}


1051bool
1052gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
1053{

if (check_used (attr, name, where))
  return false;

if (attr->codimension)
  {
    duplicate_attr ("CODIMENSION", where);
    return false;
  }

if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
    && !gfc_find_state (COMP_INTERFACE))
  {
    gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
 "at %L", name, where);
    return false;
  }

attr->codimension = 1;
return gfc_check_conflict (attr, name, where);
1074}


1077bool
1078gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
1079{

if (check_used (attr, name, where))
  return false;

if (attr->dimension && ! gfc_submodule_procedure(attr)(gfc_state_stack->previous && gfc_state_stack->
previous->previous && gfc_state_stack->previous
->previous->state == COMP_SUBMODULE && attr->
module_procedure))
  {
    duplicate_attr ("DIMENSION", where);
    return false;
  }

if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
    && !gfc_find_state (COMP_INTERFACE))
  {
    gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
 "at %L", name, where);
    return false;
  }

attr->dimension = 1;
return gfc_check_conflict (attr, name, where);
1100}


1103bool
1104gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
1105{

if (check_used (attr, name, where))
  return false;

attr->contiguous = 1;
return gfc_check_conflict (attr, name, where);
1112}


1115bool
1116gfc_add_external (symbol_attribute *attr, locus *where)
1117{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->external)
  {
    duplicate_attr ("EXTERNAL", where);
    return false;
  }

if (attr->pointer && attr->if_source != IFSRC_IFBODY)
  {
    attr->pointer = 0;
    attr->proc_pointer = 1;
  }

attr->external = 1;

return gfc_check_conflict (attr, NULL__null, where);
1137}


1140bool
1141gfc_add_intrinsic (symbol_attribute *attr, locus *where)
1142{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->intrinsic)
  {
    duplicate_attr ("INTRINSIC", where);
    return false;
  }

attr->intrinsic = 1;

return gfc_check_conflict (attr, NULL__null, where);
1156}


1159bool
1160gfc_add_optional (symbol_attribute *attr, locus *where)
1161{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->optional)
  {
    duplicate_attr ("OPTIONAL", where);
    return false;
  }

attr->optional = 1;
return gfc_check_conflict (attr, NULL__null, where);
1174}

1176bool
1177gfc_add_kind (symbol_attribute *attr, locus *where)
1178{
if (attr->pdt_kind)
  {
    duplicate_attr ("KIND", where);
    return false;
  }

attr->pdt_kind = 1;
return gfc_check_conflict (attr, NULL__null, where);
1187}

1189bool
1190gfc_add_len (symbol_attribute *attr, locus *where)
1191{
if (attr->pdt_len)
  {
    duplicate_attr ("LEN", where);
    return false;
  }

attr->pdt_len = 1;
return gfc_check_conflict (attr, NULL__null, where);
1200}


1203bool
1204gfc_add_pointer (symbol_attribute *attr, locus *where)
1205{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
    && !gfc_find_state (COMP_INTERFACE))
    && ! gfc_submodule_procedure(attr)(gfc_state_stack->previous && gfc_state_stack->
previous->previous && gfc_state_stack->previous
->previous->state == COMP_SUBMODULE && attr->
module_procedure))
  {
    duplicate_attr ("POINTER", where);
    return false;
  }

if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
    || (attr->if_source == IFSRC_IFBODY
    && !gfc_find_state (COMP_INTERFACE)))
  attr->proc_pointer = 1;
else
  attr->pointer = 1;

return gfc_check_conflict (attr, NULL__null, where);
1226}


1229bool
1230gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1231{

if (check_used (attr, NULL__null, where))
  return false;

attr->cray_pointer = 1;
return gfc_check_conflict (attr, NULL__null, where);
1238}


1241bool
1242gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1243{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->cray_pointee)
  {
    gfc_error ("Cray Pointee at %L appears in multiple pointer()"
 " statements", where);
    return false;
  }

attr->cray_pointee = 1;
return gfc_check_conflict (attr, NULL__null, where);
1257}


1260bool
1261gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1262{
if (check_used (attr, name, where))
  return false;

if (attr->is_protected)
  {
if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
	     "Duplicate PROTECTED attribute specified at %L",
	     where))
 return false;
  }

attr->is_protected = 1;
return gfc_check_conflict (attr, name, where);
1276}


1279bool
1280gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1281{

if (check_used (attr, name, where))
  return false;

attr->result = 1;
return gfc_check_conflict (attr, name, where);
1288}


1291bool
1292gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
     locus *where)
1294{

if (check_used (attr, name, where))
  return false;

if (s == SAVE_EXPLICIT && gfc_pure (NULL__null))
  {
    gfc_error
("SAVE attribute at %L cannot be specified in a PURE procedure",
where);
    return false;
  }

if (s == SAVE_EXPLICIT)
  gfc_unset_implicit_pure (NULL__null);

if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT
    && (flag_automaticglobal_options.x_flag_automatic || pedanticglobal_options.x_pedantic))
  {
if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
	     "Duplicate SAVE attribute specified at %L",
	     where))
 return false;
  }

attr->save = s;
return gfc_check_conflict (attr, name, where);
1321}


1324bool
1325gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1326{

if (check_used (attr, name, where))
  return false;

if (attr->value)
  {
if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
	     "Duplicate VALUE attribute specified at %L",
	     where))
 return false;
  }

attr->value = 1;
return gfc_check_conflict (attr, name, where);
1341}


1344bool
1345gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1346{
/* No check_used needed as 11.2.1 of the F2003 standard allows
   that the local identifier made accessible by a use statement can be
   given a VOLATILE attribute - unless it is a coarray (F2008, C560).  */

if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
  if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
	 "Duplicate VOLATILE attribute specified at %L",
	 where))
    return false;

/* F2008:  C1282 A designator of a variable with the VOLATILE attribute
   shall not appear in a pure subprogram.

   F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
   construct within a pure subprogram, shall not have the SAVE or
   VOLATILE attribute.  */
if (gfc_pure (NULL__null))
  {
    gfc_error ("VOLATILE attribute at %L cannot be specified in a "
 "PURE procedure", where);
    return false;
  }


attr->volatile_ = 1;
attr->volatile_ns = gfc_current_ns;
return gfc_check_conflict (attr, name, where);
1374}


1377bool
1378gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1379{
/* No check_used needed as 11.2.1 of the F2003 standard allows
   that the local identifier made accessible by a use statement can be
   given a ASYNCHRONOUS attribute.  */

if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
  if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
	 "Duplicate ASYNCHRONOUS attribute specified at %L",
	 where))
    return false;

attr->asynchronous = 1;
attr->asynchronous_ns = gfc_current_ns;
return gfc_check_conflict (attr, name, where);
1393}


1396bool
1397gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1398{

if (check_used (attr, name, where))
  return false;

if (attr->threadprivate)
  {
    duplicate_attr ("THREADPRIVATE", where);
    return false;
  }

attr->threadprivate = 1;
return gfc_check_conflict (attr, name, where);
1411}


1414bool
1415gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
	    locus *where)
1417{

if (check_used (attr, name, where))
  return false;

if (attr->omp_declare_target)
  return true;

attr->omp_declare_target = 1;
return gfc_check_conflict (attr, name, where);
1427}


1430bool
1431gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
		 locus *where)
1433{

if (check_used (attr, name, where))
  return false;

if (attr->omp_declare_target_link)
  return true;

attr->omp_declare_target_link = 1;
return gfc_check_conflict (attr, name, where);
1443}


1446bool
1447gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
	     locus *where)
1449{
if (check_used (attr, name, where))
  return false;

if (attr->oacc_declare_create)
  return true;

attr->oacc_declare_create = 1;
return gfc_check_conflict (attr, name, where);
1458}


1461bool
1462gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name,
	     locus *where)
1464{
if (check_used (attr, name, where))
  return false;

if (attr->oacc_declare_copyin)
  return true;

attr->oacc_declare_copyin = 1;
return gfc_check_conflict (attr, name, where);
1473}


1476bool
1477gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name,
		locus *where)
1479{
if (check_used (attr, name, where))
  return false;

if (attr->oacc_declare_deviceptr)
  return true;

attr->oacc_declare_deviceptr = 1;
return gfc_check_conflict (attr, name, where);
1488}


1491bool
1492gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name,
		      locus *where)
1494{
if (check_used (attr, name, where))
  return false;

if (attr->oacc_declare_device_resident)
  return true;

attr->oacc_declare_device_resident = 1;
return gfc_check_conflict (attr, name, where);
1503}


1506bool
1507gfc_add_target (symbol_attribute *attr, locus *where)
1508{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->target)
  {
    duplicate_attr ("TARGET", where);
    return false;
  }

attr->target = 1;
return gfc_check_conflict (attr, NULL__null, where);
1521}


1524bool
1525gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1526{

if (check_used (attr, name, where))
  return false;

/* Duplicate dummy arguments are allowed due to ENTRY statements.  */
attr->dummy = 1;
return gfc_check_conflict (attr, name, where);
1534}


1537bool
1538gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1539{

if (check_used (attr, name, where))
  return false;

/* Duplicate attribute already checked for.  */
attr->in_common = 1;
return gfc_check_conflict (attr, name, where);
1547}


1550bool
1551gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1552{

/* Duplicate attribute already checked for.  */
attr->in_equivalence = 1;
if (!gfc_check_conflict (attr, name, where))
  return false;

if (attr->flavor == FL_VARIABLE)
  return true;

return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1563}


1566bool
1567gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1568{

if (check_used (attr, name, where))
  return false;

attr->data = 1;
return gfc_check_conflict (attr, name, where);
1575}


1578bool
1579gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1580{

attr->in_namelist = 1;
return gfc_check_conflict (attr, name, where);
1584}


1587bool
1588gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1589{

if (check_used (attr, name, where))
  return false;

attr->sequence = 1;
return gfc_check_conflict (attr, name, where);
1596}


1599bool
1600gfc_add_elemental (symbol_attribute *attr, locus *where)
1601{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->elemental)
  {
    duplicate_attr ("ELEMENTAL", where);
    return false;
  }

attr->elemental = 1;
return gfc_check_conflict (attr, NULL__null, where);
1614}


1617bool
1618gfc_add_pure (symbol_attribute *attr, locus *where)
1619{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->pure)
  {
    duplicate_attr ("PURE", where);
    return false;
  }

attr->pure = 1;
return gfc_check_conflict (attr, NULL__null, where);
1632}


1635bool
1636gfc_add_recursive (symbol_attribute *attr, locus *where)
1637{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->recursive)
  {
    duplicate_attr ("RECURSIVE", where);
    return false;
  }

attr->recursive = 1;
return gfc_check_conflict (attr, NULL__null, where);
1650}


1653bool
1654gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1655{

if (check_used (attr, name, where))
  return false;

if (attr->entry)
  {
    duplicate_attr ("ENTRY", where);
    return false;
  }

attr->entry = 1;
return gfc_check_conflict (attr, name, where);
1668}


1671bool
1672gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1673{

if (attr->flavor != FL_PROCEDURE
    && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
  return false;

attr->function = 1;
return gfc_check_conflict (attr, name, where);
1681}


1684bool
1685gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1686{

if (attr->flavor != FL_PROCEDURE
    && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
  return false;

attr->subroutine = 1;

/* If we are looking at a BLOCK DATA statement and we encounter a
   name with a leading underscore (which must be
   compiler-generated), do not check. See PR 84394.  */

if (name && *name != '_' && gfc_current_state ()(gfc_state_stack->state) != COMP_BLOCK_DATA)
  return gfc_check_conflict (attr, name, where);
else
  return true;
1702}


1705bool
1706gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1707{

if (attr->flavor != FL_PROCEDURE
    && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
  return false;

attr->generic = 1;
return gfc_check_conflict (attr, name, where);
1715}


1718bool
1719gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1720{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->flavor != FL_PROCEDURE
    && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
  return false;

if (attr->procedure)
  {
    duplicate_attr ("PROCEDURE", where);
    return false;
  }

attr->procedure = 1;

return gfc_check_conflict (attr, NULL__null, where);
1738}


1741bool
1742gfc_add_abstract (symbol_attribute* attr, locus* where)
1743{
if (attr->abstract)
  {
    duplicate_attr ("ABSTRACT", where);
    return false;
  }

attr->abstract = 1;

return gfc_check_conflict (attr, NULL__null, where);
1753}


1756/* Flavors are special because some flavors are not what Fortran
 considers attributes and can be reaffirmed multiple times.  */

1759bool
1760gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
locus *where)
1762{

if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
     || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f)((f) == FL_DERIVED || (f) == FL_UNION || (f) == FL_STRUCT)
     || f == FL_NAMELIST) && check_used (attr, name, where))
  return false;

if (attr->flavor == f && f == FL_VARIABLE)
  return true;

/* Copying a procedure dummy argument for a module procedure in a
   submodule results in the flavor being copied and would result in
   an error without this.  */
if (gfc_new_block && gfc_new_block->abr_modproc_decl
    && attr->flavor == f && f == FL_PROCEDURE)
  return true;

if (attr->flavor != FL_UNKNOWN)
  {
    if (where == NULL__null)
where = &gfc_current_locus;

    if (name)
      gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
   gfc_code2string (flavors, attr->flavor), name,
   gfc_code2string (flavors, f), where);
    else
      gfc_error ("%s attribute conflicts with %s attribute at %L",
   gfc_code2string (flavors, attr->flavor),
   gfc_code2string (flavors, f), where);

    return false;
  }

attr->flavor = f;

return gfc_check_conflict (attr, name, where);
1799}


1802bool
1803gfc_add_procedure (symbol_attribute *attr, procedure_type t,
   const char *name, locus *where)
1805{

if (check_used (attr, name, where))
  return false;

if (attr->flavor != FL_PROCEDURE
    && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
  return false;

if (where == NULL__null)
  where = &gfc_current_locus;

if (attr->proc != PROC_UNKNOWN && !attr->module_procedure
    && attr->access == ACCESS_UNKNOWN)
  {
    if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
 && !gfc_notification_std (GFC_STD_F2008(1<<7)))
gfc_error ("%s procedure at %L is already declared as %s "
   "procedure. \nF2008: A pointer function assignment "
   "is ambiguous if it is the first executable statement "
   "after the specification block. Please add any other "
   "kind of executable statement before it. FIXME",
 gfc_code2string (procedures, t), where,
 gfc_code2string (procedures, attr->proc));
    else
gfc_error ("%s procedure at %L is already declared as %s "
   "procedure", gfc_code2string (procedures, t), where,
   gfc_code2string (procedures, attr->proc));

    return false;
  }

attr->proc = t;

/* Statement functions are always scalar and functions.  */
if (t == PROC_ST_FUNCTION
    && ((!attr->function && !gfc_add_function (attr, name, where))
 || attr->dimension))
  return false;

return gfc_check_conflict (attr, name, where);
1846}


1849bool
1850gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1851{

if (check_used (attr, NULL__null, where))
  return false;

if (attr->intent == INTENT_UNKNOWN)
  {
    attr->intent = intent;
    return gfc_check_conflict (attr, NULL__null, where);
  }

if (where == NULL__null)
  where = &gfc_current_locus;

gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
    gfc_intent_string (attr->intent),
    gfc_intent_string (intent), where);

return false;
1870}


1873/* No checks for use-association in public and private statements.  */

1875bool
1876gfc_add_access (symbol_attribute *attr, gfc_access access,
const char *name, locus *where)
1878{

if (attr->access == ACCESS_UNKNOWN
|| (attr->use_assoc && attr->access != ACCESS_PRIVATE))
  {
    attr->access = access;
    return gfc_check_conflict (attr, name, where);
  }

if (where == NULL__null)
  where = &gfc_current_locus;
gfc_error ("ACCESS specification at %L was already specified", where);

return false;
1892}


1895/* Set the is_bind_c field for the given symbol_attribute.  */

1897bool
1898gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
                 int is_proc_lang_bind_spec)
1900{

if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
  gfc_error_now ("BIND(C) attribute at %L can only be used for "
   "variables or common blocks", where);
else if (attr->is_bind_c)
  gfc_error_now ("Duplicate BIND attribute specified at %L", where);
else
  attr->is_bind_c = 1;

if (where == NULL__null)
  where = &gfc_current_locus;

if (!gfc_notify_std (GFC_STD_F2003(1<<4), "BIND(C) at %L", where))
  return false;

return gfc_check_conflict (attr, name, where);
1917}


1920/* Set the extension field for the given symbol_attribute.  */

1922bool
1923gfc_add_extension (symbol_attribute *attr, locus *where)
1924{
if (where == NULL__null)
  where = &gfc_current_locus;

if (attr->extension)
  gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
else
  attr->extension = 1;

if (!gfc_notify_std (GFC_STD_F2003(1<<4), "EXTENDS at %L", where))
  return false;

return true;
1937}


1940bool
1941gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
	    gfc_formal_arglist * formal, locus *where)
1943{
if (check_used (&sym->attr, sym->name, where))
  return false;

/* Skip the following checks in the case of a module_procedures in a
   submodule since they will manifestly fail.  */
if (sym->attr.module_procedure == 1
    && source == IFSRC_DECL)
  goto finish;

if (where == NULL__null)
  where = &gfc_current_locus;

if (sym->attr.if_source != IFSRC_UNKNOWN
    && sym->attr.if_source != IFSRC_DECL)
  {
    gfc_error ("Symbol %qs at %L already has an explicit interface",
 sym->name, where);
    return false;
  }

if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
  {
    gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
 "body", sym->name, where);
    return false;
  }

1971finish:
sym->formal = formal;
sym->attr.if_source = source;

return true;
1976}


1979/* Add a type to a symbol.  */

1981bool
1982gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1983{
sym_flavor flavor;
bt type;

if (where == NULL__null)
  where = &gfc_current_locus;

if (sym->result)
  type = sym->result->ts.type;
else
  type = sym->ts.type;

if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
  type = sym->ns->proc_name->ts.type;

if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)
    && !(gfc_state_stack->previous && gfc_state_stack->previous->previous
  && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
    && !sym->attr.module_procedure)
  {
    if (sym->attr.use_assoc)
gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
   "use-associated at %L", sym->name, where, sym->module,
   &sym->declared_at);
    else if (sym->attr.function && sym->attr.result)
gfc_error ("Symbol %qs at %L already has basic type of %s",
   sym->ns->proc_name->name, where, gfc_basic_typename (type));
    else
gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name,
   where, gfc_basic_typename (type));
    return false;
  }

if (sym->attr.procedure && sym->ts.interface)
  {
    gfc_error ("Procedure %qs at %L may not have basic type of %s",
 sym->name, where, gfc_basic_typename (ts->type));
    return false;
  }

flavor = sym->attr.flavor;

if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
    || flavor == FL_LABEL
    || (flavor == FL_PROCEDURE && sym->attr.subroutine)
    || flavor == FL_DERIVED || flavor == FL_NAMELIST)
  {
    gfc_error ("Symbol %qs at %L cannot have a type",
 sym->ns->proc_name ? sym->ns->proc_name->name : sym->name,
 where);
    return false;
  }

sym->ts = *ts;
return true;
2038}


2041/* Clears all attributes.  */

2043void
2044gfc_clear_attr (symbol_attribute *attr)
2045{
memset (attr, 0, sizeof (symbol_attribute));
2047}


2050/* Check for missing attributes in the new symbol.  Currently does
 nothing, but it's not clear that it is unnecessary yet.  */

2053bool
2054gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
  locus *where ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
2056{

return true;
2059}


2062/* Copy an attribute to a symbol attribute, bit by bit.  Some
 attributes have a lot of side-effects but cannot be present given
 where we are called from, so we ignore some bits.  */

2066bool
2067gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
2068{
int is_proc_lang_bind_spec;

/* In line with the other attributes, we only add bits but do not remove
   them; cf. also PR 41034.  */
dest->ext_attr |= src->ext_attr;

if (src->allocatable && !gfc_add_allocatable (dest, where))
  goto fail;

if (src->automatic && !gfc_add_automatic (dest, NULL__null, where))
  goto fail;
if (src->dimension && !gfc_add_dimension (dest, NULL__null, where))
  goto fail;
if (src->codimension && !gfc_add_codimension (dest, NULL__null, where))
  goto fail;
if (src->contiguous && !gfc_add_contiguous (dest, NULL__null, where))
  goto fail;
if (src->optional && !gfc_add_optional (dest, where))
  goto fail;
if (src->pointer && !gfc_add_pointer (dest, where))
  goto fail;
if (src->is_protected && !gfc_add_protected (dest, NULL__null, where))
  goto fail;
if (src->save && !gfc_add_save (dest, src->save, NULL__null, where))
  goto fail;
if (src->value && !gfc_add_value (dest, NULL__null, where))
  goto fail;
if (src->volatile_ && !gfc_add_volatile (dest, NULL__null, where))
  goto fail;
if (src->asynchronous && !gfc_add_asynchronous (dest, NULL__null, where))
  goto fail;
if (src->threadprivate
    && !gfc_add_threadprivate (dest, NULL__null, where))
  goto fail;
if (src->omp_declare_target
    && !gfc_add_omp_declare_target (dest, NULL__null, where))
  goto fail;
if (src->omp_declare_target_link
    && !gfc_add_omp_declare_target_link (dest, NULL__null, where))
  goto fail;
if (src->oacc_declare_create
    && !gfc_add_oacc_declare_create (dest, NULL__null, where))
  goto fail;
if (src->oacc_declare_copyin
    && !gfc_add_oacc_declare_copyin (dest, NULL__null, where))
  goto fail;
if (src->oacc_declare_deviceptr
    && !gfc_add_oacc_declare_deviceptr (dest, NULL__null, where))
  goto fail;
if (src->oacc_declare_device_resident
    && !gfc_add_oacc_declare_device_resident (dest, NULL__null, where))
  goto fail;
if (src->target && !gfc_add_target (dest, where))
  goto fail;
if (src->dummy && !gfc_add_dummy (dest, NULL__null, where))
  goto fail;
if (src->result && !gfc_add_result (dest, NULL__null, where))
  goto fail;
if (src->entry)
  dest->entry = 1;

if (src->in_namelist && !gfc_add_in_namelist (dest, NULL__null, where))
  goto fail;

if (src->in_common && !gfc_add_in_common (dest, NULL__null, where))
  goto fail;

if (src->generic && !gfc_add_generic (dest, NULL__null, where))
  goto fail;
if (src->function && !gfc_add_function (dest, NULL__null, where))
  goto fail;
if (src->subroutine && !gfc_add_subroutine (dest, NULL__null, where))
  goto fail;

if (src->sequence && !gfc_add_sequence (dest, NULL__null, where))
  goto fail;
if (src->elemental && !gfc_add_elemental (dest, where))
  goto fail;
if (src->pure && !gfc_add_pure (dest, where))
  goto fail;
if (src->recursive && !gfc_add_recursive (dest, where))
  goto fail;

if (src->flavor != FL_UNKNOWN
    && !gfc_add_flavor (dest, src->flavor, NULL__null, where))
  goto fail;

if (src->intent != INTENT_UNKNOWN
    && !gfc_add_intent (dest, src->intent, where))
  goto fail;

if (src->access != ACCESS_UNKNOWN
    && !gfc_add_access (dest, src->access, NULL__null, where))
  goto fail;

if (!gfc_missing_attr (dest, where))
  goto fail;

if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
  goto fail;
if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
  goto fail;

is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
if (src->is_bind_c
    && !gfc_add_is_bind_c (dest, NULL__null, where, is_proc_lang_bind_spec))
  return false;

if (src->is_c_interop)
  dest->is_c_interop = 1;
if (src->is_iso_c)
  dest->is_iso_c = 1;

if (src->external && !gfc_add_external (dest, where))
  goto fail;
if (src->intrinsic && !gfc_add_intrinsic (dest, where))
  goto fail;
if (src->proc_pointer)
  dest->proc_pointer = 1;

return true;

2191fail:
return false;
2193}


2196/* A function to generate a dummy argument symbol using that from the
 interface declaration. Can be used for the result symbol as well if
 the flag is set.  */

2200int
2201gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result)
2202{
int rc;

rc = gfc_get_symbol (sym->name, NULL__null, dsym);
if (rc)
  return rc;

if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus))
  return 1;

if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr),
    &gfc_current_locus))
  return 1;

if ((*dsym)->attr.dimension)
  (*dsym)->as = gfc_copy_array_spec (sym->as);

(*dsym)->attr.class_ok = sym->attr.class_ok;

if ((*dsym) != NULL__null && !result
    && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL__null)
 || !gfc_missing_attr (&(*dsym)->attr, NULL__null)))
  return 1;
else if ((*dsym) != NULL__null && result
    && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL__null)
 || !gfc_missing_attr (&(*dsym)->attr, NULL__null)))
  return 1;

return 0;
2231}


2234/************** Component name management ************/

2236/* Component names of a derived type form their own little namespaces
 that are separate from all other spaces.  The space is composed of
 a singly linked list of gfc_component structures whose head is
 located in the parent symbol.  */


2242/* Add a component name to a symbol.  The call fails if the name is
 already present.  On success, the component pointer is modified to
 point to the additional component structure.  */

2246bool
2247gfc_add_component (gfc_symbol *sym, const char *name,
   gfc_component **component)
2249{
gfc_component *p, *tail;

/* Check for existing components with the same name, but not for union
   components or containers. Unions and maps are anonymous so they have
   unique internal names which will never conflict.
   Don't use gfc_find_component here because it calls gfc_use_derived,
   but the derived type may not be fully defined yet. */
tail = NULL__null;

for (p = sym->components; p; p = p->next)
  {
    if (strcmp (p->name, name) == 0)
{
 gfc_error ("Component %qs at %C already declared at %L",
     name, &p->loc);
 return false;
}

    tail = p;
  }

if (sym->attr.extension
&& gfc_find_component (sym->components->ts.u.derived,
                             name, true, true, NULL__null))
  {
    gfc_error ("Component %qs at %C already in the parent type "
 "at %L", name, &sym->components->ts.u.derived->declared_at);
    return false;
  }

/* Allocate a new component.  */
p = gfc_get_component ()((gfc_component *) xcalloc (1, sizeof (gfc_component)));

if (tail == NULL__null)
  sym->components = p;
else
  tail->next = p;

p->name = gfc_get_string ("%s", name);
p->loc = gfc_current_locus;
p->ts.type = BT_UNKNOWN;

*component = p;
return true;
2294}


2297/* Recursive function to switch derived types of all symbol in a
 namespace.  */

2300static void
2301switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
2302{
gfc_symbol *sym;

if (st == NULL__null)
  return;

sym = st->n.sym;
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
  sym->ts.u.derived = to;

switch_types (st->left, from, to);
switch_types (st->right, from, to);
2314}


2317/* This subroutine is called when a derived type is used in order to
 make the final determination about which version to use.  The
 standard requires that a type be defined before it is 'used', but
 such types can appear in IMPLICIT statements before the actual
 definition.  'Using' in this context means declaring a variable to
 be that type or using the type constructor.

 If a type is used and the components haven't been defined, then we
 have to have a derived type in a parent unit.  We find the node in
 the other namespace and point the symtree node in this namespace to
 that node.  Further reference to this name point to the correct
 node.  If we can't find the node in a parent namespace, then we have
 an error.

 This subroutine takes a pointer to a symbol node and returns a
 pointer to the translated node or NULL for an error.  Usually there
 is no translation and we return the node we were passed.  */

2335gfc_symbol *
2336gfc_use_derived (gfc_symbol *sym)
2337{
gfc_symbol *s;
gfc_typespec *t;
gfc_symtree *st;
int i;

if (!sym)
  return NULL__null;

if (sym->attr.unlimited_polymorphic)
  return sym;

if (sym->attr.generic)
  sym = gfc_find_dt_in_generic (sym);

if (sym->components != NULL__null || sym->attr.zero_comp)
  return sym;               /* Already defined.  */

if (sym->ns->parent == NULL__null)
  goto bad;

if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
  {
    gfc_error ("Symbol %qs at %C is ambiguous", sym->name);
    return NULL__null;
  }

if (s == NULL__null || !gfc_fl_struct (s->attr.flavor)((s->attr.flavor) == FL_DERIVED || (s->attr.flavor) == FL_UNION
 || (s->attr.flavor) == FL_STRUCT))
  goto bad;

/* Get rid of symbol sym, translating all references to s.  */
for (i = 0; i < GFC_LETTERS26; i++)
  {
    t = &sym->ns->default_type[i];
    if (t->u.derived == sym)
t->u.derived = s;
  }

st = gfc_find_symtree (sym->ns->sym_root, sym->name);
st->n.sym = s;

s->refs++;

/* Unlink from list of modified symbols.  */
gfc_commit_symbol (sym);

switch_types (sym->ns->sym_root, sym, s);

/* TODO: Also have to replace sym -> s in other lists like
   namelists, common lists and interface lists.  */
gfc_free_symbol (sym);

return s;

2391bad:
gfc_error ("Derived type %qs at %C is being used before it is defined",
    sym->name);
return NULL__null;
2395}


2398/* Find the component with the given name in the union type symbol.
 If ref is not NULL it will be set to the chain of components through which
 the component can actually be accessed. This is necessary for unions because
 intermediate structures may be maps, nested structures, or other unions,
 all of which may (or must) be 'anonymous' to user code.  */

2404static gfc_component *
2405find_union_component (gfc_symbol *un, const char *name,
                    bool noaccess, gfc_ref **ref)
2407{
gfc_component *m, *check;
gfc_ref *sref, *tmp;

for (m = un->components; m; m = m->next)
  {
    check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp);
    if (check == NULL__null)
      continue;

    /* Found component somewhere in m; chain the refs together.  */
    if (ref)
      {
        /* Map ref. */
        sref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
        sref->type = REF_COMPONENT;
        sref->u.c.component = m;
        sref->u.c.sym = m->ts.u.derived;
        sref->next = tmp;

        *ref = sref;
      }
    /* Other checks (such as access) were done in the recursive calls.  */
    return check;
  }
return NULL__null;
2433}


2436/* Recursively append candidate COMPONENT structures to CANDIDATES.  Store
 the number of total candidates in CANDIDATES_LEN.  */

2439static void
2440lookup_component_fuzzy_find_candidates (gfc_component *component,
			char **&candidates,
			size_t &candidates_len)
2443{
for (gfc_component *p = component; p; p = p->next)
  vec_push (candidates, candidates_len, p->name);
2446}


2449/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account.  */

2451static const char*
2452lookup_component_fuzzy (const char *member, gfc_component *component)
2453{
char **candidates = NULL__null;
size_t candidates_len = 0;
lookup_component_fuzzy_find_candidates (component, candidates,
			  candidates_len);
return gfc_closest_fuzzy_match (member, candidates);
2459}


2462/* Given a derived type node and a component name, try to locate the
 component structure.  Returns the NULL pointer if the component is
 not found or the components are private.  If noaccess is set, no access
 checks are done.  If silent is set, an error will not be generated if
 the component cannot be found or accessed.

 If ref is not NULL, *ref is set to represent the chain of components
 required to get to the ultimate component.

 If the component is simply a direct subcomponent, or is inherited from a
 parent derived type in the given derived type, this is a single ref with its
 component set to the returned component.

 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
 when the component is found through an implicit chain of nested union and
 map components. Unions and maps are "anonymous" substructures in FORTRAN
 which cannot be explicitly referenced, but the reference chain must be
 considered as in C for backend translation to correctly compute layouts.
 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a).  */

2482gfc_component *
2483gfc_find_component (gfc_symbol *sym, const char *name,
    bool noaccess, bool silent, gfc_ref **ref)
2485{
gfc_component *p, *check;
gfc_ref *sref = NULL__null, *tmp = NULL__null;

if (name == NULL__null || sym == NULL__null)
  return NULL__null;

if (sym->attr.flavor == FL_DERIVED)
  sym = gfc_use_derived (sym);
else
  gcc_assert (gfc_fl_struct (sym->attr.flavor))((void)(!(((sym->attr.flavor) == FL_DERIVED || (sym->attr
.flavor) == FL_UNION || (sym->attr.flavor) == FL_STRUCT)) ?
 fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 2495, __FUNCTION__), 0 : 0));

if (sym == NULL__null)
  return NULL__null;

/* Handle UNIONs specially - mutually recursive with gfc_find_component. */
if (sym->attr.flavor == FL_UNION)
  return find_union_component (sym, name, noaccess, ref);

if (ref) *ref = NULL__null;
for (p = sym->components; p; p = p->next)
  {
    /* Nest search into union's maps. */
    if (p->ts.type == BT_UNION)
      {
        check = find_union_component (p->ts.u.derived, name, noaccess, &tmp);
        if (check != NULL__null)
          {
            /* Union ref. */
            if (ref)
              {
                sref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
                sref->type = REF_COMPONENT;
                sref->u.c.component = p;
                sref->u.c.sym = p->ts.u.derived;
                sref->next = tmp;
                *ref = sref;
              }
            return check;
          }
      }
    else if (strcmp (p->name, name) == 0)
      break;

    continue;
  }

if (p && sym->attr.use_assoc && !noaccess)
  {
    bool is_parent_comp = sym->attr.extension && (p == sym->components);
    if (p->attr.access == ACCESS_PRIVATE ||
 (p->attr.access != ACCESS_PUBLIC
  && sym->component_access == ACCESS_PRIVATE
  && !is_parent_comp))
{
 if (!silent)
   gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
       name, sym->name);
 return NULL__null;
}
  }

if (p == NULL__null
&& sym->attr.extension
&& sym->components->ts.type == BT_DERIVED)
  {
    p = gfc_find_component (sym->components->ts.u.derived, name,
	      noaccess, silent, ref);
    /* Do not overwrite the error.  */
    if (p == NULL__null)
return p;
  }

if (p == NULL__null && !silent)
  {
    const char *guessed = lookup_component_fuzzy (name, sym->components);
    if (guessed)
gfc_error ("%qs at %C is not a member of the %qs structure"
   "; did you mean %qs?",
   name, sym->name, guessed);
    else
gfc_error ("%qs at %C is not a member of the %qs structure",
   name, sym->name);
  }

/* Component was found; build the ultimate component reference. */
if (p != NULL__null && ref)
  {
    tmp = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
    tmp->type = REF_COMPONENT;
    tmp->u.c.component = p;
    tmp->u.c.sym = sym;
    /* Link the final component ref to the end of the chain of subrefs. */
    if (sref)
      {
        *ref = sref;
        for (; sref->next; sref = sref->next)
          ;
        sref->next = tmp;
      }
    else
      *ref = tmp;
  }

return p;
2590}


2593/* Given a symbol, free all of the component structures and everything
 they point to.  */

2596static void
2597free_components (gfc_component *p)
2598{
gfc_component *q;

for (; p; p = q)
  {
    q = p->next;

    gfc_free_array_spec (p->as);
    gfc_free_expr (p->initializer);
    if (p->kind_expr)
gfc_free_expr (p->kind_expr);
    if (p->param_list)
gfc_free_actual_arglist (p->param_list);
    free (p->tb);

    free (p);
  }
2615}


2618/******************** Statement label management ********************/

2620/* Comparison function for statement labels, used for managing the
 binary tree.  */

2623static int
2624compare_st_labels (void *a1, void *b1)
2625{
int a = ((gfc_st_label *) a1)->value;
int b = ((gfc_st_label *) b1)->value;

return (b - a);
2630}


2633/* Free a single gfc_st_label structure, making sure the tree is not
 messed up.  This function is called only when some parse error
 occurs.  */

2637void
2638gfc_free_st_label (gfc_st_label *label)
2639{

if (label == NULL__null)
  return;

gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);

if (label->format != NULL__null)
  gfc_free_expr (label->format);

free (label);
2650}


2653/* Free a whole tree of gfc_st_label structures.  */

2655static void
2656free_st_labels (gfc_st_label *label)
2657{

if (label == NULL__null)
  return;

free_st_labels (label->left);
free_st_labels (label->right);

if (label->format != NULL__null)
  gfc_free_expr (label->format);
free (label);
2668}


2671/* Given a label number, search for and return a pointer to the label
 structure, creating it if it does not exist.  */

2674gfc_st_label *
2675gfc_get_st_label (int labelno)
2676{
gfc_st_label *lp;
gfc_namespace *ns;

if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED)
  ns = gfc_current_block ()(gfc_state_stack->sym)->f2k_derived;
else
  {
    /* Find the namespace of the scoping unit:
If we're in a BLOCK construct, jump to the parent namespace.  */
    ns = gfc_current_ns;
    while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
ns = ns->parent;
  }

/* First see if the label is already in this namespace.  */
lp = ns->st_labels;
while (lp)
  {
    if (lp->value == labelno)
return lp;

    if (lp->value < labelno)
lp = lp->left;
    else
lp = lp->right;
  }

lp = XCNEW (gfc_st_label)((gfc_st_label *) xcalloc (1, sizeof (gfc_st_label)));

lp->value = labelno;
lp->defined = ST_LABEL_UNKNOWN;
lp->referenced = ST_LABEL_UNKNOWN;
lp->ns = ns;

gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);

return lp;
2714}


2717/* Called when a statement with a statement label is about to be
 accepted.  We add the label to the list of the current namespace,
 making sure it hasn't been defined previously and referenced
 correctly.  */

2722void
2723gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2724{
int labelno;

labelno = lp->value;

if (lp->defined != ST_LABEL_UNKNOWN)
  gfc_error ("Duplicate statement label %d at %L and %L", labelno,
      &lp->where, label_locus);
else
  {
    lp->where = *label_locus;

    switch (type)
{
case ST_LABEL_FORMAT:
 if (lp->referenced == ST_LABEL_TARGET
     || lp->referenced == ST_LABEL_DO_TARGET)
   gfc_error ("Label %d at %C already referenced as branch target",
       labelno);
 else
   lp->defined = ST_LABEL_FORMAT;

 break;

case ST_LABEL_TARGET:
case ST_LABEL_DO_TARGET:
 if (lp->referenced == ST_LABEL_FORMAT)
   gfc_error ("Label %d at %C already referenced as a format label",
       labelno);
 else
   lp->defined = type;

 if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
    	      && !gfc_notify_std (GFC_STD_F95_OBS(1<<1) | GFC_STD_F2018_DEL(1<<11),
		  "DO termination statement which is not END DO"
		  " or CONTINUE with label %d at %C", labelno))
   return;
 break;

default:
 lp->defined = ST_LABEL_BAD_TARGET;
 lp->referenced = ST_LABEL_BAD_TARGET;
}
  }
2768}


2771/* Reference a label.  Given a label and its type, see if that
 reference is consistent with what is known about that label,
 updating the unknown state.  Returns false if something goes
 wrong.  */

2776bool
2777gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2778{
gfc_sl_type label_type;
int labelno;
bool rc;

if (lp == NULL__null)
  return true;

labelno = lp->value;

if (lp->defined != ST_LABEL_UNKNOWN)
  label_type = lp->defined;
else
  {
    label_type = lp->referenced;
    lp->where = gfc_current_locus;
  }

if (label_type == ST_LABEL_FORMAT
    && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
  {
    gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
    rc = false;
    goto done;
  }

if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
     || label_type == ST_LABEL_BAD_TARGET)
    && type == ST_LABEL_FORMAT)
  {
    gfc_error ("Label %d at %C previously used as branch target", labelno);
    rc = false;
    goto done;
  }

if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
    && !gfc_notify_std (GFC_STD_F95_OBS(1<<1) | GFC_STD_F2018_DEL(1<<11),
	  "Shared DO termination label %d at %C", labelno))
  return false;

if (type == ST_LABEL_DO_TARGET
    && !gfc_notify_std (GFC_STD_F2018_OBS(1<<10), "Labeled DO statement "
	  "at %L", &gfc_current_locus))
  return false;

if (lp->referenced != ST_LABEL_DO_TARGET)
  lp->referenced = type;
rc = true;

2827done:
return rc;
2829}


2832/************** Symbol table management subroutines ****************/

2834/* Basic details: Fortran 95 requires a potentially unlimited number
 of distinct namespaces when compiling a program unit.  This case
 occurs during a compilation of internal subprograms because all of
 the internal subprograms must be read before we can start
 generating code for the host.

 Given the tricky nature of the Fortran grammar, we must be able to
 undo changes made to a symbol table if the current interpretation
 of a statement is found to be incorrect.  Whenever a symbol is
 looked up, we make a copy of it and link to it.  All of these
 symbols are kept in a vector so that we can commit or
 undo the changes at a later time.

 A symtree may point to a symbol node outside of its namespace.  In
 this case, that symbol has been used as a host associated variable
 at some previous time.  */

2851/* Allocate a new namespace structure.  Copies the implicit types from
 PARENT if PARENT_TYPES is set.  */

2854gfc_namespace *
2855gfc_get_namespace (gfc_namespace *parent, int parent_types)
2856{
gfc_namespace *ns;
gfc_typespec *ts;
int in;
int i;

ns = XCNEW (gfc_namespace)((gfc_namespace *) xcalloc (1, sizeof (gfc_namespace)));
ns->sym_root = NULL__null;
ns->uop_root = NULL__null;
ns->tb_sym_root = NULL__null;
ns->finalizers = NULL__null;
ns->default_access = ACCESS_UNKNOWN;
ns->parent = parent;

for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
  {
    ns->operator_access[in] = ACCESS_UNKNOWN;
    ns->tb_op[in] = NULL__null;
  }

/* Initialize default implicit types.  */
for (i = 'a'; i <= 'z'; i++)
  {
    ns->set_flag[i - 'a'] = 0;
    ts = &ns->default_type[i - 'a'];

    if (parent_types && ns->parent != NULL__null)
{
 /* Copy parent settings.  */
 *ts = ns->parent->default_type[i - 'a'];
 continue;
}

    if (flag_implicit_noneglobal_options.x_flag_implicit_none != 0)
{
 gfc_clear_ts (ts);
 continue;
}

    if ('i' <= i && i <= 'n')
{
 ts->type = BT_INTEGER;
 ts->kind = gfc_default_integer_kind;
}
    else
{
 ts->type = BT_REAL;
 ts->kind = gfc_default_real_kind;
}
  }

ns->refs = 1;

return ns;
2910}


2913/* Comparison function for symtree nodes.  */

2915static int
2916compare_symtree (void *_st1, void *_st2)
2917{
gfc_symtree *st1, *st2;

st1 = (gfc_symtree *) _st1;
st2 = (gfc_symtree *) _st2;

return strcmp (st1->name, st2->name);
2924}


2927/* Allocate a new symtree node and associate it with the new symbol.  */

2929gfc_symtree *
2930gfc_new_symtree (gfc_symtree **root, const char *name)
2931{
gfc_symtree *st;

st = XCNEW (gfc_symtree)((gfc_symtree *) xcalloc (1, sizeof (gfc_symtree)));
st->name = gfc_get_string ("%s", name);

gfc_insert_bbt (root, st, compare_symtree);
return st;
2939}


2942/* Delete a symbol from the tree.  Does not free the symbol itself!  */

2944void
2945gfc_delete_symtree (gfc_symtree **root, const char *name)
2946{
gfc_symtree st, *st0;
const char *p;

/* Submodules are marked as mod.submod.  When freeing a submodule
   symbol, the symtree only has "submod", so adjust that here.  */

p = strrchr(name, '.');
if (p)
  p++;
else
  p = name;

st0 = gfc_find_symtree (*root, p);

st.name = gfc_get_string ("%s", p);
gfc_delete_bbt (root, &st, compare_symtree);

free (st0);
2965}


2968/* Given a root symtree node and a name, try to find the symbol within
 the namespace.  Returns NULL if the symbol is not found.  */

2971gfc_symtree *
2972gfc_find_symtree (gfc_symtree *st, const char *name)
2973{
int c;

while (st != NULL__null)
  {
    c = strcmp (name, st->name);
    if (c == 0)
return st;

    st = (c < 0) ? st->left : st->right;
  }

return NULL__null;
2986}


2989/* Return a symtree node with a name that is guaranteed to be unique
 within the namespace and corresponds to an illegal fortran name.  */

2992gfc_symtree *
2993gfc_get_unique_symtree (gfc_namespace *ns)
2994{
char name[GFC_MAX_SYMBOL_LEN63 + 1];
static int serial = 0;

sprintf (name, "@%d", serial++);
return gfc_new_symtree (&ns->sym_root, name);
3000}


3003/* Given a name find a user operator node, creating it if it doesn't
 exist.  These are much simpler than symbols because they can't be
 ambiguous with one another.  */

3007gfc_user_op *
3008gfc_get_uop (const char *name)
3009{
gfc_user_op *uop;
gfc_symtree *st;
gfc_namespace *ns = gfc_current_ns;

if (ns->omp_udr_ns)
  ns = ns->parent;
st = gfc_find_symtree (ns->uop_root, name);
if (st != NULL__null)
  return st->n.uop;

st = gfc_new_symtree (&ns->uop_root, name);

uop = st->n.uop = XCNEW (gfc_user_op)((gfc_user_op *) xcalloc (1, sizeof (gfc_user_op)));
uop->name = gfc_get_string ("%s", name);
uop->access = ACCESS_UNKNOWN;
uop->ns = ns;

return uop;
3028}


3031/* Given a name find the user operator node.  Returns NULL if it does
 not exist.  */

3034gfc_user_op *
3035gfc_find_uop (const char *name, gfc_namespace *ns)
3036{
gfc_symtree *st;

if (ns == NULL__null)
  ns = gfc_current_ns;

st = gfc_find_symtree (ns->uop_root, name);
return (st == NULL__null) ? NULL__null : st->n.uop;
3044}


3047/* Update a symbol's common_block field, and take care of the associated
 memory management.  */

3050static void
3051set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
3052{
if (sym->common_block == common_block)
  return;

if (sym->common_block && sym->common_block->name[0] != '\0')
  {
    sym->common_block->refs--;
    if (sym->common_block->refs == 0)
free (sym->common_block);
  }
sym->common_block = common_block;
3063}


3066/* Remove a gfc_symbol structure and everything it points to.  */

3068void
3069gfc_free_symbol (gfc_symbol *sym)
3070{

if (sym == NULL__null)
  return;

gfc_free_array_spec (sym->as);

free_components (sym->components);

gfc_free_expr (sym->value);

gfc_free_namelist (sym->namelist);

if (sym->ns != sym->formal_ns)
  gfc_free_namespace (sym->formal_ns);

if (!sym->attr.generic_copy)
  gfc_free_interface (sym->generic);

gfc_free_formal_arglist (sym->formal);

gfc_free_namespace (sym->f2k_derived);

set_symbol_common_block (sym, NULL__null);

if (sym->param_list)
  gfc_free_actual_arglist (sym->param_list);

free (sym);
3099}


3102/* Decrease the reference counter and free memory when we reach zero.  */

3104void
3105gfc_release_symbol (gfc_symbol *sym)
3106{
if (sym == NULL__null)
  return;

if (sym->formal_ns != NULL__null && sym->refs == 2 && sym->formal_ns != sym->ns
    && (!sym->attr.entry || !sym->module))
  {
    /* As formal_ns contains a reference to sym, delete formal_ns just
before the deletion of sym.  */
    gfc_namespace *ns = sym->formal_ns;
    sym->formal_ns = NULL__null;
    gfc_free_namespace (ns);
  }

sym->refs--;
if (sym->refs > 0)
  return;

gcc_assert (sym->refs == 0)((void)(!(sym->refs == 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3124, __FUNCTION__), 0 : 0));
gfc_free_symbol (sym);
3126}


3129/* Allocate and initialize a new symbol node.  */

3131gfc_symbol *
3132gfc_new_symbol (const char *name, gfc_namespace *ns)
3133{
gfc_symbol *p;

p = XCNEW (gfc_symbol)((gfc_symbol *) xcalloc (1, sizeof (gfc_symbol)));

gfc_clear_ts (&p->ts);
gfc_clear_attr (&p->attr);
p->ns = ns;
p->declared_at = gfc_current_locus;
p->name = gfc_get_string ("%s", name);

return p;
3145}


3148/* Generate an error if a symbol is ambiguous, and set the error flag
 on it.  */

3151static void
3152ambiguous_symbol (const char *name, gfc_symtree *st)
3153{

if (st->n.sym->error)
  return;

if (st->n.sym->module)
  gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
      "from module %qs", name, st->n.sym->name, st->n.sym->module);
else
  gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
      "from current program unit", name, st->n.sym->name);

st->n.sym->error = 1;
3166}


3169/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
 selector on the stack. If yes, replace it by the corresponding temporary.  */

3172static void
3173select_type_insert_tmp (gfc_symtree **st)
3174{
gfc_select_type_stack *stack = select_type_stack;
for (; stack; stack = stack->prev)
  if ((*st)->n.sym == stack->selector && stack->tmp)
    {
      *st = stack->tmp;
      select_type_insert_tmp (st);
      return;
    }
3183}


3186/* Look for a symtree in the current procedure -- that is, go up to
 parent namespaces but only if inside a BLOCK.  Returns NULL if not found.  */

3189gfc_symtree*
3190gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
3191{
while (ns)
  {
    gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
    if (st)
return st;

    if (!ns->construct_entities)
break;
    ns = ns->parent;
  }

return NULL__null;
3204}


3207/* Search for a symtree starting in the current namespace, resorting to
 any parent namespaces if requested by a nonzero parent_flag.
 Returns nonzero if the name is ambiguous.  */

3211int
3212gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
   gfc_symtree **result)
3214{
gfc_symtree *st;

if (ns == NULL__null)
  ns = gfc_current_ns;

do
  {
    st = gfc_find_symtree (ns->sym_root, name);
    if (st != NULL__null)
{
 select_type_insert_tmp (&st);

 *result = st;
 /* Ambiguous generic interfaces are permitted, as long
    as the specific interfaces are different.  */
 if (st->ambiguous && !st->n.sym->attr.generic)
   {
     ambiguous_symbol (name, st);
     return 1;
   }

 return 0;
}

    if (!parent_flag)
break;

    /* Don't escape an interface block.  */
    if (ns && !ns->has_import_set
        && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
break;

    ns = ns->parent;
  }
while (ns != NULL__null);

if (gfc_current_state()(gfc_state_stack->state) == COMP_DERIVED
    && gfc_current_block ()(gfc_state_stack->sym)->attr.pdt_template)
  {
    gfc_symbol *der = gfc_current_block ()(gfc_state_stack->sym);
    for (; der; der = gfc_get_derived_super_type (der))
{
 if (der->f2k_derived && der->f2k_derived->sym_root)
   {
     st = gfc_find_symtree (der->f2k_derived->sym_root, name);
     if (st)
break;
   }
}
    *result = st;
    return 0;
  }

*result = NULL__null;

return 0;
3271}


3274/* Same, but returns the symbol instead.  */

3276int
3277gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
 gfc_symbol **result)
3279{
gfc_symtree *st;
int i;

i = gfc_find_sym_tree (name, ns, parent_flag, &st);

if (st == NULL__null)
  *result = NULL__null;
else
  *result = st->n.sym;

return i;
3291}


3294/* Tells whether there is only one set of changes in the stack.  */

3296static bool
3297single_undo_checkpoint_p (void)
3298{
if (latest_undo_chgset == &default_undo_chgset_var)
  {
    gcc_assert (latest_undo_chgset->previous == NULL)((void)(!(latest_undo_chgset->previous == __null) ? fancy_abort
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3301, __FUNCTION__), 0 : 0));
    return true;
  }
else
  {
    gcc_assert (latest_undo_chgset->previous != NULL)((void)(!(latest_undo_chgset->previous != __null) ? fancy_abort
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3306, __FUNCTION__), 0 : 0));
    return false;
  }
3309}

3311/* Save symbol with the information necessary to back it out.  */

3313void
3314gfc_save_symbol_data (gfc_symbol *sym)
3315{
gfc_symbol *s;
unsigned i;

if (!single_undo_checkpoint_p ())
  {
    /* If there is more than one change set, look for the symbol in the
       current one.  If it is found there, we can reuse it.  */
    FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(s)); ++(i))
if (s == sym)
 {
   gcc_assert (sym->gfc_new || sym->old_symbol != NULL)((void)(!(sym->gfc_new || sym->old_symbol != __null) ? fancy_abort
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3326, __FUNCTION__), 0 : 0));
   return;
 }
  }
else if (sym->gfc_new || sym->old_symbol != NULL__null)
  return;

s = XCNEW (gfc_symbol)((gfc_symbol *) xcalloc (1, sizeof (gfc_symbol)));
*s = *sym;
sym->old_symbol = s;
sym->gfc_new = 0;

latest_undo_chgset->syms.safe_push (sym);
3339}


3342/* Given a name, find a symbol, or create it if it does not exist yet
 in the current namespace.  If the symbol is found we make sure that
 it's OK.

 The integer return code indicates
   0   All OK
   1   The symbol name was ambiguous
   2   The name meant to be established was already host associated.

 So if the return value is nonzero, then an error was issued.  */

3353int
3354gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
  bool allow_subroutine)
3356{
gfc_symtree *st;
gfc_symbol *p;

/* This doesn't usually happen during resolution.  */
if (ns == NULL__null)
  ns = gfc_current_ns;

/* Try to find the symbol in ns.  */
st = gfc_find_symtree (ns->sym_root, name);

if (st == NULL__null && ns->omp_udr_ns)
  {
    ns = ns->parent;
    st = gfc_find_symtree (ns->sym_root, name);
  }

if (st == NULL__null)
  {
    /* If not there, create a new symbol.  */
    p = gfc_new_symbol (name, ns);

    /* Add to the list of tentative symbols.  */
    p->old_symbol = NULL__null;
    p->mark = 1;
    p->gfc_new = 1;
    latest_undo_chgset->syms.safe_push (p);

    st = gfc_new_symtree (&ns->sym_root, name);
    st->n.sym = p;
    p->refs++;

  }
else
  {
    /* Make sure the existing symbol is OK.  Ambiguous
generic interfaces are permitted, as long as the
specific interfaces are different.  */
    if (st->ambiguous && !st->n.sym->attr.generic)
{
 ambiguous_symbol (name, st);
 return 1;
}

    p = st->n.sym;
    if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
 && !(allow_subroutine && p->attr.subroutine)
 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
 && (ns->has_import_set || p->attr.imported)))
{
 /* Symbol is from another namespace.  */
 gfc_error ("Symbol %qs at %C has already been host associated",
     name);
 return 2;
}

    p->mark = 1;

    /* Copy in case this symbol is changed.  */
    gfc_save_symbol_data (p);
  }

*result = st;
return 0;
3420}


3423int
3424gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
3425{
gfc_symtree *st;
int i;

i = gfc_get_sym_tree (name, ns, &st, false);
if (i != 0)
5
←
Assuming 'i' is equal to 0→
6
←
Taking false branch→
  return i;

if (st)
7
←
Assuming 'st' is null→
8
←
Taking false branch→
  *result = st->n.sym;
else
  *result = NULL__null;
9
←
Null pointer value stored to field 'sym'→
return i;
3438}


3441/* Subroutine that searches for a symbol, creating it if it doesn't
 exist, but tries to host-associate the symbol if possible.  */

3444int
3445gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
3446{
gfc_symtree *st;
int i;

i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);

if (st != NULL__null)
  {
    gfc_save_symbol_data (st->n.sym);
    *result = st;
    return i;
  }

i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
if (i)
  return i;

if (st != NULL__null)
  {
    *result = st;
    return 0;
  }

return gfc_get_sym_tree (name, gfc_current_ns, result, false);
3470}


3473int
3474gfc_get_ha_symbol (const char *name, gfc_symbol **result)
3475{
int i;
gfc_symtree *st;

i = gfc_get_ha_sym_tree (name, &st);

if (st)
  *result = st->n.sym;
else
  *result = NULL__null;

return i;
3487}


3490/* Search for the symtree belonging to a gfc_common_head; we cannot use
 head->name as the common_root symtree's name might be mangled.  */

3493static gfc_symtree *
3494find_common_symtree (gfc_symtree *st, gfc_common_head *head)
3495{

gfc_symtree *result;

if (st == NULL__null)
  return NULL__null;

if (st->n.common == head)
  return st;

result = find_common_symtree (st->left, head);
if (!result)
  result = find_common_symtree (st->right, head);

return result;
3510}


3513/* Restore previous state of symbol.  Just copy simple stuff.  */

3515static void
3516restore_old_symbol (gfc_symbol *p)
3517{
gfc_symbol *old;

p->mark = 0;
old = p->old_symbol;

p->ts.type = old->ts.type;
p->ts.kind = old->ts.kind;

p->attr = old->attr;

if (p->value != old->value)
  {
    gcc_checking_assert (old->value == NULL)((void)(!(old->value == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3530, __FUNCTION__), 0 : 0));
    gfc_free_expr (p->value);
    p->value = NULL__null;
  }

if (p->as != old->as)
  {
    if (p->as)
gfc_free_array_spec (p->as);
    p->as = old->as;
  }

p->generic = old->generic;
p->component_access = old->component_access;

if (p->namelist != NULL__null && old->namelist == NULL__null)
  {
    gfc_free_namelist (p->namelist);
    p->namelist = NULL__null;
  }
else
  {
    if (p->namelist_tail != old->namelist_tail)
{
 gfc_free_namelist (old->namelist_tail->next);
 old->namelist_tail->next = NULL__null;
}
  }

p->namelist_tail = old->namelist_tail;

if (p->formal != old->formal)
  {
    gfc_free_formal_arglist (p->formal);
    p->formal = old->formal;
  }

set_symbol_common_block (p, old->common_block);
p->common_head = old->common_head;

p->old_symbol = old->old_symbol;
free (old);
3572}


3575/* Frees the internal data of a gfc_undo_change_set structure.  Doesn't free
 the structure itself.  */

3578static void
3579free_undo_change_set_data (gfc_undo_change_set &cs)
3580{
cs.syms.release ();
cs.tbps.release ();
3583}


3586/* Given a change set pointer, free its target's contents and update it with
 the address of the previous change set.  Note that only the contents are
 freed, not the target itself (the contents' container).  It is not a problem
 as the latter will be a local variable usually.  */

3591static void
3592pop_undo_change_set (gfc_undo_change_set *&cs)
3593{
free_undo_change_set_data (*cs);
cs = cs->previous;
3596}


3599static void free_old_symbol (gfc_symbol *sym);


3602/* Merges the current change set into the previous one.  The changes themselves
 are left untouched; only one checkpoint is forgotten.  */

3605void
3606gfc_drop_last_undo_checkpoint (void)
3607{
gfc_symbol *s, *t;
unsigned i, j;

FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(s)); ++(i))
  {
    /* No need to loop in this case.  */
    if (s->old_symbol == NULL__null)
      continue;

    /* Remove the duplicate symbols.  */
    FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)for (j = 0; (latest_undo_chgset->previous->syms).iterate
 ((j), &(t)); ++(j))
if (t == s)
 {
   latest_undo_chgset->previous->syms.unordered_remove (j);

   /* S->OLD_SYMBOL is the backup symbol for S as it was at the
      last checkpoint.  We drop that checkpoint, so S->OLD_SYMBOL
      shall contain from now on the backup symbol for S as it was
      at the checkpoint before.  */
   if (s->old_symbol->gfc_new)
     {
gcc_assert (s->old_symbol->old_symbol == NULL)((void)(!(s->old_symbol->old_symbol == __null) ? fancy_abort
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3629, __FUNCTION__), 0 : 0));
s->gfc_new = s->old_symbol->gfc_new;
free_old_symbol (s);
     }
   else
     restore_old_symbol (s->old_symbol);
   break;
 }
  }

latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);

pop_undo_change_set (latest_undo_chgset);
3643}


3646/* Undoes all the changes made to symbols since the previous checkpoint.
 This subroutine is made simpler due to the fact that attributes are
 never removed once added.  */

3650void
3651gfc_restore_last_undo_checkpoint (void)
3652{
gfc_symbol *p;
unsigned i;

FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(p)); ++(i))
  {
    /* Symbol in a common block was new. Or was old and just put in common */
    if (p->common_block
 && (p->gfc_new || !p->old_symbol->common_block))
{
 /* If the symbol was added to any common block, it
    needs to be removed to stop the resolver looking
    for a (possibly) dead symbol.  */
 if (p->common_block->head == p && !p->common_next)
   {
     gfc_symtree st, *st0;
     st0 = find_common_symtree (p->ns->common_root,
			 p->common_block);
     if (st0)
{
  st.name = st0->name;
  gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
  free (st0);
}
   }

 if (p->common_block->head == p)
   p->common_block->head = p->common_next;
 else
   {
     gfc_symbol *cparent, *csym;

     cparent = p->common_block->head;
     csym = cparent->common_next;

     while (csym != p)
{
  cparent = csym;
  csym = csym->common_next;
}

     gcc_assert(cparent->common_next == p)((void)(!(cparent->common_next == p) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3693, __FUNCTION__), 0 : 0));
     cparent->common_next = csym->common_next;
   }
 p->common_next = NULL__null;
}
    if (p->gfc_new)
{
 /* The derived type is saved in the symtree with the first
    letter capitalized; the all lower-case version to the
    derived type contains its associated generic function.  */
 if (gfc_fl_struct (p->attr.flavor)((p->attr.flavor) == FL_DERIVED || (p->attr.flavor) == FL_UNION
 || (p->attr.flavor) == FL_STRUCT))
   gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name));
        else
   gfc_delete_symtree (&p->ns->sym_root, p->name);

 gfc_release_symbol (p);
}
    else
restore_old_symbol (p);
  }

latest_undo_chgset->syms.truncate (0);
latest_undo_chgset->tbps.truncate (0);

if (!single_undo_checkpoint_p ())
  pop_undo_change_set (latest_undo_chgset);
3719}


3722/* Makes sure that there is only one set of changes; in other words we haven't
 forgotten to pair a call to gfc_new_checkpoint with a call to either
 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint.  */

3726static void
3727enforce_single_undo_checkpoint (void)
3728{
gcc_checking_assert (single_undo_checkpoint_p ())((void)(!(single_undo_checkpoint_p ()) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3729, __FUNCTION__), 0 : 0));
3730}


3733/* Undoes all the changes made to symbols in the current statement.  */

3735void
3736gfc_undo_symbols (void)
3737{
enforce_single_undo_checkpoint ();
gfc_restore_last_undo_checkpoint ();
3740}


3743/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
 components of old_symbol that might need deallocation are the "allocatables"
 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
 namelist_tail.  In case these differ between old_symbol and sym, it's just
 because sym->namelist has gotten a few more items.  */

3749static void
3750free_old_symbol (gfc_symbol *sym)
3751{

if (sym->old_symbol == NULL__null)
  return;

if (sym->old_symbol->as != sym->as)
  gfc_free_array_spec (sym->old_symbol->as);

if (sym->old_symbol->value != sym->value)
  gfc_free_expr (sym->old_symbol->value);

if (sym->old_symbol->formal != sym->formal)
  gfc_free_formal_arglist (sym->old_symbol->formal);

free (sym->old_symbol);
sym->old_symbol = NULL__null;
3767}


3770/* Makes the changes made in the current statement permanent-- gets
 rid of undo information.  */

3773void
3774gfc_commit_symbols (void)
3775{
gfc_symbol *p;
gfc_typebound_proc *tbp;
unsigned i;

enforce_single_undo_checkpoint ();

FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(p)); ++(i))
  {
    p->mark = 0;
    p->gfc_new = 0;
    free_old_symbol (p);
  }
latest_undo_chgset->syms.truncate (0);

FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)for (i = 0; (latest_undo_chgset->tbps).iterate ((i), &
(tbp)); ++(i))
  tbp->error = 0;
latest_undo_chgset->tbps.truncate (0);
3793}


3796/* Makes the changes made in one symbol permanent -- gets rid of undo
 information.  */

3799void
3800gfc_commit_symbol (gfc_symbol *sym)
3801{
gfc_symbol *p;
unsigned i;

enforce_single_undo_checkpoint ();

FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(p)); ++(i))
  if (p == sym)
    {
latest_undo_chgset->syms.unordered_remove (i);
break;
    }

sym->mark = 0;
sym->gfc_new = 0;

free_old_symbol (sym);
3818}


3821/* Recursively free trees containing type-bound procedures.  */

3823static void
3824free_tb_tree (gfc_symtree *t)
3825{
if (t == NULL__null)
  return;

free_tb_tree (t->left);
free_tb_tree (t->right);

/* TODO: Free type-bound procedure structs themselves; probably needs some
   sort of ref-counting mechanism.  */

free (t);
3836}


3839/* Recursive function that deletes an entire tree and all the common
 head structures it points to.  */

3842static void
3843free_common_tree (gfc_symtree * common_tree)
3844{
if (common_tree == NULL__null)
  return;

free_common_tree (common_tree->left);
free_common_tree (common_tree->right);

free (common_tree);
3852}


3855/* Recursive function that deletes an entire tree and all the common
 head structures it points to.  */

3858static void
3859free_omp_udr_tree (gfc_symtree * omp_udr_tree)
3860{
if (omp_udr_tree == NULL__null)
  return;

free_omp_udr_tree (omp_udr_tree->left);
free_omp_udr_tree (omp_udr_tree->right);

gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
free (omp_udr_tree);
3869}


3872/* Recursive function that deletes an entire tree and all the user
 operator nodes that it contains.  */

3875static void
3876free_uop_tree (gfc_symtree *uop_tree)
3877{
if (uop_tree == NULL__null)
  return;

free_uop_tree (uop_tree->left);
free_uop_tree (uop_tree->right);

gfc_free_interface (uop_tree->n.uop->op);
free (uop_tree->n.uop);
free (uop_tree);
3887}


3890/* Recursive function that deletes an entire tree and all the symbols
 that it contains.  */

3893static void
3894free_sym_tree (gfc_symtree *sym_tree)
3895{
if (sym_tree == NULL__null)
  return;

free_sym_tree (sym_tree->left);
free_sym_tree (sym_tree->right);

gfc_release_symbol (sym_tree->n.sym);
free (sym_tree);
3904}


3907/* Free the gfc_equiv_info's.  */

3909static void
3910gfc_free_equiv_infos (gfc_equiv_info *s)
3911{
if (s == NULL__null)
  return;
gfc_free_equiv_infos (s->next);
free (s);
3916}


3919/* Free the gfc_equiv_lists.  */

3921static void
3922gfc_free_equiv_lists (gfc_equiv_list *l)
3923{
if (l == NULL__null)
  return;
gfc_free_equiv_lists (l->next);
gfc_free_equiv_infos (l->equiv);
free (l);
3929}


3932/* Free a finalizer procedure list.  */

3934void
3935gfc_free_finalizer (gfc_finalizer* el)
3936{
if (el)
  {
    gfc_release_symbol (el->proc_sym);
    free (el);
  }
3942}

3944static void
3945gfc_free_finalizer_list (gfc_finalizer* list)
3946{
while (list)
  {
    gfc_finalizer* current = list;
    list = list->next;
    gfc_free_finalizer (current);
  }
3953}


3956/* Create a new gfc_charlen structure and add it to a namespace.
 If 'old_cl' is given, the newly created charlen will be a copy of it.  */

3959gfc_charlen*
3960gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3961{
gfc_charlen *cl;

cl = gfc_get_charlen ()((gfc_charlen *) xcalloc (1, sizeof (gfc_charlen)));

/* Copy old_cl.  */
if (old_cl)
  {
    cl->length = gfc_copy_expr (old_cl->length);
    cl->length_from_typespec = old_cl->length_from_typespec;
    cl->backend_decl = old_cl->backend_decl;
    cl->passed_length = old_cl->passed_length;
    cl->resolved = old_cl->resolved;
  }

/* Put into namespace.  */
cl->next = ns->cl_list;
ns->cl_list = cl;

return cl;
3981}


3984/* Free the charlen list from cl to end (end is not freed).
 Free the whole list if end is NULL.  */

3987void
3988gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3989{
gfc_charlen *cl2;

for (; cl != end; cl = cl2)
  {
    gcc_assert (cl)((void)(!(cl) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3994, __FUNCTION__), 0 : 0));

    cl2 = cl->next;
    gfc_free_expr (cl->length);
    free (cl);
  }
4000}


4003/* Free entry list structs.  */

4005static void
4006free_entry_list (gfc_entry_list *el)
4007{
gfc_entry_list *next;

if (el == NULL__null)
  return;

next = el->next;
free (el);
free_entry_list (next);
4016}


4019/* Free a namespace structure and everything below it.  Interface
 lists associated with intrinsic operators are not freed.  These are
 taken care of when a specific name is freed.  */

4023void
4024gfc_free_namespace (gfc_namespace *ns)
4025{
gfc_namespace *p, *q;
int i;
gfc_was_finalized *f;

if (ns == NULL__null)
  return;

ns->refs--;
if (ns->refs > 0)
  return;

gcc_assert (ns->refs == 0)((void)(!(ns->refs == 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4037, __FUNCTION__), 0 : 0));

gfc_free_statements (ns->code);

free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
free_omp_udr_tree (ns->omp_udr_root);
free_tb_tree (ns->tb_sym_root);
free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
gfc_free_charlen (ns->cl_list, NULL__null);
free_st_labels (ns->st_labels);

free_entry_list (ns->entries);
gfc_free_equiv (ns->equiv);
gfc_free_equiv_lists (ns->equiv_lists);
gfc_free_use_stmts (ns->use_stmts);

for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
  gfc_free_interface (ns->op[i]);

gfc_free_data (ns->data);

/* Free all the expr + component combinations that have been
   finalized.  */
f = ns->was_finalized;
while (f)
  {
    gfc_was_finalized* current = f;
    f = f->next;
    free (current);
  }

p = ns->contained;
free (ns);

/* Recursively free any contained namespaces.  */
while (p != NULL__null)
  {
    q = p;
    p = p->sibling;
    gfc_free_namespace (q);
  }
4082}


4085void
4086gfc_symbol_init_2 (void)
4087{

gfc_current_ns = gfc_get_namespace (NULL__null, 0);
4090}


4093void
4094gfc_symbol_done_2 (void)
4095{
if (gfc_current_ns != NULL__null)
  {
    /* free everything from the root.  */
    while (gfc_current_ns->parent != NULL__null)
gfc_current_ns = gfc_current_ns->parent;
    gfc_free_namespace (gfc_current_ns);
    gfc_current_ns = NULL__null;
  }
gfc_derived_types = NULL__null;

enforce_single_undo_checkpoint ();
free_undo_change_set_data (*latest_undo_chgset);
4108}


4111/* Count how many nodes a symtree has.  */

4113static unsigned
4114count_st_nodes (const gfc_symtree *st)
4115{
unsigned nodes;
if (!st)
  return 0;

nodes = count_st_nodes (st->left);
nodes++;
nodes += count_st_nodes (st->right);

return nodes;
4125}


4128/* Convert symtree tree into symtree vector.  */

4130static unsigned
4131fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
4132{
if (!st)
  return node_cntr;

node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
st_vec[node_cntr++] = st;
node_cntr = fill_st_vector (st->right, st_vec, node_cntr);

return node_cntr;
4141}


4144/* Traverse namespace.  As the functions might modify the symtree, we store the
 symtree as a vector and operate on this vector.  Note: We assume that
 sym_func or st_func never deletes nodes from the symtree - only adding is
 allowed. Additionally, newly added nodes are not traversed.  */

4149static void
4150do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
     void (*sym_func) (gfc_symbol *))
4152{
gfc_symtree **st_vec;
unsigned nodes, i, node_cntr;

gcc_assert ((st_func && !sym_func) || (!st_func && sym_func))((void)(!((st_func && !sym_func) || (!st_func &&
 sym_func)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4156, __FUNCTION__), 0 : 0));
nodes = count_st_nodes (st);
st_vec = XALLOCAVEC (gfc_symtree *, nodes)((gfc_symtree * *) __builtin_alloca(sizeof (gfc_symtree *) * (
nodes)));
node_cntr = 0;
fill_st_vector (st, st_vec, node_cntr);

if (sym_func)
  {
    /* Clear marks.  */
    for (i = 0; i < nodes; i++)
st_vec[i]->n.sym->mark = 0;
    for (i = 0; i < nodes; i++)
if (!st_vec[i]->n.sym->mark)
 {
   (*sym_func) (st_vec[i]->n.sym);
   st_vec[i]->n.sym->mark = 1;
 }
   }
 else
    for (i = 0; i < nodes; i++)
(*st_func) (st_vec[i]);
4177}


4180/* Recursively traverse the symtree nodes.  */

4182void
4183gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
4184{
do_traverse_symtree (st, st_func, NULL__null);
4186}


4189/* Call a given function for all symbols in the namespace.  We take
 care that each gfc_symbol node is called exactly once.  */

4192void
4193gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
4194{
do_traverse_symtree (ns->sym_root, NULL__null, sym_func);
4196}


4199/* Return TRUE when name is the name of an intrinsic type.  */

4201bool
4202gfc_is_intrinsic_typename (const char *name)
4203{
if (strcmp (name, "integer") == 0
    || strcmp (name, "real") == 0
    || strcmp (name, "character") == 0
    || strcmp (name, "logical") == 0
    || strcmp (name, "complex") == 0
    || strcmp (name, "doubleprecision") == 0
    || strcmp (name, "doublecomplex") == 0)
  return true;
else
  return false;
4214}


4217/* Return TRUE if the symbol is an automatic variable.  */

4219static bool
4220gfc_is_var_automatic (gfc_symbol *sym)
4221{
/* Pointer and allocatable variables are never automatic.  */
if (sym->attr.pointer || sym->attr.allocatable)
  return false;
/* Check for arrays with non-constant size.  */
if (sym->attr.dimension && sym->as
    && !gfc_is_compile_time_shape (sym->as))
  return true;
/* Check for non-constant length character variables.  */
if (sym->ts.type == BT_CHARACTER
    && sym->ts.u.cl
    && !gfc_is_constant_expr (sym->ts.u.cl->length))
  return true;
/* Variables with explicit AUTOMATIC attribute.  */
if (sym->attr.automatic)
    return true;

return false;
4239}

4241/* Given a symbol, mark it as SAVEd if it is allowed.  */

4243static void
4244save_symbol (gfc_symbol *sym)
4245{

if (sym->attr.use_assoc)
  return;

if (sym->attr.in_common
    || sym->attr.in_equivalence
    || sym->attr.dummy
    || sym->attr.result
    || sym->attr.flavor != FL_VARIABLE)
  return;
/* Automatic objects are not saved.  */
if (gfc_is_var_automatic (sym))
  return;
gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
4260}


4263/* Mark those symbols which can be SAVEd as such.  */

4265void
4266gfc_save_all (gfc_namespace *ns)
4267{
gfc_traverse_ns (ns, save_symbol);
4269}


4272/* Make sure that no changes to symbols are pending.  */

4274void
4275gfc_enforce_clean_symbol_state(void)
4276{
enforce_single_undo_checkpoint ();
gcc_assert (latest_undo_chgset->syms.is_empty ())((void)(!(latest_undo_chgset->syms.is_empty ()) ? fancy_abort
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4278, __FUNCTION__), 0 : 0));
4279}


4282/************** Global symbol handling ************/


4285/* Search a tree for the global symbol.  */

4287gfc_gsymbol *
4288gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
4289{
int c;

if (symbol == NULL__null)
  return NULL__null;

while (symbol)
  {
    c = strcmp (name, symbol->name);
    if (!c)
return symbol;

    symbol = (c < 0) ? symbol->left : symbol->right;
  }

return NULL__null;
4305}


4308/* Case insensitive search a tree for the global symbol.  */

4310gfc_gsymbol *
4311gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name)
4312{
int c;

if (symbol == NULL__null)
  return NULL__null;

while (symbol)
  {
    c = strcasecmp (name, symbol->name);
    if (!c)
return symbol;

    symbol = (c < 0) ? symbol->left : symbol->right;
  }

return NULL__null;
4328}


4331/* Compare two global symbols. Used for managing the BB tree.  */

4333static int
4334gsym_compare (void *_s1, void *_s2)
4335{
gfc_gsymbol *s1, *s2;

s1 = (gfc_gsymbol *) _s1;
s2 = (gfc_gsymbol *) _s2;
return strcmp (s1->name, s2->name);
4341}


4344/* Get a global symbol, creating it if it doesn't exist.  */

4346gfc_gsymbol *
4347gfc_get_gsymbol (const char *name, bool bind_c)
4348{
gfc_gsymbol *s;

s = gfc_find_gsymbol (gfc_gsym_root, name);
if (s != NULL__null)
  return s;

s = XCNEW (gfc_gsymbol)((gfc_gsymbol *) xcalloc (1, sizeof (gfc_gsymbol)));
s->type = GSYM_UNKNOWN;
s->name = gfc_get_string ("%s", name);
s->bind_c = bind_c;

gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);

return s;
4363}

4365void
4366gfc_traverse_gsymbol (gfc_gsymbol *gsym,
      void (*do_something) (gfc_gsymbol *, void *),
      void *data)
4369{
if (gsym->left)
  gfc_traverse_gsymbol (gsym->left, do_something, data);

(*do_something) (gsym, data);

if (gsym->right)
  gfc_traverse_gsymbol (gsym->right, do_something, data);
4377}

4379static gfc_symbol *
4380get_iso_c_binding_dt (int sym_id)
4381{
gfc_symbol *dt_list = gfc_derived_types;

/* Loop through the derived types in the name list, searching for
   the desired symbol from iso_c_binding.  Search the parent namespaces
   if necessary and requested to (parent_flag).  */
if (dt_list)
  {
    while (dt_list->dt_next != gfc_derived_types)
{
 if (dt_list->from_intmod != INTMOD_NONE
     && dt_list->intmod_sym_id == sym_id)
   return dt_list;

 dt_list = dt_list->dt_next;
}
  }

return NULL__null;
4400}


4403/* Verifies that the given derived type symbol, derived_sym, is interoperable
 with C.  This is necessary for any derived type that is BIND(C) and for
 derived types that are parameters to functions that are BIND(C).  All
 fields of the derived type are required to be interoperable, and are tested
 for such.  If an error occurs, the errors are reported here, allowing for
 multiple errors to be handled for a single derived type.  */

4410bool
4411verify_bind_c_derived_type (gfc_symbol *derived_sym)
4412{
gfc_component *curr_comp = NULL__null;
bool is_c_interop = false;
bool retval = true;

if (derived_sym == NULL__null)
  gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
                      "unexpectedly NULL");

/* If we've already looked at this derived symbol, do not look at it again
   so we don't repeat warnings/errors.  */
if (derived_sym->ts.is_c_interop)
  return true;

/* The derived type must have the BIND attribute to be interoperable
   J3/04-007, Section 15.2.3.  */
if (derived_sym->attr.is_bind_c != 1)
  {
    derived_sym->ts.is_c_interop = 0;
    gfc_error_now ("Derived type %qs declared at %L must have the BIND "
                   "attribute to be C interoperable", derived_sym->name,
                   &(derived_sym->declared_at));
    retval = false;
  }

curr_comp = derived_sym->components;

/* Fortran 2003 allows an empty derived type.  C99 appears to disallow an
   empty struct.  Section 15.2 in Fortran 2003 states:  "The following
   subclauses define the conditions under which a Fortran entity is
   interoperable.  If a Fortran entity is interoperable, an equivalent
   entity may be defined by means of C and the Fortran entity is said
   to be interoperable with the C entity.  There does not have to be such
   an interoperating C entity."
*/
if (curr_comp == NULL__null)
  {
    gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
   "and may be inaccessible by the C companion processor",
   derived_sym->name, &(derived_sym->declared_at));
    derived_sym->ts.is_c_interop = 1;
    derived_sym->attr.is_bind_c = 1;
    return true;
  }


/* Initialize the derived type as being C interoperable.
   If we find an error in the components, this will be set false.  */
derived_sym->ts.is_c_interop = 1;

/* Loop through the list of components to verify that the kind of
   each is a C interoperable type.  */
do
  {
    /* The components cannot be pointers (fortran sense).
       J3/04-007, Section 15.2.3, C1505.	*/
    if (curr_comp->attr.pointer != 0)
      {
        gfc_error ("Component %qs at %L cannot have the "
                   "POINTER attribute because it is a member "
                   "of the BIND(C) derived type %qs at %L",
                   curr_comp->name, &(curr_comp->loc),
                   derived_sym->name, &(derived_sym->declared_at));
        retval = false;
      }

    if (curr_comp->attr.proc_pointer != 0)
{
 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
     " of the BIND(C) derived type %qs at %L", curr_comp->name,
     &curr_comp->loc, derived_sym->name,
     &derived_sym->declared_at);
        retval = false;
      }

    /* The components cannot be allocatable.
       J3/04-007, Section 15.2.3, C1505.	*/
    if (curr_comp->attr.allocatable != 0)
      {
        gfc_error ("Component %qs at %L cannot have the "
                   "ALLOCATABLE attribute because it is a member "
                   "of the BIND(C) derived type %qs at %L",
                   curr_comp->name, &(curr_comp->loc),
                   derived_sym->name, &(derived_sym->declared_at));
        retval = false;
      }

    /* BIND(C) derived types must have interoperable components.  */
    if (curr_comp->ts.type == BT_DERIVED
 && curr_comp->ts.u.derived->ts.is_iso_c != 1
        && curr_comp->ts.u.derived != derived_sym)
      {
        /* This should be allowed; the draft says a derived-type cannot
           have type parameters if it is has the BIND attribute.  Type
           parameters seem to be for making parameterized derived types.
           There's no need to verify the type if it is c_ptr/c_funptr.  */
        retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
}
    else
{
 /* Grab the typespec for the given component and test the kind.  */
 is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));

 if (!is_c_interop)
   {
     /* Report warning and continue since not fatal.  The
 draft does specify a constraint that requires all fields
 to interoperate, but if the user says real(4), etc., it
 may interoperate with *something* in C, but the compiler
 most likely won't know exactly what.  Further, it may not
 interoperate with the same data type(s) in C if the user
 recompiles with different flags (e.g., -m32 and -m64 on
 x86_64 and using integer(4) to claim interop with a
 C_LONG).  */
     if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_typeglobal_options.x_warn_c_binding_type)
/* If the derived type is bind(c), all fields must be
   interop.  */
gfc_warning (OPT_Wc_binding_type,
	     "Component %qs in derived type %qs at %L "
                           "may not be C interoperable, even though "
                           "derived type %qs is BIND(C)",
                           curr_comp->name, derived_sym->name,
                           &(curr_comp->loc), derived_sym->name);
     else if (warn_c_binding_typeglobal_options.x_warn_c_binding_type)
/* If derived type is param to bind(c) routine, or to one
   of the iso_c_binding procs, it must be interoperable, so
   all fields must interop too.	 */
gfc_warning (OPT_Wc_binding_type,
	     "Component %qs in derived type %qs at %L "
                           "may not be C interoperable",
                           curr_comp->name, derived_sym->name,
                           &(curr_comp->loc));
   }
}

    curr_comp = curr_comp->next;
  } while (curr_comp != NULL__null);

if (derived_sym->attr.sequence != 0)
  {
    gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
               "attribute because it is BIND(C)", derived_sym->name,
               &(derived_sym->declared_at));
    retval = false;
  }

/* Mark the derived type as not being C interoperable if we found an
   error.  If there were only warnings, proceed with the assumption
   it's interoperable.  */
if (!retval)
  derived_sym->ts.is_c_interop = 0;

return retval;
4565}


4568/* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */

4570static bool
4571gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
4572{
gfc_constructor *c;

gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym)((void)(!(tmp_sym && dt_symtree && dt_symtree
->n.sym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4575, __FUNCTION__), 0 : 0));
dt_symtree->n.sym->attr.referenced = 1;

tmp_sym->attr.is_c_interop = 1;
tmp_sym->attr.is_bind_c = 1;
tmp_sym->ts.is_c_interop = 1;
tmp_sym->ts.is_iso_c = 1;
tmp_sym->ts.type = BT_DERIVED;
tmp_sym->ts.f90_type = BT_VOID;
tmp_sym->attr.flavor = FL_PARAMETER;
tmp_sym->ts.u.derived = dt_symtree->n.sym;

/* Set the c_address field of c_null_ptr and c_null_funptr to
   the value of NULL.	 */
tmp_sym->value = gfc_get_expr ();
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
tmp_sym->value->ts.f90_type = BT_VOID;
tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL__null, NULL__null);
c = gfc_constructor_first (tmp_sym->value->value.constructor);
c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL__null, 0);
c->expr->ts.is_iso_c = 1;

return true;
4600}


4603/* Add a formal argument, gfc_formal_arglist, to the
 end of the given list of arguments.	Set the reference to the
 provided symbol, param_sym, in the argument.  */

4607static void
4608add_formal_arg (gfc_formal_arglist **head,
              gfc_formal_arglist **tail,
              gfc_formal_arglist *formal_arg,
              gfc_symbol *param_sym)
4612{
/* Put in list, either as first arg or at the tail (curr arg).  */
if (*head == NULL__null)
  *head = *tail = formal_arg;
else
  {
    (*tail)->next = formal_arg;
    (*tail) = formal_arg;
  }

(*tail)->sym = param_sym;
(*tail)->next = NULL__null;

return;
4626}


4629/* Add a procedure interface to the given symbol (i.e., store a
 reference to the list of formal arguments).  */

4632static void
4633add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4634{

sym->formal = formal;
sym->attr.if_source = source;
4638}


4641/* Copy the formal args from an existing symbol, src, into a new
 symbol, dest.  New formal args are created, and the description of
 each arg is set according to the existing ones.  This function is
 used when creating procedure declaration variables from a procedure
 declaration statement (see match_proc_decl()) to create the formal
 args based on the args of a given named interface.

 When an actual argument list is provided, skip the absent arguments
 unless copy_type is true.
 To be used together with gfc_se->ignore_optional.  */

4652void
4653gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
	   gfc_actual_arglist *actual, bool copy_type)
4655{
gfc_formal_arglist *head = NULL__null;
gfc_formal_arglist *tail = NULL__null;
gfc_formal_arglist *formal_arg = NULL__null;
gfc_intrinsic_arg *curr_arg = NULL__null;
gfc_formal_arglist *formal_prev = NULL__null;
gfc_actual_arglist *act_arg = actual;
/* Save current namespace so we can change it for formal args.  */
gfc_namespace *parent_ns = gfc_current_ns;

/* Create a new namespace, which will be the formal ns (namespace
   of the formal args).  */
gfc_current_ns = gfc_get_namespace (parent_ns, 0);
gfc_current_ns->proc_name = dest;

for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
1
Loop condition is true.  Entering loop body→
  {
    /* Skip absent arguments.  */
    if (actual)
2
←
Assuming 'actual' is null→
3
←
Taking false branch→
{
 gcc_assert (act_arg != NULL)((void)(!(act_arg != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4675, __FUNCTION__), 0 : 0));
 if (act_arg->expr == NULL__null)
   {
     act_arg = act_arg->next;
     continue;
   }
}
    formal_arg = gfc_get_formal_arglist ()((gfc_formal_arglist *) xcalloc (1, sizeof (gfc_formal_arglist
)));
    gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4
←
Calling 'gfc_get_symbol'→
10
←
Returning from 'gfc_get_symbol'→

    /* May need to copy more info for the symbol.  */
    if (copy_type && act_arg->expr != NULL__null)
11
←
Assuming 'copy_type' is false→
{
 formal_arg->sym->ts = act_arg->expr->ts;
 if (act_arg->expr->rank > 0)
   {
     formal_arg->sym->attr.dimension = 1;
     formal_arg->sym->as = gfc_get_array_spec()((gfc_array_spec *) xcalloc (1, sizeof (gfc_array_spec)));
     formal_arg->sym->as->rank = -1;
     formal_arg->sym->as->type = AS_ASSUMED_RANK;
   }
 if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0)
   formal_arg->sym->pass_as_value = 1;
}
    else
formal_arg->sym->ts = curr_arg->ts;
12
←
Called C++ object pointer is null

    formal_arg->sym->attr.optional = curr_arg->optional;
    formal_arg->sym->attr.value = curr_arg->value;
    formal_arg->sym->attr.intent = curr_arg->intent;
    formal_arg->sym->attr.flavor = FL_VARIABLE;
    formal_arg->sym->attr.dummy = 1;

    if (formal_arg->sym->ts.type == BT_CHARACTER)
formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);

    /* If this isn't the first arg, set up the next ptr.  For the
      last arg built, the formal_arg->next will never get set to
      anything other than NULL.  */
    if (formal_prev != NULL__null)
formal_prev->next = formal_arg;
    else
formal_arg->next = NULL__null;

    formal_prev = formal_arg;

    /* Add arg to list of formal args.  */
    add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);

    /* Validate changes.  */
    gfc_commit_symbol (formal_arg->sym);
    if (actual)
act_arg = act_arg->next;
  }

/* Add the interface to the symbol.  */
add_proc_interface (dest, IFSRC_DECL, head);

/* Store the formal namespace information.  */
if (dest->formal != NULL__null)
  /* The current ns should be that for the dest proc.  */
  dest->formal_ns = gfc_current_ns;
/* Restore the current namespace to what it was on entry.  */
gfc_current_ns = parent_ns;
4739}


4742static int
4743std_for_isocbinding_symbol (int id)
4744{
switch (id)
  {
4747#define NAMED_INTCST(a,b,c,d) \
    case a:\
      return d;
4750#include "iso-c-binding.def"
4751#undef NAMED_INTCST

4753#define NAMED_FUNCTION(a,b,c,d) \
    case a:\
      return d;
4756#define NAMED_SUBROUTINE(a,b,c,d) \
    case a:\
      return d;
4759#include "iso-c-binding.def"
4760#undef NAMED_FUNCTION
4761#undef NAMED_SUBROUTINE

     default:
       return GFC_STD_F2003(1<<4);
  }
4766}

4768/* Generate the given set of C interoperable kind objects, or all
 interoperable kinds.  This function will only be given kind objects
 for valid iso_c_binding defined types because this is verified when
 the 'use' statement is parsed.  If the user gives an 'only' clause,
 the specific kinds are looked up; if they don't exist, an error is
 reported.  If the user does not give an 'only' clause, all
 iso_c_binding symbols are generated.  If a list of specific kinds
 is given, it must have a NULL in the first empty spot to mark the
 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
 point to the symtree for c_(fun)ptr.  */

4779gfc_symtree *
4780generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
	     const char *local_name, gfc_symtree *dt_symtree,
	     bool hidden)
4783{
const char *const name = (local_name && local_name[0])
	   ? local_name : c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym = NULL__null;
int index;

if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
  return NULL__null;

tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (hidden
    && (!tmp_symtree || !tmp_symtree->n.sym
 || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
 || tmp_symtree->n.sym->intmod_sym_id != s))
  tmp_symtree = NULL__null;

/* Already exists in this scope so don't re-add it.  */
if (tmp_symtree != NULL__null && (tmp_sym = tmp_symtree->n.sym) != NULL__null
    && (!tmp_sym->attr.generic
 || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL__null)
    && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
  {
    if (tmp_sym->attr.flavor == FL_DERIVED
 && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
{
 if (gfc_derived_types)
   {
     tmp_sym->dt_next = gfc_derived_types->dt_next;
     gfc_derived_types->dt_next = tmp_sym;
   }
 else
   {
     tmp_sym->dt_next = tmp_sym;
   }
 gfc_derived_types = tmp_sym;
      }

    return tmp_symtree;
  }

/* Create the sym tree in the current ns.  */
if (hidden)
  {
    tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
    tmp_sym = gfc_new_symbol (name, gfc_current_ns);

    /* Add to the list of tentative symbols.  */
    latest_undo_chgset->syms.safe_push (tmp_sym);
    tmp_sym->old_symbol = NULL__null;
    tmp_sym->mark = 1;
    tmp_sym->gfc_new = 1;

    tmp_symtree->n.sym = tmp_sym;
    tmp_sym->refs++;
  }
else
  {
    gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
    gcc_assert (tmp_symtree)((void)(!(tmp_symtree) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4842, __FUNCTION__), 0 : 0));
    tmp_sym = tmp_symtree->n.sym;
  }

/* Say what module this symbol belongs to.  */
tmp_sym->module = gfc_get_string ("%s", mod_name);
tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
tmp_sym->intmod_sym_id = s;
tmp_sym->attr.is_iso_c = 1;
tmp_sym->attr.use_assoc = 1;

gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR((void)(!(dt_symtree == __null || s == ISOCBINDING_NULL_FUNPTR
 || s == ISOCBINDING_NULL_PTR) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4854, __FUNCTION__), 0 : 0))
     || s == ISOCBINDING_NULL_PTR)((void)(!(dt_symtree == __null || s == ISOCBINDING_NULL_FUNPTR
 || s == ISOCBINDING_NULL_PTR) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4854, __FUNCTION__), 0 : 0));

switch (s)
  {

4859#define NAMED_INTCST(a,b,c,d) case a :
4860#define NAMED_REALCST(a,b,c,d) case a :
4861#define NAMED_CMPXCST(a,b,c,d) case a :
4862#define NAMED_LOGCST(a,b,c) case a :
4863#define NAMED_CHARKNDCST(a,b,c) case a :
4864#include "iso-c-binding.def"

tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL__null,
		 	   c_interop_kinds_table[s].value);

/* Initialize an integer constant expression node.  */
tmp_sym->attr.flavor = FL_PARAMETER;
tmp_sym->ts.type = BT_INTEGER;
tmp_sym->ts.kind = gfc_default_integer_kind;

/* Mark this type as a C interoperable one.  */
tmp_sym->ts.is_c_interop = 1;
tmp_sym->ts.is_iso_c = 1;
tmp_sym->value->ts.is_c_interop = 1;
tmp_sym->value->ts.is_iso_c = 1;
tmp_sym->attr.is_c_interop = 1;

/* Tell what f90 type this c interop kind is valid.  */
tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;

break;


4887#define NAMED_CHARCST(a,b,c) case a :
4888#include "iso-c-binding.def"

/* Initialize an integer constant expression node for the
  length of the character.  */
tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
				 &gfc_current_locus, NULL__null, 1);
tmp_sym->value->ts.is_c_interop = 1;
tmp_sym->value->ts.is_iso_c = 1;
tmp_sym->value->value.character.length = 1;
tmp_sym->value->value.character.string[0]
 = (gfc_char_t) c_interop_kinds_table[s].value;
tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
				     NULL__null, 1);

/* May not need this in both attr and ts, but do need in
  attr for writing module file.  */
tmp_sym->attr.is_c_interop = 1;

tmp_sym->attr.flavor = FL_PARAMETER;
tmp_sym->ts.type = BT_CHARACTER;

/* Need to set it to the C_CHAR kind.  */
tmp_sym->ts.kind = gfc_default_character_kind;

/* Mark this type as a C interoperable one.  */
tmp_sym->ts.is_c_interop = 1;
tmp_sym->ts.is_iso_c = 1;

/* Tell what f90 type this c interop kind is valid.  */
tmp_sym->ts.f90_type = BT_CHARACTER;

break;

    case ISOCBINDING_PTR:
    case ISOCBINDING_FUNPTR:
{
 gfc_symbol *dt_sym;
 gfc_component *tmp_comp = NULL__null;

 /* Generate real derived type.  */
 if (hidden)
   dt_sym = tmp_sym;
 else
   {
     const char *hidden_name;
     gfc_interface *intr, *head;

     hidden_name = gfc_dt_upper_string (tmp_sym->name);
     tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
			      hidden_name);
     gcc_assert (tmp_symtree == NULL)((void)(!(tmp_symtree == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4939, __FUNCTION__), 0 : 0));
     gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
     dt_sym = tmp_symtree->n.sym;
     dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
			     ? "c_ptr" : "c_funptr");

     /* Generate an artificial generic function.  */
     head = tmp_sym->generic;
     intr = gfc_get_interface ()((gfc_interface *) xcalloc (1, sizeof (gfc_interface)));
     intr->sym = dt_sym;
     intr->where = gfc_current_locus;
     intr->next = head;
     tmp_sym->generic = intr;

     if (!tmp_sym->attr.generic
  && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL__null))
return NULL__null;

     if (!tmp_sym->attr.function
  && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL__null))
return NULL__null;
   }

 /* Say what module this symbol belongs to.  */
 dt_sym->module = gfc_get_string ("%s", mod_name);
 dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
 dt_sym->intmod_sym_id = s;
        dt_sym->attr.use_assoc = 1;

 /* Initialize an integer constant expression node.  */
 dt_sym->attr.flavor = FL_DERIVED;
 dt_sym->ts.is_c_interop = 1;
 dt_sym->attr.is_c_interop = 1;
 dt_sym->attr.private_comp = 1;
 dt_sym->component_access = ACCESS_PRIVATE;
 dt_sym->ts.is_iso_c = 1;
 dt_sym->ts.type = BT_DERIVED;
 dt_sym->ts.f90_type = BT_VOID;

 /* A derived type must have the bind attribute to be
    interoperable (J3/04-007, Section 15.2.3), even though
    the binding label is not used.  */
 dt_sym->attr.is_bind_c = 1;

 dt_sym->attr.referenced = 1;
 dt_sym->ts.u.derived = dt_sym;

 /* Add the symbol created for the derived type to the current ns.  */
 if (gfc_derived_types)
   {
     dt_sym->dt_next = gfc_derived_types->dt_next;
     gfc_derived_types->dt_next = dt_sym;
   }
 else
   {
     dt_sym->dt_next = dt_sym;
   }
 gfc_derived_types = dt_sym;

 gfc_add_component (dt_sym, "c_address", &tmp_comp);
 if (tmp_comp == NULL__null)
   gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5000, __FUNCTION__));

 tmp_comp->ts.type = BT_INTEGER;

 /* Set this because the module will need to read/write this field.  */
 tmp_comp->ts.f90_type = BT_INTEGER;

 /* The kinds for c_ptr and c_funptr are the same.  */
 index = get_c_kind ("c_ptr", c_interop_kinds_table);
 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
 tmp_comp->attr.access = ACCESS_PRIVATE;

 /* Mark the component as C interoperable.  */
 tmp_comp->ts.is_c_interop = 1;
}

break;

    case ISOCBINDING_NULL_PTR:
    case ISOCBINDING_NULL_FUNPTR:
      gen_special_c_interop_ptr (tmp_sym, dt_symtree);
      break;

    default:
gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5024, __FUNCTION__));
  }
gfc_commit_symbol (tmp_sym);
return tmp_symtree;
5028}


5031/* Check that a symbol is already typed.  If strict is not set, an untyped
 symbol is acceptable for non-standard-conforming mode.  */

5034bool
5035gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
	bool strict, locus where)
5037{
gcc_assert (sym)((void)(!(sym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5038, __FUNCTION__), 0 : 0));

if (gfc_matching_prefix)
  return true;

/* Check for the type and try to give it an implicit one.  */
if (sym->ts.type == BT_UNKNOWN
    && !gfc_set_default_type (sym, 0, ns))
  {
    if (strict)
{
 gfc_error ("Symbol %qs is used before it is typed at %L",
     sym->name, &where);
 return false;
}

    if (!gfc_notify_std (GFC_STD_GNU(1<<5), "Symbol %qs is used before"
	   " it is typed at %L", sym->name, &where))
return false;
  }

/* Everything is ok.  */
return true;
5061}


5064/* Construct a typebound-procedure structure.  Those are stored in a tentative
 list and marked `error' until symbols are committed.  */

5067gfc_typebound_proc*
5068gfc_get_typebound_proc (gfc_typebound_proc *tb0)
5069{
gfc_typebound_proc *result;

result = XCNEW (gfc_typebound_proc)((gfc_typebound_proc *) xcalloc (1, sizeof (gfc_typebound_proc
)));
if (tb0)
  *result = *tb0;
result->error = 1;

latest_undo_chgset->tbps.safe_push (result);

return result;
5080}


5083/* Get the super-type of a given derived type.  */

5085gfc_symbol*
5086gfc_get_derived_super_type (gfc_symbol* derived)
5087{
gcc_assert (derived)((void)(!(derived) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5088, __FUNCTION__), 0 : 0));

if (derived->attr.generic)
  derived = gfc_find_dt_in_generic (derived);

if (!derived->attr.extension)
  return NULL__null;

gcc_assert (derived->components)((void)(!(derived->components) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5096, __FUNCTION__), 0 : 0));
gcc_assert (derived->components->ts.type == BT_DERIVED)((void)(!(derived->components->ts.type == BT_DERIVED) ?
 fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5097, __FUNCTION__), 0 : 0));
gcc_assert (derived->components->ts.u.derived)((void)(!(derived->components->ts.u.derived) ? fancy_abort
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5098, __FUNCTION__), 0 : 0));

if (derived->components->ts.u.derived->attr.generic)
  return gfc_find_dt_in_generic (derived->components->ts.u.derived);

return derived->components->ts.u.derived;
5104}


5107/* Get the ultimate super-type of a given derived type.  */

5109gfc_symbol*
5110gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
5111{
if (!derived->attr.extension)
  return NULL__null;

derived = gfc_get_derived_super_type (derived);

if (derived->attr.extension)
  return gfc_get_ultimate_derived_super_type (derived);
else
  return derived;
5121}


5124/* Check if a derived type t2 is an extension of (or equal to) a type t1.  */

5126bool
5127gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
5128{
while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
  t2 = gfc_get_derived_super_type (t2);
return gfc_compare_derived_types (t1, t2);
5132}


5135/* Check if two typespecs are type compatible (F03:5.1.1.2):
 If ts1 is nonpolymorphic, ts2 must be the same type.
 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */

5139bool
5140gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
5141{
bool is_class1 = (ts1->type == BT_CLASS);
bool is_class2 = (ts2->type == BT_CLASS);
bool is_derived1 = (ts1->type == BT_DERIVED);
bool is_derived2 = (ts2->type == BT_DERIVED);
bool is_union1 = (ts1->type == BT_UNION);
bool is_union2 = (ts2->type == BT_UNION);

if (is_class1
    && ts1->u.derived->components
    && ((ts1->u.derived->attr.is_class
  && ts1->u.derived->components->ts.u.derived->attr
					.unlimited_polymorphic)
 || ts1->u.derived->attr.unlimited_polymorphic))
  return 1;

if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2
    && !is_union1 && !is_union2)
  return (ts1->type == ts2->type);

if ((is_derived1 && is_derived2) || (is_union1 && is_union2))
  return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);

if (is_derived1 && is_class2)
  return gfc_compare_derived_types (ts1->u.derived,
		      ts2->u.derived->attr.is_class ?
		      ts2->u.derived->components->ts.u.derived
		      : ts2->u.derived);
if (is_class1 && is_derived2)
  return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
		       ts1->u.derived->components->ts.u.derived
		     : ts1->u.derived,
		     ts2->u.derived);
else if (is_class1 && is_class2)
  return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
		       ts1->u.derived->components->ts.u.derived
		     : ts1->u.derived,
		     ts2->u.derived->attr.is_class ?
		       ts2->u.derived->components->ts.u.derived
		     : ts2->u.derived);
else
  return 0;
5183}


5186/* Find the parent-namespace of the current function.  If we're inside
 BLOCK constructs, it may not be the current one.  */

5189gfc_namespace*
5190gfc_find_proc_namespace (gfc_namespace* ns)
5191{
while (ns->construct_entities)
  {
    ns = ns->parent;
    gcc_assert (ns)((void)(!(ns) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5195, __FUNCTION__), 0 : 0));
  }

return ns;
5199}


5202/* Check if an associate-variable should be translated as an `implicit' pointer
 internally (if it is associated to a variable and not an array with
 descriptor).  */

5206bool
5207gfc_is_associate_pointer (gfc_symbol* sym)
5208{
if (!sym->assoc)
  return false;

if (sym->ts.type == BT_CLASS)
  return true;

if (sym->ts.type == BT_CHARACTER
    && sym->ts.deferred
    && sym->assoc->target
    && sym->assoc->target->expr_type == EXPR_FUNCTION)
  return true;

if (!sym->assoc->variable)
  return false;

if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
  return false;

return true;
5228}


5231gfc_symbol *
5232gfc_find_dt_in_generic (gfc_symbol *sym)
5233{
gfc_interface *intr = NULL__null;

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

if (sym->attr.generic)
  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;
return intr ? intr->sym : NULL__null;
5244}


5247/* Get the dummy arguments from a procedure symbol. If it has been declared
 via a PROCEDURE statement with a named interface, ts.interface will be set
 and the arguments need to be taken from there.  */

5251gfc_formal_arglist *
5252gfc_sym_get_dummy_args (gfc_symbol *sym)
5253{
gfc_formal_arglist *dummies;

dummies = sym->formal;
if (dummies == NULL__null && sym->ts.interface != NULL__null)
  dummies = sym->ts.interface->formal;

return dummies;
5261}