Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / fortran / resolve.cc
blob: 29df531cdb61902f9a8e9b2acbb1dd51de2531ca [file] [log] [blame]
/* Perform type resolution on the various structures.
Copyright (C) 2001-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 "bitmap.h"
#include "gfortran.h"
#include "arith.h" /* For gfc_compare_expr(). */
#include "dependency.h"
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
#include "constructor.h"
/* Types used in equivalence statements. */
enum seq_type
{
SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
};
/* Stack to keep track of the nesting of blocks as we move through the
code. See resolve_branch() and gfc_resolve_code(). */
typedef struct code_stack
{
struct gfc_code *head, *current;
struct code_stack *prev;
/* This bitmap keeps track of the targets valid for a branch from
inside this block except for END {IF|SELECT}s of enclosing
blocks. */
bitmap reachable_labels;
}
code_stack;
static code_stack *cs_base = NULL;
/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
static int forall_flag;
int gfc_do_concurrent_flag;
/* True when we are resolving an expression that is an actual argument to
a procedure. */
static bool actual_arg = false;
/* True when we are resolving an expression that is the first actual argument
to a procedure. */
static bool first_actual_arg = false;
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
static int omp_workshare_flag;
/* True if we are processing a formal arglist. The corresponding function
resets the flag each time that it is read. */
static bool formal_arg_flag = false;
/* True if we are resolving a specification expression. */
static bool specification_expr = false;
/* The id of the last entry seen. */
static int current_entry_id;
/* We use bitmaps to determine if a branch target is valid. */
static bitmap_obstack labels_obstack;
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
bool
gfc_is_formal_arg (void)
{
return formal_arg_flag;
}
/* Is the symbol host associated? */
static bool
is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
{
for (ns = ns->parent; ns; ns = ns->parent)
{
if (sym->ns == ns)
return true;
}
return false;
}
/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
an ABSTRACT derived-type. If where is not NULL, an error message with that
locus is printed, optionally using name. */
static bool
resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
{
if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
{
if (where)
{
if (name)
gfc_error ("%qs at %L is of the ABSTRACT type %qs",
name, where, ts->u.derived->name);
else
gfc_error ("ABSTRACT type %qs used at %L",
ts->u.derived->name, where);
}
return false;
}
return true;
}
static bool
check_proc_interface (gfc_symbol *ifc, locus *where)
{
/* Several checks for F08:C1216. */
if (ifc->attr.procedure)
{
gfc_error ("Interface %qs at %L is declared "
"in a later PROCEDURE statement", ifc->name, where);
return false;
}
if (ifc->generic)
{
/* For generic interfaces, check if there is
a specific procedure with the same name. */
gfc_interface *gen = ifc->generic;
while (gen && strcmp (gen->sym->name, ifc->name) != 0)
gen = gen->next;
if (!gen)
{
gfc_error ("Interface %qs at %L may not be generic",
ifc->name, where);
return false;
}
}
if (ifc->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Interface %qs at %L may not be a statement function",
ifc->name, where);
return false;
}
if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
|| gfc_is_intrinsic (ifc, 1, ifc->declared_at))
ifc->attr.intrinsic = 1;
if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
{
gfc_error ("Intrinsic procedure %qs not allowed in "
"PROCEDURE statement at %L", ifc->name, where);
return false;
}
if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
{
gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
return false;
}
return true;
}
static void resolve_symbol (gfc_symbol *sym);
/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
static bool
resolve_procedure_interface (gfc_symbol *sym)
{
gfc_symbol *ifc = sym->ts.interface;
if (!ifc)
return true;
if (ifc == sym)
{
gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
sym->name, &sym->declared_at);
return false;
}
if (!check_proc_interface (ifc, &sym->declared_at))
return false;
if (ifc->attr.if_source || ifc->attr.intrinsic)
{
/* Resolve interface and copy attributes. */
resolve_symbol (ifc);
if (ifc->attr.intrinsic)
gfc_resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
{
sym->ts = ifc->result->ts;
sym->attr.allocatable = ifc->result->attr.allocatable;
sym->attr.pointer = ifc->result->attr.pointer;
sym->attr.dimension = ifc->result->attr.dimension;
sym->attr.class_ok = ifc->result->attr.class_ok;
sym->as = gfc_copy_array_spec (ifc->result->as);
sym->result = sym;
}
else
{
sym->ts = ifc->ts;
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
sym->attr.dimension = ifc->attr.dimension;
sym->attr.class_ok = ifc->attr.class_ok;
sym->as = gfc_copy_array_spec (ifc->as);
}
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
sym->attr.subroutine = ifc->attr.subroutine;
sym->attr.pure = ifc->attr.pure;
sym->attr.elemental = ifc->attr.elemental;
sym->attr.contiguous = ifc->attr.contiguous;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
sym->attr.ext_attr |= ifc->attr.ext_attr;
sym->attr.is_bind_c = ifc->attr.is_bind_c;
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
&& !gfc_resolve_expr (sym->ts.u.cl->length))
return false;
}
}
return true;
}
/* Resolve types of formal argument lists. These have to be done early so that
the formal argument lists of module procedures can be copied to the
containing module before the individual procedures are resolved
individually. We also resolve argument lists of procedures in interface
blocks because they are self-contained scoping units.
Since a dummy argument cannot be a non-dummy procedure, the only
resort left for untyped names are the IMPLICIT types. */
void
gfc_resolve_formal_arglist (gfc_symbol *proc)
{
gfc_formal_arglist *f;
gfc_symbol *sym;
bool saved_specification_expr;
int i;
if (proc->result != NULL)
sym = proc->result;
else
sym = proc;
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
|| (sym->as && sym->as->rank != 0))
{
proc->attr.always_explicit = 1;
sym->attr.always_explicit = 1;
}
formal_arg_flag = true;
for (f = proc->formal; f; f = f->next)
{
gfc_array_spec *as;
sym = f->sym;
if (sym == NULL)
{
/* Alternate return placeholder. */
if (gfc_elemental (proc))
gfc_error ("Alternate return specifier in elemental subroutine "
"%qs at %L is not allowed", proc->name,
&proc->declared_at);
if (proc->attr.function)
gfc_error ("Alternate return specifier in function "
"%qs at %L is not allowed", proc->name,
&proc->declared_at);
continue;
}
else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
&& !resolve_procedure_interface (sym))
return;
if (strcmp (proc->name, sym->name) == 0)
{
gfc_error ("Self-referential argument "
"%qs at %L is not allowed", sym->name,
&proc->declared_at);
return;
}
if (sym->attr.if_source != IFSRC_UNKNOWN)
gfc_resolve_formal_arglist (sym);
if (sym->attr.subroutine || sym->attr.external)
{
if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
}
else
{
if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
&& (!sym->attr.function || sym->result == sym))
gfc_set_default_type (sym, 1, sym->ns);
}
as = sym->ts.type == BT_CLASS && sym->attr.class_ok
? CLASS_DATA (sym)->as : sym->as;
saved_specification_expr = specification_expr;
specification_expr = true;
gfc_resolve_array_spec (as, 0);
specification_expr = saved_specification_expr;
/* We can't tell if an array with dimension (:) is assumed or deferred
shape until we know if it has the pointer or allocatable attributes.
*/
if (as && as->rank > 0 && as->type == AS_DEFERRED
&& ((sym->ts.type != BT_CLASS
&& !(sym->attr.pointer || sym->attr.allocatable))
|| (sym->ts.type == BT_CLASS
&& !(CLASS_DATA (sym)->attr.class_pointer
|| CLASS_DATA (sym)->attr.allocatable)))
&& sym->attr.flavor != FL_PROCEDURE)
{
as->type = AS_ASSUMED_SHAPE;
for (i = 0; i < as->rank; i++)
as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
}
if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
|| (as && as->type == AS_ASSUMED_RANK)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
&& (CLASS_DATA (sym)->attr.class_pointer
|| CLASS_DATA (sym)->attr.allocatable
|| CLASS_DATA (sym)->attr.target))
|| sym->attr.optional)
{
proc->attr.always_explicit = 1;
if (proc->result)
proc->result->attr.always_explicit = 1;
}
/* If the flavor is unknown at this point, it has to be a variable.
A procedure specification would have already set the type. */
if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
if (gfc_pure (proc))
{
if (sym->attr.flavor == FL_PROCEDURE)
{
/* F08:C1279. */
if (!gfc_pure (sym))
{
gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
"also be PURE", sym->name, &sym->declared_at);
continue;
}
}
else if (!sym->attr.pointer)
{
if (proc->attr.function && sym->attr.intent != INTENT_IN)
{
if (sym->attr.value)
gfc_notify_std (GFC_STD_F2008, "Argument %qs"
" of pure function %qs at %L with VALUE "
"attribute but without INTENT(IN)",
sym->name, proc->name, &sym->declared_at);
else
gfc_error ("Argument %qs of pure function %qs at %L must "
"be INTENT(IN) or VALUE", sym->name, proc->name,
&sym->declared_at);
}
if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
{
if (sym->attr.value)
gfc_notify_std (GFC_STD_F2008, "Argument %qs"
" of pure subroutine %qs at %L with VALUE "
"attribute but without INTENT", sym->name,
proc->name, &sym->declared_at);
else
gfc_error ("Argument %qs of pure subroutine %qs at %L "
"must have its INTENT specified or have the "
"VALUE attribute", sym->name, proc->name,
&sym->declared_at);
}
}
/* F08:C1278a. */
if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
{
gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
" may not be polymorphic", sym->name, proc->name,
&sym->declared_at);
continue;
}
}
if (proc->attr.implicit_pure)
{
if (sym->attr.flavor == FL_PROCEDURE)
{
if (!gfc_pure (sym))
proc->attr.implicit_pure = 0;
}
else if (!sym->attr.pointer)
{
if (proc->attr.function && sym->attr.intent != INTENT_IN
&& !sym->value)
proc->attr.implicit_pure = 0;
if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
&& !sym->value)
proc->attr.implicit_pure = 0;
}
}
if (gfc_elemental (proc))
{
/* F08:C1289. */
if (sym->attr.codimension
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.codimension))
{
gfc_error ("Coarray dummy argument %qs at %L to elemental "
"procedure", sym->name, &sym->declared_at);
continue;
}
if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->as))
{
gfc_error ("Argument %qs of elemental procedure at %L must "
"be scalar", sym->name, &sym->declared_at);
continue;
}
if (sym->attr.allocatable
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.allocatable))
{
gfc_error ("Argument %qs of elemental procedure at %L cannot "
"have the ALLOCATABLE attribute", sym->name,
&sym->declared_at);
continue;
}
if (sym->attr.pointer
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.class_pointer))
{
gfc_error ("Argument %qs of elemental procedure at %L cannot "
"have the POINTER attribute", sym->name,
&sym->declared_at);
continue;
}
if (sym->attr.flavor == FL_PROCEDURE)
{
gfc_error ("Dummy procedure %qs not allowed in elemental "
"procedure %qs at %L", sym->name, proc->name,
&sym->declared_at);
continue;
}
/* Fortran 2008 Corrigendum 1, C1290a. */
if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
{
gfc_error ("Argument %qs of elemental procedure %qs at %L must "
"have its INTENT specified or have the VALUE "
"attribute", sym->name, proc->name,
&sym->declared_at);
continue;
}
}
/* Each dummy shall be specified to be scalar. */
if (proc->attr.proc == PROC_ST_FUNCTION)
{
if (sym->as != NULL)
{
/* F03:C1263 (R1238) The function-name and each dummy-arg-name
shall be specified, explicitly or implicitly, to be scalar. */
gfc_error ("Argument '%s' of statement function '%s' at %L "
"must be scalar", sym->name, proc->name,
&proc->declared_at);
continue;
}
if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Character-valued argument %qs of statement "
"function at %L must have constant length",
sym->name, &sym->declared_at);
continue;
}
}
}
}
formal_arg_flag = false;
}
/* Work function called when searching for symbols that have argument lists
associated with them. */
static void
find_arglists (gfc_symbol *sym)
{
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
|| gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
return;
gfc_resolve_formal_arglist (sym);
}
/* Given a namespace, resolve all formal argument lists within the namespace.
*/
static void
resolve_formal_arglists (gfc_namespace *ns)
{
if (ns == NULL)
return;
gfc_traverse_ns (ns, find_arglists);
}
static void
resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
{
bool t;
if (sym && sym->attr.flavor == FL_PROCEDURE
&& sym->ns->parent
&& sym->ns->parent->proc_name
&& sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
&& !strcmp (sym->name, sym->ns->parent->proc_name->name))
gfc_error ("Contained procedure %qs at %L has the same name as its "
"encompassing procedure", sym->name, &sym->declared_at);
/* If this namespace is not a function or an entry master function,
ignore it. */
if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
|| sym->attr.entry_master)
return;
if (!sym->result)
return;
/* Try to find out of what the return type is. */
if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
{
t = gfc_set_default_type (sym->result, 0, ns);
if (!t && !sym->result->attr.untyped)
{
if (sym->result == sym)
gfc_error ("Contained function %qs at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
else if (!sym->result->attr.proc_pointer)
gfc_error ("Result %qs of contained function %qs at %L has "
"no IMPLICIT type", sym->result->name, sym->name,
&sym->result->declared_at);
sym->result->attr.untyped = 1;
}
}
/* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
type, lists the only ways a character length value of * can be used:
dummy arguments of procedures, named constants, function results and
in allocate statements if the allocate_object is an assumed length dummy
in external functions. Internal function results and results of module
procedures are not on this list, ergo, not permitted. */
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
if ((!cl || !cl->length) && !sym->result->ts.deferred)
{
/* See if this is a module-procedure and adapt error message
accordingly. */
bool module_proc;
gcc_assert (ns->parent && ns->parent->proc_name);
module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
gfc_error (module_proc
? G_("Character-valued module procedure %qs at %L"
" must not be assumed length")
: G_("Character-valued internal function %qs at %L"
" must not be assumed length"),
sym->name, &sym->declared_at);
}
}
}
/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
introduce duplicates. */
static void
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
gfc_formal_arglist *f, *new_arglist;
gfc_symbol *new_sym;
for (; new_args != NULL; new_args = new_args->next)
{
new_sym = new_args->sym;
/* See if this arg is already in the formal argument list. */
for (f = proc->formal; f; f = f->next)
{
if (new_sym == f->sym)
break;
}
if (f)
continue;
/* Add a new argument. Argument order is not important. */
new_arglist = gfc_get_formal_arglist ();
new_arglist->sym = new_sym;
new_arglist->next = proc->formal;
proc->formal = new_arglist;
}
}
/* Flag the arguments that are not present in all entries. */
static void
check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
gfc_formal_arglist *f, *head;
head = new_args;
for (f = proc->formal; f; f = f->next)
{
if (f->sym == NULL)
continue;
for (new_args = head; new_args; new_args = new_args->next)
{
if (new_args->sym == f->sym)
break;
}
if (new_args)
continue;
f->sym->attr.not_always_present = 1;
}
}
/* Resolve alternate entry points. If a symbol has multiple entry points we
create a new master symbol for the main routine, and turn the existing
symbol into an entry point. */
static void
resolve_entries (gfc_namespace *ns)
{
gfc_namespace *old_ns;
gfc_code *c;
gfc_symbol *proc;
gfc_entry_list *el;
char name[GFC_MAX_SYMBOL_LEN + 1];
static int master_count = 0;
if (ns->proc_name == NULL)
return;
/* No need to do anything if this procedure doesn't have alternate entry
points. */
if (!ns->entries)
return;
/* We may already have resolved alternate entry points. */
if (ns->proc_name->attr.entry_master)
return;
/* If this isn't a procedure something has gone horribly wrong. */
gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
/* Remember the current namespace. */
old_ns = gfc_current_ns;
gfc_current_ns = ns;
/* Add the main entry point to the list of entry points. */
el = gfc_get_entry_list ();
el->sym = ns->proc_name;
el->id = 0;
el->next = ns->entries;
ns->entries = el;
ns->proc_name->attr.entry = 1;
/* If it is a module function, it needs to be in the right namespace
so that gfc_get_fake_result_decl can gather up the results. The
need for this arose in get_proc_name, where these beasts were
left in their own namespace, to keep prior references linked to
the entry declaration.*/
if (ns->proc_name->attr.function
&& ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
el->sym->ns = ns;
/* Do the same for entries where the master is not a module
procedure. These are retained in the module namespace because
of the module procedure declaration. */
for (el = el->next; el; el = el->next)
if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
&& el->sym->attr.mod_proc)
el->sym->ns = ns;
el = ns->entries;
/* Add an entry statement for it. */
c = gfc_get_code (EXEC_ENTRY);
c->ext.entry = el;
c->next = ns->code;
ns->code = c;
/* Create a new symbol for the master function. */
/* Give the internal function a unique name (within this file).
Also include the function name so the user has some hope of figuring
out what is going on. */
snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
master_count++, ns->proc_name->name);
gfc_get_ha_symbol (name, &proc);
gcc_assert (proc != NULL);
gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
if (ns->proc_name->attr.subroutine)
gfc_add_subroutine (&proc->attr, proc->name, NULL);
else
{
gfc_symbol *sym;
gfc_typespec *ts, *fts;
gfc_array_spec *as, *fas;
gfc_add_function (&proc->attr, proc->name, NULL);
proc->result = proc;
fas = ns->entries->sym->as;
fas = fas ? fas : ns->entries->sym->result->as;
fts = &ns->entries->sym->result->ts;
if (fts->type == BT_UNKNOWN)
fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
for (el = ns->entries->next; el; el = el->next)
{
ts = &el->sym->result->ts;
as = el->sym->as;
as = as ? as : el->sym->result->as;
if (ts->type == BT_UNKNOWN)
ts = gfc_get_default_type (el->sym->result->name, NULL);
if (! gfc_compare_types (ts, fts)
|| (el->sym->result->attr.dimension
!= ns->entries->sym->result->attr.dimension)
|| (el->sym->result->attr.pointer
!= ns->entries->sym->result->attr.pointer))
break;
else if (as && fas && ns->entries->sym->result != el->sym->result
&& gfc_compare_array_spec (as, fas) == 0)
gfc_error ("Function %s at %L has entries with mismatched "
"array specifications", ns->entries->sym->name,
&ns->entries->sym->declared_at);
/* The characteristics need to match and thus both need to have
the same string length, i.e. both len=*, or both len=4.
Having both len=<variable> is also possible, but difficult to
check at compile time. */
else if (ts->type == BT_CHARACTER
&& (el->sym->result->attr.allocatable
!= ns->entries->sym->result->attr.allocatable))
{
gfc_error ("Function %s at %L has entry %s with mismatched "
"characteristics", ns->entries->sym->name,
&ns->entries->sym->declared_at, el->sym->name);
goto cleanup;
}
else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
&& (((ts->u.cl->length && !fts->u.cl->length)
||(!ts->u.cl->length && fts->u.cl->length))
|| (ts->u.cl->length
&& ts->u.cl->length->expr_type
!= fts->u.cl->length->expr_type)
|| (ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT
&& mpz_cmp (ts->u.cl->length->value.integer,
fts->u.cl->length->value.integer) != 0)))
gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
"entries returning variables of different "
"string lengths", ns->entries->sym->name,
&ns->entries->sym->declared_at);
}
if (el == NULL)
{
sym = ns->entries->sym->result;
/* All result types the same. */
proc->ts = *fts;
if (sym->attr.dimension)
gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
if (sym->attr.pointer)
gfc_add_pointer (&proc->attr, NULL);
}
else
{
/* Otherwise the result will be passed through a union by
reference. */
proc->attr.mixed_entry_master = 1;
for (el = ns->entries; el; el = el->next)
{
sym = el->sym->result;
if (sym->attr.dimension)
{
if (el == ns->entries)
gfc_error ("FUNCTION result %s cannot be an array in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
else
gfc_error ("ENTRY result %s cannot be an array in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
}
else if (sym->attr.pointer)
{
if (el == ns->entries)
gfc_error ("FUNCTION result %s cannot be a POINTER in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
else
gfc_error ("ENTRY result %s cannot be a POINTER in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
}
else
{
ts = &sym->ts;
if (ts->type == BT_UNKNOWN)
ts = gfc_get_default_type (sym->name, NULL);
switch (ts->type)
{
case BT_INTEGER:
if (ts->kind == gfc_default_integer_kind)
sym = NULL;
break;
case BT_REAL:
if (ts->kind == gfc_default_real_kind
|| ts->kind == gfc_default_double_kind)
sym = NULL;
break;
case BT_COMPLEX:
if (ts->kind == gfc_default_complex_kind)
sym = NULL;
break;
case BT_LOGICAL:
if (ts->kind == gfc_default_logical_kind)
sym = NULL;
break;
case BT_UNKNOWN:
/* We will issue error elsewhere. */
sym = NULL;
break;
default:
break;
}
if (sym)
{
if (el == ns->entries)
gfc_error ("FUNCTION result %s cannot be of type %s "
"in FUNCTION %s at %L", sym->name,
gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
else
gfc_error ("ENTRY result %s cannot be of type %s "
"in FUNCTION %s at %L", sym->name,
gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
}
}
}
}
}
cleanup:
proc->attr.access = ACCESS_PRIVATE;
proc->attr.entry_master = 1;
/* Merge all the entry point arguments. */
for (el = ns->entries; el; el = el->next)
merge_argument_lists (proc, el->sym->formal);
/* Check the master formal arguments for any that are not
present in all entry points. */
for (el = ns->entries; el; el = el->next)
check_argument_lists (proc, el->sym->formal);
/* Use the master function for the function body. */
ns->proc_name = proc;
/* Finalize the new symbols. */
gfc_commit_symbols ();
/* Restore the original namespace. */
gfc_current_ns = old_ns;
}
/* Resolve common variables. */
static void
resolve_common_vars (gfc_common_head *common_block, bool named_common)
{
gfc_symbol *csym = common_block->head;
gfc_gsymbol *gsym;
for (; csym; csym = csym->common_next)
{
gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
gfc_error_now ("Global entity %qs at %L cannot appear in a "
"COMMON block at %L", gsym->name,
&gsym->where, &csym->common_block->where);
/* gfc_add_in_common may have been called before, but the reported errors
have been ignored to continue parsing.
We do the checks again here. */
if (!csym->attr.use_assoc)
{
gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
&common_block->where);
}
if (csym->value || csym->attr.data)
{
if (!csym->ns->is_block_data)
gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
"but only in BLOCK DATA initialization is "
"allowed", csym->name, &csym->declared_at);
else if (!named_common)
gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
"in a blank COMMON but initialization is only "
"allowed in named common blocks", csym->name,
&csym->declared_at);
}
if (UNLIMITED_POLY (csym))
gfc_error_now ("%qs at %L cannot appear in COMMON "
"[F2008:C5100]", csym->name, &csym->declared_at);
if (csym->ts.type != BT_DERIVED)
continue;
if (!(csym->ts.u.derived->attr.sequence
|| csym->ts.u.derived->attr.is_bind_c))
gfc_error_now ("Derived type variable %qs in COMMON at %L "
"has neither the SEQUENCE nor the BIND(C) "
"attribute", csym->name, &csym->declared_at);
if (csym->ts.u.derived->attr.alloc_comp)
gfc_error_now ("Derived type variable %qs in COMMON at %L "
"has an ultimate component that is "
"allocatable", csym->name, &csym->declared_at);
if (gfc_has_default_initializer (csym->ts.u.derived))
gfc_error_now ("Derived type variable %qs in COMMON at %L "
"may not have default initializer", csym->name,
&csym->declared_at);
if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
}
}
/* Resolve common blocks. */
static void
resolve_common_blocks (gfc_symtree *common_root)
{
gfc_symbol *sym;
gfc_gsymbol * gsym;
if (common_root == NULL)
return;
if (common_root->left)
resolve_common_blocks (common_root->left);
if (common_root->right)
resolve_common_blocks (common_root->right);
resolve_common_vars (common_root->n.common, true);
/* The common name is a global name - in Fortran 2003 also if it has a
C binding name, since Fortran 2008 only the C binding name is a global
identifier. */
if (!common_root->n.common->binding_label
|| gfc_notification_std (GFC_STD_F2008))
{
gsym = gfc_find_gsymbol (gfc_gsym_root,
common_root->n.common->name);
if (gsym && gfc_notification_std (GFC_STD_F2008)
&& gsym->type == GSYM_COMMON
&& ((common_root->n.common->binding_label
&& (!gsym->binding_label
|| strcmp (common_root->n.common->binding_label,
gsym->binding_label) != 0))
|| (!common_root->n.common->binding_label
&& gsym->binding_label)))
{
gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
"identifier and must thus have the same binding name "
"as the same-named COMMON block at %L: %s vs %s",
common_root->n.common->name, &common_root->n.common->where,
&gsym->where,
common_root->n.common->binding_label
? common_root->n.common->binding_label : "(blank)",
gsym->binding_label ? gsym->binding_label : "(blank)");
return;
}
if (gsym && gsym->type != GSYM_COMMON
&& !common_root->n.common->binding_label)
{
gfc_error ("COMMON block %qs at %L uses the same global identifier "
"as entity at %L",
common_root->n.common->name, &common_root->n.common->where,
&gsym->where);
return;
}
if (gsym && gsym->type != GSYM_COMMON)
{
gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
"%L sharing the identifier with global non-COMMON-block "
"entity at %L", common_root->n.common->name,
&common_root->n.common->where, &gsym->where);
return;
}
if (!gsym)
{
gsym = gfc_get_gsymbol (common_root->n.common->name, false);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
}
gsym->used = 1;
}
if (common_root->n.common->binding_label)
{
gsym = gfc_find_gsymbol (gfc_gsym_root,
common_root->n.common->binding_label);
if (gsym && gsym->type != GSYM_COMMON)
{
gfc_error ("COMMON block at %L with binding label %qs uses the same "
"global identifier as entity at %L",
&common_root->n.common->where,
common_root->n.common->binding_label, &gsym->where);
return;
}
if (!gsym)
{
gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
}
gsym->used = 1;
}
gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
if (sym == NULL)
return;
if (sym->attr.flavor == FL_PARAMETER)
gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
sym->name, &common_root->n.common->where, &sym->declared_at);
if (sym->attr.external)
gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
sym->name, &common_root->n.common->where);
if (sym->attr.intrinsic)
gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
sym->name, &common_root->n.common->where);
else if (sym->attr.result
|| gfc_is_function_return_value (sym, gfc_current_ns))
gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
"that is also a function result", sym->name,
&common_root->n.common->where);
else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
&& sym->attr.proc != PROC_ST_FUNCTION)
gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
"that is also a global procedure", sym->name,
&common_root->n.common->where);
}
/* Resolve contained function types. Because contained functions can call one
another, they have to be worked out before any of the contained procedures
can be resolved.
The good news is that if a function doesn't already have a type, the only
way it can get one is through an IMPLICIT type or a RESULT variable, because
by definition contained functions are contained namespace they're contained
in, not in a sibling or parent namespace. */
static void
resolve_contained_functions (gfc_namespace *ns)
{
gfc_namespace *child;
gfc_entry_list *el;
resolve_formal_arglists (ns);
for (child = ns->contained; child; child = child->sibling)
{
/* Resolve alternate entry points first. */
resolve_entries (child);
/* Then check function return types. */
resolve_contained_fntype (child->proc_name, child);
for (el = child->entries; el; el = el->next)
resolve_contained_fntype (el->sym, child);
}
}
/* A Parameterized Derived Type constructor must contain values for
the PDT KIND parameters or they must have a default initializer.
Go through the constructor picking out the KIND expressions,
storing them in 'param_list' and then call gfc_get_pdt_instance
to obtain the PDT instance. */
static gfc_actual_arglist *param_list, *param_tail, *param;
static bool
get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
{
param = gfc_get_actual_arglist ();
if (!param_list)
param_list = param_tail = param;
else
{
param_tail->next = param;
param_tail = param_tail->next;
}
param_tail->name = c->name;
if (expr)
param_tail->expr = gfc_copy_expr (expr);
else if (c->initializer)
param_tail->expr = gfc_copy_expr (c->initializer);
else
{
param_tail->spec_type = SPEC_ASSUMED;
if (c->attr.pdt_kind)
{
gfc_error ("The KIND parameter %qs in the PDT constructor "
"at %C has no value", param->name);
return false;
}
}
return true;
}
static bool
get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
gfc_symbol *derived)
{
gfc_constructor *cons = NULL;
gfc_component *comp;
bool t = true;
if (expr && expr->expr_type == EXPR_STRUCTURE)
cons = gfc_constructor_first (expr->value.constructor);
else if (constr)
cons = *constr;
gcc_assert (cons);
comp = derived->components;
for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
if (cons->expr
&& cons->expr->expr_type == EXPR_STRUCTURE
&& comp->ts.type == BT_DERIVED)
{
t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
if (!t)
return t;
}
else if (comp->ts.type == BT_DERIVED)
{
t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
if (!t)
return t;
}
else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
&& derived->attr.pdt_template)
{
t = get_pdt_spec_expr (comp, cons->expr);
if (!t)
return t;
}
}
return t;
}
static bool resolve_fl_derived0 (gfc_symbol *sym);
static bool resolve_fl_struct (gfc_symbol *sym);
/* Resolve all of the elements of a structure constructor and make sure that
the types are correct. The 'init' flag indicates that the given
constructor is an initializer. */
static bool
resolve_structure_cons (gfc_expr *expr, int init)
{
gfc_constructor *cons;
gfc_component *comp;
bool t;
symbol_attribute a;
t = true;
if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
{
if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
resolve_fl_derived0 (expr->ts.u.derived);
else
resolve_fl_struct (expr->ts.u.derived);
/* If this is a Parameterized Derived Type template, find the
instance corresponding to the PDT kind parameters. */
if (expr->ts.u.derived->attr.pdt_template)
{
param_list = NULL;
t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
if (!t)
return t;
gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
expr->param_list = gfc_copy_actual_arglist (param_list);
if (param_list)
gfc_free_actual_arglist (param_list);
if (!expr->ts.u.derived->attr.pdt_type)
return false;
}
}
/* A constructor may have references if it is the result of substituting a
parameter variable. In this case we just pull out the component we
want. */
if (expr->ref)
comp = expr->ref->u.c.sym->components;
else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
|| expr->ts.type == BT_UNION)
&& expr->ts.u.derived)
comp = expr->ts.u.derived->components;
else
return false;
cons = gfc_constructor_first (expr->value.constructor);
for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
int rank;
if (!cons->expr)
continue;
/* Unions use an EXPR_NULL contrived expression to tell the translation
phase to generate an initializer of the appropriate length.
Ignore it here. */
if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
continue;
if (!gfc_resolve_expr (cons->expr))
{
t = false;
continue;
}
rank = comp->as ? comp->as->rank : 0;
if (comp->ts.type == BT_CLASS
&& !comp->ts.u.derived->attr.unlimited_polymorphic
&& CLASS_DATA (comp)->as)
rank = CLASS_DATA (comp)->as->rank;
if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
&& (comp->attr.allocatable || cons->expr->rank))
{
gfc_error ("The rank of the element in the structure "
"constructor at %L does not match that of the "
"component (%d/%d)", &cons->expr->where,
cons->expr->rank, rank);
t = false;
}
/* If we don't have the right type, try to convert it. */
if (!comp->attr.proc_pointer &&
!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
if (strcmp (comp->name, "_extends") == 0)
{
/* Can afford to be brutal with the _extends initializer.
The derived type can get lost because it is PRIVATE
but it is not usage constrained by the standard. */
cons->expr->ts = comp->ts;
}
else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
{
gfc_error ("The element in the structure constructor at %L, "
"for pointer component %qs, is %s but should be %s",
&cons->expr->where, comp->name,
gfc_basic_typename (cons->expr->ts.type),
gfc_basic_typename (comp->ts.type));
t = false;
}
else
{
bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
if (t)
t = t2;
}
}
/* For strings, the length of the constructor should be the same as
the one of the structure, ensure this if the lengths are known at
compile time and when we are dealing with PARAMETER or structure
constructors. */
if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
&& comp->ts.u.cl->length
&& comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
&& cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
&& cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
&& mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
comp->ts.u.cl->length->value.integer) != 0)
{
if (comp->attr.pointer)
{
HOST_WIDE_INT la, lb;
la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
"component %qs in constructor at %L",
la, lb, comp->name, &cons->expr->where);
t = false;
}
if (cons->expr->expr_type == EXPR_VARIABLE
&& cons->expr->rank != 0
&& cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
{
/* Wrap the parameter in an array constructor (EXPR_ARRAY)
to make use of the gfc_resolve_character_array_constructor
machinery. The expression is later simplified away to
an array of string literals. */
gfc_expr *para = cons->expr;
cons->expr = gfc_get_expr ();
cons->expr->ts = para->ts;
cons->expr->where = para->where;
cons->expr->expr_type = EXPR_ARRAY;
cons->expr->rank = para->rank;
cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
gfc_constructor_append_expr (&cons->expr->value.constructor,
para, &cons->expr->where);
}
if (cons->expr->expr_type == EXPR_ARRAY)
{
/* Rely on the cleanup of the namespace to deal correctly with
the old charlen. (There was a block here that attempted to
remove the charlen but broke the chain in so doing.) */
cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
cons->expr->ts.u.cl->length_from_typespec = true;
cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
gfc_resolve_character_array_constructor (cons->expr);
}
}
if (cons->expr->expr_type == EXPR_NULL
&& !(comp->attr.pointer || comp->attr.allocatable
|| comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
|| (comp->ts.type == BT_CLASS
&& (CLASS_DATA (comp)->attr.class_pointer
|| CLASS_DATA (comp)->attr.allocatable))))
{
t = false;
gfc_error ("The NULL in the structure constructor at %L is "
"being applied to component %qs, which is neither "
"a POINTER nor ALLOCATABLE", &cons->expr->where,
comp->name);
}
if (comp->attr.proc_pointer && comp->ts.interface)
{
/* Check procedure pointer interface. */
gfc_symbol *s2 = NULL;
gfc_component *c2;
const char *name;
char err[200];
c2 = gfc_get_proc_ptr_comp (cons->expr);
if (c2)
{
s2 = c2->ts.interface;
name = c2->name;
}
else if (cons->expr->expr_type == EXPR_FUNCTION)
{
s2 = cons->expr->symtree->n.sym->result;
name = cons->expr->symtree->n.sym->result->name;
}
else if (cons->expr->expr_type != EXPR_NULL)
{
s2 = cons->expr->symtree->n.sym;
name = cons->expr->symtree->n.sym->name;
}
if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
err, sizeof (err), NULL, NULL))
{
gfc_error_opt (0, "Interface mismatch for procedure-pointer "
"component %qs in structure constructor at %L:"
" %s", comp->name, &cons->expr->where, err);
return false;
}
}
/* Validate shape, except for dynamic or PDT arrays. */
if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
&& comp->as && !comp->attr.allocatable && !comp->attr.pointer
&& !comp->attr.pdt_array)
{
mpz_t len;
mpz_init (len);
for (int n = 0; n < rank; n++)
{
if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
|| comp->as->lower[n]->expr_type != EXPR_CONSTANT)
{
gfc_error ("Bad array spec of component %qs referenced in "
"structure constructor at %L",
comp->name, &cons->expr->where);
t = false;
break;
};
if (cons->expr->shape == NULL)
continue;
mpz_set_ui (len, 1);
mpz_add (len, len, comp->as->upper[n]->value.integer);
mpz_sub (len, len, comp->as->lower[n]->value.integer);
if (mpz_cmp (cons->expr->shape[n], len) != 0)
{
gfc_error ("The shape of component %qs in the structure "
"constructor at %L differs from the shape of the "
"declared component for dimension %d (%ld/%ld)",
comp->name, &cons->expr->where, n+1,
mpz_get_si (cons->expr->shape[n]),
mpz_get_si (len));
t = false;
}
}
mpz_clear (len);
}
if (!comp->attr.pointer || comp->attr.proc_pointer
|| cons->expr->expr_type == EXPR_NULL)
continue;
a = gfc_expr_attr (cons->expr);
if (!a.pointer && !a.target)
{
t = false;
gfc_error ("The element in the structure constructor at %L, "
"for pointer component %qs should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
if (init)
{
/* F08:C461. Additional checks for pointer initialization. */
if (a.allocatable)
{
t = false;
gfc_error ("Pointer initialization target at %L "
"must not be ALLOCATABLE", &cons->expr->where);
}
if (!a.save)
{
t = false;
gfc_error ("Pointer initialization target at %L "
"must have the SAVE attribute", &cons->expr->where);
}
}
/* F2003, C1272 (3). */
bool impure = cons->expr->expr_type == EXPR_VARIABLE
&& (gfc_impure_variable (cons->expr->symtree->n.sym)
|| gfc_is_coindexed (cons->expr));
if (impure && gfc_pure (NULL))
{
t = false;
gfc_error ("Invalid expression in the structure constructor for "
"pointer component %qs at %L in PURE procedure",
comp->name, &cons->expr->where);
}
if (impure)
gfc_unset_implicit_pure (NULL);
}
return t;
}
/****************** Expression name resolution ******************/
/* Returns 0 if a symbol was not declared with a type or
attribute declaration statement, nonzero otherwise. */
static int
was_declared (gfc_symbol *sym)
{
symbol_attribute a;
a = sym->attr;
if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
return 1;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target || a.volatile_
|| a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
|| a.asynchronous || a.codimension)
return 1;
return 0;
}
/* Determine if a symbol is generic or not. */
static int
generic_sym (gfc_symbol *sym)
{
gfc_symbol *s;
if (sym->attr.generic ||
(sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
return 1;
if (was_declared (sym) || sym->ns->parent == NULL)
return 0;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
if (s != NULL)
{
if (s == sym)
return 0;
else
return generic_sym (s);
}
return 0;
}
/* Determine if a symbol is specific or not. */
static int
specific_sym (gfc_symbol *sym)
{
gfc_symbol *s;
if (sym->attr.if_source == IFSRC_IFBODY
|| sym->attr.proc == PROC_MODULE
|| sym->attr.proc == PROC_INTERNAL
|| sym->attr.proc == PROC_ST_FUNCTION
|| (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
|| sym->attr.external)
return 1;
if (was_declared (sym) || sym->ns->parent == NULL)
return 0;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
return (s == NULL) ? 0 : specific_sym (s);
}
/* Figure out if the procedure is specific, generic or unknown. */
enum proc_type
{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
static proc_type
procedure_kind (gfc_symbol *sym)
{
if (generic_sym (sym))
return PTYPE_GENERIC;
if (specific_sym (sym))
return PTYPE_SPECIFIC;
return PTYPE_UNKNOWN;
}
/* Check references to assumed size arrays. The flag need_full_assumed_size
is nonzero when matching actual arguments. */
static int need_full_assumed_size = 0;
static bool
check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
{
if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
return false;
/* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
What should it be? */
if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
&& (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
&& (e->ref->u.ar.type == AR_FULL))
{
gfc_error ("The upper bound in the last dimension must "
"appear in the reference to the assumed size "
"array %qs at %L", sym->name, &e->where);
return true;
}
return false;
}
/* Look for bad assumed size array references in argument expressions
of elemental and array valued intrinsic procedures. Since this is
called from procedure resolution functions, it only recurses at
operators. */
static bool
resolve_assumed_size_actual (gfc_expr *e)
{
if (e == NULL)
return false;
switch (e->expr_type)
{
case EXPR_VARIABLE:
if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
return true;
break;
case EXPR_OP:
if (resolve_assumed_size_actual (e->value.op.op1)
|| resolve_assumed_size_actual (e->value.op.op2))
return true;
break;
default:
break;
}
return false;
}
/* Check a generic procedure, passed as an actual argument, to see if
there is a matching specific name. If none, it is an error, and if
more than one, the reference is ambiguous. */
static int
count_specific_procs (gfc_expr *e)
{
int n;
gfc_interface *p;
gfc_symbol *sym;
n = 0;
sym = e->symtree->n.sym;
for (p = sym->generic; p; p = p->next)
if (strcmp (sym->name, p->sym->name) == 0)
{
e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
sym->name);
n++;
}
if (n > 1)
gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
&e->where);
if (n == 0)
gfc_error ("GENERIC procedure %qs is not allowed as an actual "
"argument at %L", sym->name, &e->where);
return n;
}
/* See if a call to sym could possibly be a not allowed RECURSION because of
a missing RECURSIVE declaration. This means that either sym is the current
context itself, or sym is the parent of a contained procedure calling its
non-RECURSIVE containing procedure.
This also works if sym is an ENTRY. */
static bool
is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
{
gfc_symbol* proc_sym;
gfc_symbol* context_proc;
gfc_namespace* real_context;
if (sym->attr.flavor == FL_PROGRAM
|| gfc_fl_struct (sym->attr.flavor))
return false;
/* If we've got an ENTRY, find real procedure. */
if (sym->attr.entry && sym->ns->entries)
proc_sym = sym->ns->entries->sym;
else
proc_sym = sym;
/* If sym is RECURSIVE, all is well of course. */
if (proc_sym->attr.recursive || flag_recursive)
return false;
/* Find the context procedure's "real" symbol if it has entries.
We look for a procedure symbol, so recurse on the parents if we don't
find one (like in case of a BLOCK construct). */
for (real_context = context; ; real_context = real_context->parent)
{
/* We should find something, eventually! */
gcc_assert (real_context);
context_proc = (real_context->entries ? real_context->entries->sym
: real_context->proc_name);
/* In some special cases, there may not be a proc_name, like for this
invalid code:
real(bad_kind()) function foo () ...
when checking the call to bad_kind ().
In these cases, we simply return here and assume that the
call is ok. */
if (!context_proc)
return false;
if (context_proc->attr.flavor != FL_LABEL)
break;
}
/* A call from sym's body to itself is recursion, of course. */
if (context_proc == proc_sym)
return true;
/* The same is true if context is a contained procedure and sym the
containing one. */
if (context_proc->attr.contained)
{
gfc_symbol* parent_proc;
gcc_assert (context->parent);
parent_proc = (context->parent->entries ? context->parent->entries->sym
: context->parent->proc_name);
if (parent_proc == proc_sym)
return true;
}
return false;
}
/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
its typespec and formal argument list. */
bool
gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
{
gfc_intrinsic_sym* isym = NULL;
const char* symstd;
if (sym->resolve_symbol_called >= 2)
return true;
sym->resolve_symbol_called = 2;
/* Already resolved. */
if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
return true;
/* We already know this one is an intrinsic, so we don't call
gfc_is_intrinsic for full checking but rather use gfc_find_function and
gfc_find_subroutine directly to check whether it is a function or
subroutine. */
if (sym->intmod_sym_id && sym->attr.subroutine)
{
gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
isym = gfc_intrinsic_subroutine_by_id (id);
}
else if (sym->intmod_sym_id)
{
gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
isym = gfc_intrinsic_function_by_id (id);
}
else if (!sym->attr.subroutine)
isym = gfc_find_function (sym->name);
if (isym && !sym->attr.subroutine)
{
if (sym->ts.type != BT_UNKNOWN && warn_surprising
&& !sym->attr.implicit_type)
gfc_warning (OPT_Wsurprising,
"Type specified for intrinsic function %qs at %L is"
" ignored", sym->name, &sym->declared_at);
if (!sym->attr.function &&
!gfc_add_function(&sym->attr, sym->name, loc))
return false;
sym->ts = isym->ts;
}
else if (isym || (isym = gfc_find_subroutine (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
{
gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
" specifier", sym->name, &sym->declared_at);
return false;
}
if (!sym->attr.subroutine &&
!gfc_add_subroutine(&sym->attr, sym->name, loc))
return false;
}
else
{
gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
&sym->declared_at);
return false;
}
gfc_copy_formal_args_intr (sym, isym, NULL);
sym->attr.pure = isym->pure;
sym->attr.elemental = isym->elemental;
/* Check it is actually available in the standard settings. */
if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
{
gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
"available in the current standard settings but %s. Use "
"an appropriate %<-std=*%> option or enable "
"%<-fall-intrinsics%> in order to use it.",
sym->name, &sym->declared_at, symstd);
return false;
}
return true;
}
/* Resolve a procedure expression, like passing it to a called procedure or as
RHS for a procedure pointer assignment. */
static bool
resolve_procedure_expression (gfc_expr* expr)
{
gfc_symbol* sym;
if (expr->expr_type != EXPR_VARIABLE)
return true;
gcc_assert (expr->symtree);
sym = expr->symtree->n.sym;
if (sym->attr.intrinsic)
gfc_resolve_intrinsic (sym, &expr->where);
if (sym->attr.flavor != FL_PROCEDURE
|| (sym->attr.function && sym->result == sym))
return true;
/* A non-RECURSIVE procedure that is used as procedure expression within its
own body is in danger of being called recursively. */
if (is_illegal_recursion (sym, gfc_current_ns))
gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
" itself recursively. Declare it RECURSIVE or use"
" %<-frecursive%>", sym->name, &expr->where);
return true;
}
/* Check that name is not a derived type. */
static bool
is_dt_name (const char *name)
{
gfc_symbol *dt_list, *dt_first;
dt_list = dt_first = gfc_derived_types;
for (; dt_list; dt_list = dt_list->dt_next)
{
if (strcmp(dt_list->name, name) == 0)
return true;
if (dt_first == dt_list->dt_next)
break;
}
return false;
}
/* Resolve an actual argument list. Most of the time, this is just
resolving the expressions in the list.
The exception is that we sometimes have to decide whether arguments
that look like procedure arguments are really simple variable
references. */
static bool
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
bool no_formal_args)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
gfc_expr *e;
gfc_component *comp;
int save_need_full_assumed_size;
bool return_value = false;
bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
actual_arg = true;
first_actual_arg = true;
for (; arg; arg = arg->next)
{
e = arg->expr;
if (e == NULL)
{
/* Check the label is a valid branching target. */
if (arg->label)
{
if (arg->label->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("Label %d referenced at %L is never defined",
arg->label->value, &arg->label->where);
goto cleanup;
}
}
first_actual_arg = false;
continue;
}
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.generic
&& no_formal_args
&& count_specific_procs (e) != 1)
goto cleanup;
if (e->ts.type != BT_PROCEDURE)
{
save_need_full_assumed_size = need_full_assumed_size;
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (!gfc_resolve_expr (e))
goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
goto argument_list;
}
/* See if the expression node should really be a variable reference. */
sym = e->symtree->n.sym;
if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
{
gfc_error ("Derived type %qs is used as an actual "
"argument at %L", sym->name, &e->where);
goto cleanup;
}
if (sym->attr.flavor == FL_PROCEDURE
|| sym->attr.intrinsic
|| sym->attr.external)
{
int actual_ok;
/* If a procedure is not already determined to be something else
check if it is intrinsic. */
if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Statement function %qs at %L is not allowed as an "
"actual argument", sym->name, &e->where);
}
actual_ok = gfc_intrinsic_actual_ok (sym->name,
sym->attr.subroutine);
if (sym->attr.intrinsic && actual_ok == 0)
{
gfc_error ("Intrinsic %qs at %L is not allowed as an "
"actual argument", sym->name, &e->where);
}
if (sym->attr.contained && !sym->attr.use_assoc
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
{
if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
" used as actual argument at %L",
sym->name, &e->where))
goto cleanup;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
{
gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
"allowed as an actual argument at %L", sym->name,
&e->where);
}
/* Check if a generic interface has a specific procedure
with the same name before emitting an error. */
if (sym->attr.generic && count_specific_procs (e) != 1)
goto cleanup;
/* Just in case a specific was found for the expression. */
sym = e->symtree->n.sym;
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
if (gfc_is_function_return_value (sym, sym->ns))
goto got_variable;
/* If all else fails, see if we have a specific intrinsic. */
if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
isym = gfc_find_function (sym->name);
if (isym == NULL || !isym->specific)
{
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference %qs at %L", sym->name,
&e->where);
goto cleanup;
}
sym->ts = isym->ts;
sym->attr.intrinsic = 1;
sym->attr.function = 1;
}
if (!gfc_resolve_expr (e))
goto cleanup;
goto argument_list;
}
/* See if the name is a module procedure in a parent unit. */
if (was_declared (sym) || sym->ns->parent == NULL)
goto got_variable;
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
goto cleanup;
}
if (parent_st == NULL)
goto got_variable;
sym = parent_st->n.sym;
e->symtree = parent_st; /* Point to the right thing. */
if (sym->attr.flavor == FL_PROCEDURE
|| sym->attr.intrinsic
|| sym->attr.external)
{
if (!gfc_resolve_expr (e))
goto cleanup;
goto argument_list;
}
got_variable:
e->expr_type = EXPR_VARIABLE;
e->ts = sym->ts;
if ((sym->as != NULL && sym->ts.type != BT_CLASS)
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
&& CLASS_DATA (sym)->as))
{
e->rank = sym->ts.type == BT_CLASS
? CLASS_DATA (sym)->as->rank : sym->as->rank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
e->ref->u.ar.as = sym->ts.type == BT_CLASS
? CLASS_DATA (sym)->as : sym->as;
}
/* Expressions are assigned a default ts.type of BT_PROCEDURE in
primary.cc (match_actual_arg). If above code determines that it
is a variable instead, it needs to be resolved as it was not
done at the beginning of this function. */
save_need_full_assumed_size = need_full_assumed_size;
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (!gfc_resolve_expr (e))
goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
argument_list:
/* Check argument list functions %VAL, %LOC and %REF. There is
nothing to do for %REF. */
if (arg->name && arg->name[0] == '%')
{
if (strcmp ("%VAL", arg->name) == 0)
{
if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
{
gfc_error ("By-value argument at %L is not of numeric "
"type", &e->where);
goto cleanup;
}
if (e->rank)
{
gfc_error ("By-value argument at %L cannot be an array or "
"an array section", &e->where);
goto cleanup;
}
/* Intrinsics are still PROC_UNKNOWN here. However,
since same file external procedures are not resolvable
in gfortran, it is a good deal easier to leave them to
intrinsic.cc. */
if (ptype != PROC_UNKNOWN
&& ptype != PROC_DUMMY
&& ptype != PROC_EXTERNAL
&& ptype != PROC_MODULE)
{
gfc_error ("By-value argument at %L is not allowed "
"in this context", &e->where);
goto cleanup;
}
}
/* Statement functions have already been excluded above. */
else if (strcmp ("%LOC", arg->name) == 0
&& e->ts.type == BT_PROCEDURE)
{
if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
{
gfc_error ("Passing internal procedure at %L by location "
"not allowed", &e->where);
goto cleanup;
}
}
}
comp = gfc_get_proc_ptr_comp(e);
if (e->expr_type == EXPR_VARIABLE
&& comp && comp->attr.elemental)
{
gfc_error ("ELEMENTAL procedure pointer component %qs is not "
"allowed as an actual argument at %L", comp->name,
&e->where);
}
/* Fortran 2008, C1237. */
if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
&& gfc_has_ultimate_pointer (e))
{
gfc_error ("Coindexed actual argument at %L with ultimate pointer "
"component", &e->where);
goto cleanup;
}
first_actual_arg = false;
}
return_value = true;
cleanup:
actual_arg = actual_arg_sav;
first_actual_arg = first_actual_arg_sav;
return return_value;
}
/* Do the checks of the actual argument list that are specific to elemental
procedures. If called with c == NULL, we have a function, otherwise if
expr == NULL, we have a subroutine. */
static bool
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
gfc_actual_arglist *arg0;
gfc_actual_arglist *arg;
gfc_symbol *esym = NULL;
gfc_intrinsic_sym *isym = NULL;
gfc_expr *e = NULL;
gfc_intrinsic_arg *iformal = NULL;
gfc_formal_arglist *eformal = NULL;
bool formal_optional = false;
bool set_by_optional = false;
int i;
int rank = 0;
/* Is this an elemental procedure? */
if (expr && expr->value.function.actual != NULL)
{
if (expr->value.function.esym != NULL
&& expr->value.function.esym->attr.elemental)
{
arg0 = expr->value.function.actual;
esym = expr->value.function.esym;
}
else if (expr->value.function.isym != NULL
&& expr->value.function.isym->elemental)
{
arg0 = expr->value.function.actual;
isym = expr->value.function.isym;
}
else
return true;
}
else if (c && c->ext.actual != NULL)
{
arg0 = c->ext.actual;
if (c->resolved_sym)
esym = c->resolved_sym;
else
esym = c->symtree->n.sym;
gcc_assert (esym);
if (!esym->attr.elemental)
return true;
}
else
return true;
/* The rank of an elemental is the rank of its array argument(s). */
for (arg = arg0; arg; arg = arg->next)
{
if (arg->expr != NULL && arg->expr->rank != 0)
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->symtree->n.sym->attr.optional)
set_by_optional = true;
/* Function specific; set the result rank and shape. */
if (expr)
{
expr->rank = rank;
if (!expr->shape && arg->expr->shape)
{
expr->shape = gfc_get_shape (rank);
for (i = 0; i < rank; i++)
mpz_init_set (expr->shape[i], arg->expr->shape[i]);
}
}
break;
}
}
/* If it is an array, it shall not be supplied as an actual argument
to an elemental procedure unless an array of the same rank is supplied
as an actual argument corresponding to a nonoptional dummy argument of
that elemental procedure(12.4.1.5). */
formal_optional = false;
if (isym)
iformal = isym->formal;
else
eformal = esym->formal;
for (arg = arg0; arg; arg = arg->next)
{
if (eformal)
{
if (eformal->sym && eformal->sym->attr.optional)
formal_optional = true;
eformal = eformal->next;
}
else if (isym && iformal)
{
if (iformal->optional)
formal_optional = true;
iformal = iformal->next;
}
else if (isym)
formal_optional = true;
if (pedantic && arg->expr != NULL
&& arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->symtree->n.sym->attr.optional
&& formal_optional
&& arg->expr->rank
&& (set_by_optional || arg->expr->rank != rank)
&& !(isym && isym->id == GFC_ISYM_CONVERSION))
{
bool t = false;
gfc_actual_arglist *a;
/* Scan the argument list for a non-optional argument with the
same rank as arg. */
for (a = arg0; a; a = a->next)
if (a != arg
&& a->expr->rank == arg->expr->rank
&& !a->expr->symtree->n.sym->attr.optional)
{
t = true;
break;
}
if (!t)
gfc_warning (OPT_Wpedantic,
"%qs at %L is an array and OPTIONAL; If it is not "
"present, then it cannot be the actual argument of "
"an ELEMENTAL procedure unless there is a non-optional"
" argument with the same rank "
"(Fortran 2018, 15.5.2.12)",
arg->expr->symtree->n.sym->name, &arg->expr->where);
}
}
for (arg = arg0; arg; arg = arg->next)
{
if (arg->expr == NULL || arg->expr->rank == 0)
continue;
/* Being elemental, the last upper bound of an assumed size array
argument must be present. */
if (resolve_assumed_size_actual (arg->expr))
return false;
/* Elemental procedure's array actual arguments must conform. */
if (e != NULL)
{
if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
return false;
}
else
e = arg->expr;
}
/* INTENT(OUT) is only allowed for subroutines; if any actual argument
is an array, the intent inout/out variable needs to be also an array. */
if (rank > 0 && esym && expr == NULL)
for (eformal = esym->formal, arg = arg0; arg && eformal;
arg = arg->next, eformal = eformal->next)
if (eformal->sym
&& (eformal->sym->attr.intent == INTENT_OUT
|| eformal->sym->attr.intent == INTENT_INOUT)
&& arg->expr && arg->expr->rank == 0)
{
gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
"ELEMENTAL subroutine %qs is a scalar, but another "
"actual argument is an array", &arg->expr->where,
(eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
: "INOUT", eformal->sym->name, esym->name);
return false;
}
return true;
}
/* This function does the checking of references to global procedures
as defined in sections 18.1 and 14.1, respectively, of the Fortran
77 and 95 standards. It checks for a gsymbol for the name, making
one if it does not already exist. If it already exists, then the
reference being resolved must correspond to the type of gsymbol.
Otherwise, the new symbol is equipped with the attributes of the
reference. The corresponding code that is called in creating
global entities is parse.cc.
In addition, for all but -std=legacy, the gsymbols are used to
check the interfaces of external procedures from the same file.
The namespace of the gsymbol is resolved and then, once this is
done the interface is checked. */
static bool
not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
{
if (!gsym_ns->proc_name->attr.recursive)
return true;
if (sym->ns == gsym_ns)
return false;
if (sym->ns->parent && sym->ns->parent == gsym_ns)
return false;
return true;
}
static bool
not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
{
if (gsym_ns->entries)
{
gfc_entry_list *entry = gsym_ns->entries;
for (; entry; entry = entry->next)
{
if (strcmp (sym->name, entry->sym->name) == 0)
{
if (strcmp (gsym_ns->proc_name->name,
sym->ns->proc_name->name) == 0)
return false;
if (sym->ns->parent
&& strcmp (gsym_ns->proc_name->name,
sym->ns->parent->proc_name->name) == 0)
return false;
}
}
}
return true;
}
/* Check for the requirement of an explicit interface. F08:12.4.2.2. */
bool
gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
{
gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
for ( ; arg; arg = arg->next)
{
if (!arg->sym)
continue;
if (arg->sym->attr.allocatable) /* (2a) */
{
strncpy (errmsg, _("allocatable argument"), err_len);
return true;
}
else if (arg->sym->attr.asynchronous)
{
strncpy (errmsg, _("asynchronous argument"), err_len);
return true;
}
else if (arg->sym->attr.optional)
{
strncpy (errmsg, _("optional argument"), err_len);
return true;
}
else if (arg->sym->attr.pointer)
{
strncpy (errmsg, _("pointer argument"), err_len);
return true;
}
else if (arg->sym->attr.target)
{
strncpy (errmsg, _("target argument"), err_len);
return true;
}
else if (arg->sym->attr.value)
{
strncpy (errmsg, _("value argument"), err_len);
return true;
}
else if (arg->sym->attr.volatile_)
{
strncpy (errmsg, _("volatile argument"), err_len);
return true;
}
else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
{
strncpy (errmsg, _("assumed-shape argument"), err_len);
return true;
}
else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
{
strncpy (errmsg, _("assumed-rank argument"), err_len);
return true;
}
else if (arg->sym->attr.codimension) /* (2c) */
{
strncpy (errmsg, _("coarray argument"), err_len);
return true;
}
else if (false) /* (2d) TODO: parametrized derived type */
{
strncpy (errmsg, _("parametrized derived type argument"), err_len);
return true;
}
else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
{
strncpy (errmsg, _("polymorphic argument"), err_len);
return true;
}
else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
{
strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
return true;
}
else if (arg->sym->ts.type == BT_ASSUMED)
{
/* As assumed-type is unlimited polymorphic (cf. above).
See also TS 29113, Note 6.1. */
strncpy (errmsg, _("assumed-type argument"), err_len);
return true;
}
}
if (sym->attr.function)
{
gfc_symbol *res = sym->result ? sym->result : sym;
if (res->attr.dimension) /* (3a) */
{
strncpy (errmsg, _("array result"), err_len);
return true;
}
else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
{
strncpy (errmsg, _("pointer or allocatable result"), err_len);
return true;
}
else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
&& res->ts.u.cl->length
&& res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
{
strncpy (errmsg, _("result with non-constant character length"), err_len);
return true;
}
}
if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
{
strncpy (errmsg, _("elemental procedure"), err_len);
return true;
}
else if (sym->attr.is_bind_c) /* (5) */
{
strncpy (errmsg, _("bind(c) procedure"), err_len);
return true;
}
return false;
}
static void
resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
{
gfc_gsymbol * gsym;
gfc_namespace *ns;
enum gfc_symbol_type type;
char reason[200];
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
sym->binding_label != NULL);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
gfc_global_used (gsym, where);
if ((sym->attr.if_source == IFSRC_UNKNOWN
|| sym->attr.if_source == IFSRC_IFBODY)
&& gsym->type != GSYM_UNKNOWN
&& !gsym->binding_label
&& gsym->ns
&& gsym->ns->proc_name
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
gfc_symbol *def_sym;
def_sym = gsym->ns->proc_name;
if (gsym->ns->resolved != -1)
{
/* Resolve the gsymbol namespace if needed. */
if (!gsym->ns->resolved)
{
gfc_symbol *old_dt_list;
/* Stash away derived types so that the backend_decls
do not get mixed up. */
old_dt_list = gfc_derived_types;
gfc_derived_types = NULL;
gfc_resolve (gsym->ns);
/* Store the new derived types with the global namespace. */
if (gfc_derived_types)
gsym->ns->derived_types = gfc_derived_types;
/* Restore the derived types of this namespace. */
gfc_derived_types = old_dt_list;
}
/* Make sure that translation for the gsymbol occurs before
the procedure currently being resolved. */
ns = gfc_global_ns_list;
for (; ns && ns != gsym->ns; ns = ns->sibling)
{
if (ns->sibling == gsym->ns)
{
ns->sibling = gsym->ns->sibling;
gsym->ns->sibling = gfc_global_ns_list;
gfc_global_ns_list = gsym->ns;
break;
}
}
/* This can happen if a binding name has been specified. */
if (gsym->binding_label && gsym->sym_name != def_sym->name)
gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
if (def_sym->attr.entry_master || def_sym->attr.entry)
{
gfc_entry_list *entry;
for (entry = gsym->ns->entries; entry; entry = entry->next)
if (strcmp (entry->sym->name, sym->name) == 0)
{
def_sym = entry->sym;
break;
}
}
}
if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
{
gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
gfc_typename (&def_sym->ts));
goto done;
}
if (sym->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
{
gfc_error ("Explicit interface required for %qs at %L: %s",
sym->name, &sym->declared_at, reason);
goto done;
}
bool bad_result_characteristics;
if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
reason, sizeof(reason), NULL, NULL,
&bad_result_characteristics))
{
/* Turn erros into warnings with -std=gnu and -std=legacy,
unless a function returns a wrong type, which can lead
to all kinds of ICEs and wrong code. */
if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
&& !bad_result_characteristics)
gfc_errors_to_warnings (true);
gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
sym->name, &sym->declared_at, reason);
sym->error = 1;
gfc_errors_to_warnings (false);
goto done;
}
}
done:
if (gsym->type == GSYM_UNKNOWN)
{
gsym->type = type;
gsym->where = *where;
}
gsym->used = 1;
}
/************* Function resolution *************/
/* Resolve a function call known to be generic.
Section 14.1.2.4.1. */
static match
resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
{
gfc_symbol *s;
if (sym->attr.generic)
{
s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
if (s != NULL)
{
expr->value.function.name = s->name;
expr->value.function.esym = s;
if (s->ts.type != BT_UNKNOWN)
expr->ts = s->ts;
else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
expr->ts = s->result->ts;
if (s->as != NULL)
expr->rank = s->as->rank;
else if (s->result != NULL && s->result->as != NULL)
expr->rank = s->result->as->rank;
gfc_set_sym_referenced (expr->value.function.esym);
return MATCH_YES;
}
/* TODO: Need to search for elemental references in generic
interface. */
}
if (sym->attr.intrinsic)
return gfc_intrinsic_func_interface (expr, 0);
return MATCH_NO;
}
static bool
resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
gfc_interface *intr = NULL;
sym = expr->symtree->n.sym;
for (;;)
{
m = resolve_generic_f0 (expr, sym);
if (m == MATCH_YES)
return true;
else if (m == MATCH_ERROR)
return false;
generic:
if (!intr)
for (intr = sym->generic; intr; intr = intr->next)
if (gfc_fl_struct (intr->sym->attr.flavor))
break;
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
if (sym == NULL)
break;
if (!generic_sym (sym))
goto generic;
}
/* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */
if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
{
if (gfc_init_expr_flag)
gfc_error ("Function %qs in initialization expression at %L "
"must be an intrinsic function",
expr->symtree->n.sym->name, &expr->where);
else
gfc_error ("There is no specific function for the generic %qs "
"at %L", expr->symtree->n.sym->name, &expr->where);
return false;
}
if (intr)
{
if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
NULL, false))
return false;
if (!gfc_use_derived (expr->ts.u.derived))
return false;
return resolve_structure_cons (expr, 0);
}
m = gfc_intrinsic_func_interface (expr, 0);
if (m == MATCH_YES)
return true;
if (m == MATCH_NO)
gfc_error ("Generic function %qs at %L is not consistent with a "
"specific intrinsic interface", expr->symtree->n.sym->name,
&expr->where);
return false;
}
/* Resolve a function call known to be specific. */
static match
resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
{
match m;
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
{
sym->attr.proc = PROC_DUMMY;
goto found;
}
sym->attr.proc = PROC_EXTERNAL;
goto found;
}
if (sym->attr.proc == PROC_MODULE
|| sym->attr.proc == PROC_ST_FUNCTION
|| sym->attr.proc == PROC_INTERNAL)
goto found;
if (sym->attr.intrinsic)
{
m = gfc_intrinsic_func_interface (expr, 1);
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
"with an intrinsic", sym->name, &expr->where);
return MATCH_ERROR;
}
return MATCH_NO;
found:
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
if (sym->result)
expr->ts = sym->result->ts;
else
expr->ts = sym->ts;
expr->value.function.name = sym->name;
expr->value.function.esym = sym;
/* Prevent crash when sym->ts.u.derived->components is not set due to previous
error(s). */
if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
return MATCH_ERROR;
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
expr->rank = CLASS_DATA (sym)->as->rank;
else if (sym->as != NULL)
expr->rank = sym->as->rank;
return MATCH_YES;
}
static bool
resolve_specific_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
sym = expr->symtree->n.sym;
for (;;)
{
m = resolve_specific_f0 (sym, expr);
if (m == MATCH_YES)
return true;
if (m == MATCH_ERROR)
return false;
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
if (sym == NULL)
break;
}
gfc_error ("Unable to resolve the specific function %qs at %L",
expr->symtree->n.sym->name, &expr->where);
return true;
}
/* Recursively append candidate SYM to CANDIDATES. Store the number of
candidates in CANDIDATES_LEN. */
static void
lookup_function_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->attr.external)
&& sym->n.sym->attr.flavor == FL_PROCEDURE)
vec_push (candidates, candidates_len, sym->name);
p = sym->left;
if (p)
lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
p = sym->right;