Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / fortran / symbol.cc
blob: 7a80dfd063b1ba66c0f9e35efd2c07d1659cd3d2 [file] [log] [blame]
/* Maintain binary trees of symbols.
Copyright (C) 2000-2022 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "options.h"
#include "gfortran.h"
#include "parse.h"
#include "match.h"
#include "constructor.h"
/* Strings for all symbol attributes. We use these for dumping the
parse tree, in error messages, and also when reading and writing
modules. */
const mstring flavors[] =
{
minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT),
minit (NULL, -1)
};
const mstring procedures[] =
{
minit ("UNKNOWN-PROC", PROC_UNKNOWN),
minit ("MODULE-PROC", PROC_MODULE),
minit ("INTERNAL-PROC", PROC_INTERNAL),
minit ("DUMMY-PROC", PROC_DUMMY),
minit ("INTRINSIC-PROC", PROC_INTRINSIC),
minit ("EXTERNAL-PROC", PROC_EXTERNAL),
minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
minit (NULL, -1)
};
const mstring intents[] =
{
minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
minit ("IN", INTENT_IN),
minit ("OUT", INTENT_OUT),
minit ("INOUT", INTENT_INOUT),
minit (NULL, -1)
};
const mstring access_types[] =
{
minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
minit ("PUBLIC", ACCESS_PUBLIC),
minit ("PRIVATE", ACCESS_PRIVATE),
minit (NULL, -1)
};
const mstring ifsrc_types[] =
{
minit ("UNKNOWN", IFSRC_UNKNOWN),
minit ("DECL", IFSRC_DECL),
minit ("BODY", IFSRC_IFBODY)
};
const mstring save_status[] =
{
minit ("UNKNOWN", SAVE_NONE),
minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
};
/* Set the mstrings for DTIO procedure names. */
const mstring dtio_procs[] =
{
minit ("_dtio_formatted_read", DTIO_RF),
minit ("_dtio_formatted_write", DTIO_WF),
minit ("_dtio_unformatted_read", DTIO_RUF),
minit ("_dtio_unformatted_write", DTIO_WUF),
};
/* This is to make sure the backend generates setup code in the correct
order. */
static int next_dummy_order = 1;
gfc_namespace *gfc_current_ns;
gfc_namespace *gfc_global_ns_list;
gfc_gsymbol *gfc_gsym_root = NULL;
gfc_symbol *gfc_derived_types;
static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
/* The following static variable indicates whether a particular element has
been explicitly set or not. */
static int new_flag[GFC_LETTERS];
/* Handle a correctly parsed IMPLICIT NONE. */
void
gfc_set_implicit_none (bool type, bool external, locus *loc)
{
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_LETTERS; 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;
}
}
}
/* Reset the implicit range flags. */
void
gfc_clear_new_implicit (void)
{
int i;
for (i = 0; i < GFC_LETTERS; i++)
new_flag[i] = 0;
}
/* Prepare for a new implicit range. Sets flags in new_flag[]. */
bool
gfc_add_new_implicit_range (int c1, int c2)
{
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;
}
/* Add a matched implicit range for gfc_set_implicit(). Check if merging
the new implicit types back into the existing types will work. */
bool
gfc_merge_new_implicit (gfc_typespec *ts)
{
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_LETTERS; 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;
}
/* Given a symbol, return a pointer to the typespec for its default type. */
gfc_typespec *
gfc_get_default_type (const char *name, gfc_namespace *ns)
{
char letter;
letter = name[0];
if (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)
ns = gfc_current_ns;
return &ns->default_type[letter - 'a'];
}
/* Recursively append candidate SYM to CANDIDATES. Store the number of
candidates in CANDIDATES_LEN. */
static void
lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
char **&candidates,
size_t &candidates_len)
{
gfc_symtree *p;
if (sym == 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);
}
/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
static const char*
lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
{
char **candidates = 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);
}
/* 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. */
bool
gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
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 && !gfc_query_suppress_errors ())
{
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_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
&& (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_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;
}
/* This function is called from parse.cc(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. */
void
gfc_check_function_type (gfc_namespace *ns)
{
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)
{
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;
}
}
}
/******************** Symbol attribute stuff *********************/
/* This is a generic conflict-checker. We do this to avoid having a
single conflict in two places. */
#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
#define conf_std(a, b, std) if (attr->a && attr->b)\
{\
a1 = a;\
a2 = b;\
standard = std;\
goto conflict_std;\
}
bool
gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
{
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)
where = &gfc_current_locus;
if (attr->pointer && attr->intent != INTENT_UNKNOWN)
{
a1 = pointer;
a2 = intent;
standard = GFC_STD_F2003;
goto conflict_std;
}
if (attr->in_namelist && (attr->allocatable || attr->pointer))
{
a1 = in_namelist;
a2 = attr->allocatable ? allocatable : pointer;
standard = GFC_STD_F2003;
goto conflict_std;
}
/* Check for attributes not allowed in a BLOCK DATA. */
if (gfc_current_state () == COMP_BLOCK_DATA)
{
a1 = 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)
{
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_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 () == 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,
"Procedure pointer at %C"))
return false;
conf (allocatable, pointer);
conf_std (allocatable, dummy, GFC_STD_F2003);
conf_std (allocatable, function, GFC_STD_F2003);
conf_std (allocatable, result, GFC_STD_F2003);
conf_std (elemental, recursive, GFC_STD_F2018);
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)
conf (pdt_len, pdt_kind)
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))
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_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;
conflict:
if (name == 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;
conflict_std:
if (name == 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);
}
}
#undef conf
#undef conf2
#undef conf_std
/* Mark a symbol as referenced. */
void
gfc_set_sym_referenced (gfc_symbol *sym)
{
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++;
}
/* 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. */
static int
check_used (symbol_attribute *attr, const char *name, locus *where)
{
if (attr->use_assoc == 0)
return 0;
if (where == NULL)
where = &gfc_current_locus;
if (name == 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;
}
/* Generate an error because of a duplicate attribute. */
static void
duplicate_attr (const char *attr, locus *where)
{
if (where == NULL)
where = &gfc_current_locus;
gfc_error ("Duplicate %s attribute specified at %L", attr, where);
}
bool
gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
locus *where ATTRIBUTE_UNUSED)
{
attr->ext_attr |= 1 << ext_attr;
return true;
}
/* Called from decl.cc (attr_decl1) to check attributes, when declared
separately. */
bool
gfc_add_attribute (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->allocatable && ! gfc_submodule_procedure(attr))
{
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, where);
}
bool
gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY,
"Duplicate AUTOMATIC attribute specified at %L", where))
return false;
attr->automatic = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
{
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);
}
bool
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
if (attr->dimension && ! gfc_submodule_procedure(attr))
{
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);
}
bool
gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
attr->contiguous = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_external (symbol_attribute *attr, locus *where)
{
if (check_used (attr, 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, where);
}
bool
gfc_add_intrinsic (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->intrinsic)
{
duplicate_attr ("INTRINSIC", where);
return false;
}
attr->intrinsic = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_optional (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->optional)
{
duplicate_attr ("OPTIONAL", where);
return false;
}
attr->optional = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_kind (symbol_attribute *attr, locus *where)
{
if (attr->pdt_kind)
{
duplicate_attr ("KIND", where);
return false;
}
attr->pdt_kind = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_len (symbol_attribute *attr, locus *where)
{
if (attr->pdt_len)
{
duplicate_attr ("LEN", where);
return false;
}
attr->pdt_len = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_pointer (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
&& !gfc_find_state (COMP_INTERFACE))
&& ! gfc_submodule_procedure(attr))
{
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, where);
}
bool
gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
attr->cray_pointer = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
{
if (check_used (attr, 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, where);
}
bool
gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
if (attr->is_protected)
{
if (!gfc_notify_std (GFC_STD_LEGACY,
"Duplicate PROTECTED attribute specified at %L",
where))
return false;
}
attr->is_protected = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
attr->result = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
locus *where)
{
if (check_used (attr, name, where))
return false;
if (s == SAVE_EXPLICIT && gfc_pure (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);
if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT
&& (flag_automatic || pedantic))
{
if (!gfc_notify_std (GFC_STD_LEGACY,
"Duplicate SAVE attribute specified at %L",
where))
return false;
}
attr->save = s;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
if (attr->value)
{
if (!gfc_notify_std (GFC_STD_LEGACY,
"Duplicate VALUE attribute specified at %L",
where))
return false;
}
attr->value = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
{
/* 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,
"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))
{
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);
}
bool
gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
{
/* 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,
"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);
}
bool
gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
{
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);
}
bool
gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
locus *where)
{
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);
}
bool
gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
locus *where)
{
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);
}
bool
gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
locus *where)
{
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);
}
bool
gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name,
locus *where)
{
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);
}
bool
gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name,
locus *where)
{
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);
}
bool
gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name,
locus *where)
{
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);
}
bool
gfc_add_target (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->target)
{
duplicate_attr ("TARGET", where);
return false;
}
attr->target = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
{
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);
}
bool
gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
/* Duplicate attribute already checked for. */
attr->in_common = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
{
/* 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);
}
bool
gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
attr->data = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
{
attr->in_namelist = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
attr->sequence = 1;
return gfc_check_conflict (attr, name, where);
}
bool
gfc_add_elemental (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->elemental)
{
duplicate_attr ("ELEMENTAL", where);
return false;
}
attr->elemental = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_pure (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->pure)
{
duplicate_attr ("PURE", where);
return false;
}
attr->pure = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_recursive (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->recursive)
{
duplicate_attr ("RECURSIVE", where);
return false;
}
attr->recursive = 1;
return gfc_check_conflict (attr, NULL, where);
}
bool
gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
{
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);
}
bool
gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
{
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);
}
bool
gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
{
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 () != COMP_BLOCK_DATA)
return gfc_check_conflict (attr, name, where);
else
return true;
}
bool
gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
{
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);
}
bool
gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, 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, where);
}
bool
gfc_add_abstract (symbol_attribute* attr, locus* where)
{
if (attr->abstract)
{
duplicate_attr ("ABSTRACT", where);
return false;
}
attr->abstract = 1;
return gfc_check_conflict (attr, NULL, where);
}
/* Flavors are special because some flavors are not what Fortran
considers attributes and can be reaffirmed multiple times. */
bool
gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
locus *where)
{
if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
|| f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f)
|| 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 (attr->flavor == f && f == FL_PROCEDURE
&& gfc_new_block && gfc_new_block->abr_modproc_decl)
return true;
if (attr->flavor != FL_UNKNOWN)
{
if (where == 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);
}
bool
gfc_add_procedure (symbol_attribute *attr, procedure_type t,
const char *name, locus *where)
{
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)
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))
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);
}
bool
gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
{
if (check_used (attr, NULL, where))
return false;
if (attr->intent == INTENT_UNKNOWN)
{
attr->intent = intent;
return gfc_check_conflict (attr, NULL, where);
}
if (where == 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;
}
/* No checks for use-association in public and private statements. */
bool
gfc_add_access (symbol_attribute *attr, gfc_access access,
const char *name, locus *where)
{
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)
where = &gfc_current_locus;
gfc_error ("ACCESS specification at %L was already specified", where);
return false;
}
/* Set the is_bind_c field for the given symbol_attribute. */
bool
gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
int is_proc_lang_bind_spec)
{
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)
where = &gfc_current_locus;
if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
return false;
return gfc_check_conflict (attr, name, where);
}
/* Set the extension field for the given symbol_attribute. */
bool
gfc_add_extension (symbol_attribute *attr, locus *where)
{
if (where == 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, "EXTENDS at %L", where))
return false;
return true;
}
bool
gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
gfc_formal_arglist * formal, locus *where)
{
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)
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;
}
finish:
sym->formal = formal;
sym->attr.if_source = source;
return true;
}
/* Add a type to a symbol. */
bool
gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
{
sym_flavor flavor;
bt type;
if (where == 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;
}
/* Clears all attributes. */
void
gfc_clear_attr (symbol_attribute *attr)
{
memset (attr, 0, sizeof (symbol_attribute));
}
/* Check for missing attributes in the new symbol. Currently does
nothing, but it's not clear that it is unnecessary yet. */
bool
gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
locus *where ATTRIBUTE_UNUSED)
{
return true;
}
/* 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. */
bool
gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
{
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, where))
goto fail;
if (src->dimension && !gfc_add_dimension (dest, NULL, where))
goto fail;
if (src->codimension && !gfc_add_codimension (dest, NULL, where))
goto fail;
if (src->contiguous && !gfc_add_contiguous (dest, 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, where))
goto fail;
if (src->save && !gfc_add_save (dest, src->save, NULL, where))
goto fail;
if (src->value && !gfc_add_value (dest, NULL, where))
goto fail;
if (src->volatile_ && !gfc_add_volatile (dest, NULL, where))
goto fail;
if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where))
goto fail;
if (src->threadprivate
&& !gfc_add_threadprivate (dest, NULL, where))
goto fail;
if (src->omp_declare_target
&& !gfc_add_omp_declare_target (dest, NULL, where))
goto fail;
if (src->omp_declare_target_link
&& !gfc_add_omp_declare_target_link (dest, NULL, where))
goto fail;
if (src->oacc_declare_create
&& !gfc_add_oacc_declare_create (dest, NULL, where))
goto fail;
if (src->oacc_declare_copyin
&& !gfc_add_oacc_declare_copyin (dest, NULL, where))
goto fail;
if (src->oacc_declare_deviceptr
&& !gfc_add_oacc_declare_deviceptr (dest, NULL, where))
goto fail;
if (src->oacc_declare_device_resident
&& !gfc_add_oacc_declare_device_resident (dest, NULL, where))
goto fail;
if (src->target && !gfc_add_target (dest, where))
goto fail;
if (src->dummy && !gfc_add_dummy (dest, NULL, where))
goto fail;
if (src->result && !gfc_add_result (dest, NULL, where))
goto fail;
if (src->entry)
dest->entry = 1;
if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where))
goto fail;
if (src->in_common && !gfc_add_in_common (dest, NULL, where))
goto fail;
if (src->generic && !gfc_add_generic (dest, NULL, where))
goto fail;
if (src->function && !gfc_add_function (dest, NULL, where))
goto fail;
if (src->subroutine && !gfc_add_subroutine (dest, NULL, where))
goto fail;
if (src->sequence && !gfc_add_sequence (dest, 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, 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, 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, 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;
fail:
return false;
}
/* 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. */
int
gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result)
{
int rc;
rc = gfc_get_symbol (sym->name, 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 && !result
&& (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL)
|| !gfc_missing_attr (&(*dsym)->attr, NULL)))
return 1;
else if ((*dsym) != NULL && result
&& (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL)
|| !gfc_missing_attr (&(*dsym)->attr, NULL)))
return 1;
return 0;
}
/************** Component name management ************/
/* 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. */
/* 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. */
bool
gfc_add_component (gfc_symbol *sym, const char *name,
gfc_component **component)
{
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;
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))
{
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 ();
if (tail == 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;
}
/* Recursive function to switch derived types of all symbol in a
namespace. */
static void
switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
{
gfc_symbol *sym;
if (st == 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);
}
/* 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. */
gfc_symbol *
gfc_use_derived (gfc_symbol *sym)
{
gfc_symbol *s;
gfc_typespec *t;
gfc_symtree *st;
int i;
if (!sym)
return NULL;
if (sym->attr.unlimited_polymorphic)
return sym;
if (sym->attr.generic)
sym = gfc_find_dt_in_generic (sym);
if (sym->components != NULL || sym->attr.zero_comp)
return sym; /* Already defined. */
if (sym->ns->parent == 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;
}
if (s == NULL || !gfc_fl_struct (s->attr.flavor))
goto bad;
/* Get rid of symbol sym, translating all references to s. */
for (i = 0; i < GFC_LETTERS; 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;
bad:
gfc_error ("Derived type %qs at %C is being used before it is defined",
sym->name);
return NULL;
}
/* 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. */
static gfc_component *
find_union_component (gfc_symbol *un, const char *name,
bool noaccess, gfc_ref **ref)
{
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)
continue;
/* Found component somewhere in m; chain the refs together. */
if (ref)
{
/* Map ref. */
sref = gfc_get_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;
}
/* Recursively append candidate COMPONENT structures to CANDIDATES. Store
the number of total candidates in CANDIDATES_LEN. */
static void
lookup_component_fuzzy_find_candidates (gfc_component *component,
char **&candidates,
size_t &candidates_len)
{
for (gfc_component *p = component; p; p = p->next)
vec_push (candidates, candidates_len, p->name);
}
/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
static const char*
lookup_component_fuzzy (const char *member, gfc_component *component)
{
char **candidates = NULL;
size_t candidates_len = 0;
lookup_component_fuzzy_find_candidates (component, candidates,
candidates_len);
return gfc_closest_fuzzy_match (member, candidates);
}
/* 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). */
gfc_component *
gfc_find_component (gfc_symbol *sym, const char *name,
bool noaccess, bool silent, gfc_ref **ref)
{
gfc_component *p, *check;
gfc_ref *sref = NULL, *tmp = NULL;
if (name == NULL || sym == NULL)
return NULL;
if (sym->attr.flavor == FL_DERIVED)
sym = gfc_use_derived (sym);
else
gcc_assert (gfc_fl_struct (sym->attr.flavor));
if (sym == NULL)
return 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;
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)
{
/* Union ref. */
if (ref)
{
sref = gfc_get_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;
}
}
if (p == 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)
return p;
}
if (p == 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 && ref)
{
tmp = gfc_get_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;
}
/* Given a symbol, free all of the component structures and everything
they point to. */
static void
free_components (gfc_component *p)
{
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);
p->tb = NULL;
free (p);
}
}
/******************** Statement label management ********************/
/* Comparison function for statement labels, used for managing the
binary tree. */
static int
compare_st_labels (void *a1, void *b1)
{
int a = ((gfc_st_label *) a1)->value;
int b = ((gfc_st_label *) b1)->value;
return (b - a);
}
/* 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. */
void
gfc_free_st_label (gfc_st_label *label)
{
if (label == NULL)
return;
gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
if (label->format != NULL)
gfc_free_expr (label->format);
free (label);
}
/* Free a whole tree of gfc_st_label structures. */
static void
free_st_labels (gfc_st_label *label)
{
if (label == NULL)
return;
free_st_labels (label->left);
free_st_labels (label->right);
if (label->format != NULL)
gfc_free_expr (label->format);
free (label);
}
/* Given a label number, search for and return a pointer to the label
structure, creating it if it does not exist. */
gfc_st_label *
gfc_get_st_label (int labelno)
{
gfc_st_label *lp;
gfc_namespace *ns;
if (gfc_current_state () == COMP_DERIVED)
ns = gfc_current_block ()->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);
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;
}
/* 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. */
void
gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
{
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 | GFC_STD_F2018_DEL,
"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;
}
}
}
/* 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. */
bool
gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
{
gfc_sl_type label_type;
int labelno;
bool rc;
if (lp == 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 | GFC_STD_F2018_DEL,
"Shared DO termination label %d at %C", labelno))
return false;
if (type == ST_LABEL_DO_TARGET
&& !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement "
"at %L", &gfc_current_locus))
return false;
if (lp->referenced != ST_LABEL_DO_TARGET)
lp->referenced = type;
rc = true;
done:
return rc;
}
/************** Symbol table management subroutines ****************/
/* 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. */
/* Allocate a new namespace structure. Copies the implicit types from
PARENT if PARENT_TYPES is set. */
gfc_namespace *
gfc_get_namespace (gfc_namespace *parent, int parent_types)
{
gfc_namespace *ns;
gfc_typespec *ts;
int in;
int i;
ns = XCNEW (gfc_namespace);
ns->sym_root = NULL;
ns->uop_root = NULL;
ns->tb_sym_root = NULL;
ns->finalizers = 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;
}
/* 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)
{
/* Copy parent settings. */
*ts = ns->parent->default_type[i - 'a'];
continue;
}
if (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;
}
/* Comparison function for symtree nodes. */
static int
compare_symtree (void *_st1, void *_st2)
{
gfc_symtree *st1, *st2;
st1 = (gfc_symtree *) _st1;
st2 = (gfc_symtree *) _st2;
return strcmp (st1->name, st2->name);
}
/* Allocate a new symtree node and associate it with the new symbol. */
gfc_symtree *
gfc_new_symtree (gfc_symtree **root, const char *name)
{
gfc_symtree *st;
st = XCNEW (gfc_symtree);
st->name = gfc_get_string ("%s", name);
gfc_insert_bbt (root, st, compare_symtree);
return st;
}
/* Delete a symbol from the tree. Does not free the symbol itself! */
void
gfc_delete_symtree (gfc_symtree **root, const char *name)
{
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);
}
/* Given a root symtree node and a name, try to find the symbol within
the namespace. Returns NULL if the symbol is not found. */
gfc_symtree *
gfc_find_symtree (gfc_symtree *st, const char *name)
{
int c;
while (st != NULL)
{
c = strcmp (name, st->name);
if (c == 0)
return st;
st = (c < 0) ? st->left : st->right;
}
return NULL;
}
/* Return a symtree node with a name that is guaranteed to be unique
within the namespace and corresponds to an illegal fortran name. */
gfc_symtree *
gfc_get_unique_symtree (gfc_namespace *ns)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
static int serial = 0;
sprintf (name, "@%d", serial++);
return gfc_new_symtree (&ns->sym_root, name);
}
/* 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. */
gfc_user_op *
gfc_get_uop (const char *name)
{
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)
return st->n.uop;
st = gfc_new_symtree (&ns->uop_root, name);
uop = st->n.uop = XCNEW (gfc_user_op);
uop->name = gfc_get_string ("%s", name);
uop->access = ACCESS_UNKNOWN;
uop->ns = ns;
return uop;
}
/* Given a name find the user operator node. Returns NULL if it does
not exist. */
gfc_user_op *
gfc_find_uop (const char *name, gfc_namespace *ns)
{
gfc_symtree *st;
if (ns == NULL)
ns = gfc_current_ns;
st = gfc_find_symtree (ns->uop_root, name);
return (st == NULL) ? NULL : st->n.uop;
}
/* Update a symbol's common_block field, and take care of the associated
memory management. */
static void
set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
{
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;
}
/* Remove a gfc_symbol structure and everything it points to. */
void
gfc_free_symbol (gfc_symbol *&sym)
{
if (sym == 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);
if (sym->param_list)
gfc_free_actual_arglist (sym->param_list);
free (sym);
sym = NULL;
}
/* Decrease the reference counter and free memory when we reach zero. */
void
gfc_release_symbol (gfc_symbol *&sym)
{
if (sym == NULL)
return;
if (sym->formal_ns != 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;
gfc_free_namespace (ns);
}
sym->refs--;
if (sym->refs > 0)
return;
gcc_assert (sym->refs == 0);
gfc_free_symbol (sym);
}
/* Allocate and initialize a new symbol node. */
gfc_symbol *
gfc_new_symbol (const char *name, gfc_namespace *ns)
{
gfc_symbol *p;
p = XCNEW (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;
}
/* Generate an error if a symbol is ambiguous, and set the error flag
on it. */
static void
ambiguous_symbol (const char *name, gfc_symtree *st)
{
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;
}
/* 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. */
static void
select_type_insert_tmp (gfc_symtree **st)
{
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;
}
}
/* 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. */