blob: 2f5d1fe780ea8cfaa514544597187895ad3126fd [file] [log] [blame]
/* Perform type resolution on the various structures.
Copyright (C) 2001-2013 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 "flags.h"
#include "gfortran.h"
#include "obstack.h"
#include "bitmap.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. */
typedef enum seq_type
{
SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
}
seq_type;
/* Stack to keep track of the nesting of blocks as we move through the
code. See resolve_branch() and 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;
static int 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;
/* Nonzero if we are processing a formal arglist. The corresponding function
resets the flag each time that it is read. */
static int formal_arg_flag = 0;
/* 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;
int
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 gfc_try
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 ("'%s' at %L is of the ABSTRACT type '%s'",
name, where, ts->u.derived->name);
else
gfc_error ("ABSTRACT type '%s' used at %L",
ts->u.derived->name, where);
}
return FAILURE;
}
return SUCCESS;
}
static gfc_try
check_proc_interface (gfc_symbol *ifc, locus *where)
{
/* Several checks for F08:C1216. */
if (ifc->attr.procedure)
{
gfc_error ("Interface '%s' at %L is declared "
"in a later PROCEDURE statement", ifc->name, where);
return FAILURE;
}
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 '%s' at %L may not be generic",
ifc->name, where);
return FAILURE;
}
}
if (ifc->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Interface '%s' at %L may not be a statement function",
ifc->name, where);
return FAILURE;
}
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 '%s' not allowed in "
"PROCEDURE statement at %L", ifc->name, where);
return FAILURE;
}
if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
{
gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where);
return FAILURE;
}
return SUCCESS;
}
static void resolve_symbol (gfc_symbol *sym);
/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
static gfc_try
resolve_procedure_interface (gfc_symbol *sym)
{
gfc_symbol *ifc = sym->ts.interface;
if (!ifc)
return SUCCESS;
if (ifc == sym)
{
gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
sym->name, &sym->declared_at);
return FAILURE;
}
if (check_proc_interface (ifc, &sym->declared_at) == FAILURE)
return FAILURE;
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->result = sym;
}
else
sym->ts = ifc->ts;
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
sym->attr.subroutine = ifc->attr.subroutine;
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
sym->attr.pure = ifc->attr.pure;
sym->attr.elemental = ifc->attr.elemental;
sym->attr.dimension = ifc->attr.dimension;
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;
sym->attr.class_ok = ifc->attr.class_ok;
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
/* 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) == FAILURE)
return FAILURE;
}
}
return SUCCESS;
}
/* 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. */
static void
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 = 1;
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 "
"'%s' at %L is not allowed", proc->name,
&proc->declared_at);
if (proc->attr.function)
gfc_error ("Alternate return specifier in function "
"'%s' 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) == FAILURE)
return;
if (sym->attr.if_source != IFSRC_UNKNOWN)
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 '%s' 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 '%s'"
" of pure function '%s' at %L with VALUE "
"attribute but without INTENT(IN)",
sym->name, proc->name, &sym->declared_at);
else
gfc_error ("Argument '%s' of pure function '%s' 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 '%s'"
" of pure subroutine '%s' at %L with VALUE "
"attribute but without INTENT", sym->name,
proc->name, &sym->declared_at);
else
gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
"must have its INTENT specified or have the "
"VALUE attribute", sym->name, proc->name,
&sym->declared_at);
}
}
}
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 '%s' 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 '%s' 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 '%s' 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 '%s' 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 '%s' not allowed in elemental "
"procedure '%s' 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 '%s' of elemental procedure '%s' 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)
{
gfc_error ("Argument '%s' of statement function at %L must "
"be scalar", sym->name, &sym->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 '%s' of statement "
"function at %L must have constant length",
sym->name, &sym->declared_at);
continue;
}
}
}
}
formal_arg_flag = 0;
}
/* 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
|| sym->attr.flavor == FL_DERIVED)
return;
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)
{
gfc_try t;
/* 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;
/* 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 == FAILURE && !sym->result->attr.untyped)
{
if (sym->result == sym)
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
else if (!sym->result->attr.proc_pointer)
gfc_error ("Result '%s' of contained function '%s' at %L has "
"no IMPLICIT type", sym->result->name, sym->name,
&sym->result->declared_at);
sym->result->attr.untyped = 1;
}
}
/* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
type, lists the only ways a character length value of * can be used:
dummy arguments of procedures, named constants, and function results
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 ("Character-valued %s '%s' at %L must not be"
" assumed length",
module_proc ? _("module procedure")
: _("internal function"),
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 ();
c->op = 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 && 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 can't be an array in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
else
gfc_error ("ENTRY result %s can't 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 can't be a POINTER in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
else
gfc_error ("ENTRY result %s can't 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 can't 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 can't be of type %s "
"in FUNCTION %s at %L", sym->name,
gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
}
}
}
}
}
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_symbol *sym, bool named_common)
{
gfc_symbol *csym = sym;
for (; csym; csym = csym->common_next)
{
if (csym->value || csym->attr.data)
{
if (!csym->ns->is_block_data)
gfc_notify_std (GFC_STD_GNU, "Variable '%s' 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 '%s' 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 ("'%s' in cannot appear in COMMON at %L "
"[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 '%s' 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 '%s' 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 '%s' 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;
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->head, true);
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 '%s' 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 '%s' at %L can not have the EXTERNAL attribute",
sym->name, &common_root->n.common->where);
if (sym->attr.intrinsic)
gfc_error ("COMMON block '%s' 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 '%s' 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 '%s' 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);
}
}
static gfc_try resolve_fl_derived0 (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 gfc_try
resolve_structure_cons (gfc_expr *expr, int init)
{
gfc_constructor *cons;
gfc_component *comp;
gfc_try t;
symbol_attribute a;
t = SUCCESS;
if (expr->ts.type == BT_DERIVED)
resolve_fl_derived0 (expr->ts.u.derived);
cons = gfc_constructor_first (expr->value.constructor);
/* See if the user is trying to invoke a structure constructor for one of
the iso_c_binding derived types. */
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
&& expr->ts.u.derived->ts.is_iso_c && cons
&& (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
{
gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
expr->ts.u.derived->name, &(expr->where));
return FAILURE;
}
/* Return if structure constructor is c_null_(fun)prt. */
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
&& expr->ts.u.derived->ts.is_iso_c && cons
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
return SUCCESS;
/* 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
comp = expr->ts.u.derived->components;
for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
int rank;
if (!cons->expr)
continue;
if (gfc_resolve_expr (cons->expr) == FAILURE)
{
t = FAILURE;
continue;
}
rank = comp->as ? comp->as->rank : 0;
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 = FAILURE;
}
/* 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 '%s', 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 = FAILURE;
}
else
{
gfc_try t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
if (t != FAILURE)
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
&& cons->expr->rank != 0
&& mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
comp->ts.u.cl->length->value.integer) != 0)
{
if (cons->expr->expr_type == EXPR_VARIABLE
&& 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)
{
gfc_constructor *p;
p = gfc_constructor_first (cons->expr->value.constructor);
if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
{
gfc_charlen *cl, *cl2;
cl2 = NULL;
for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
{
if (cl == cons->expr->ts.u.cl)
break;
cl2 = cl;
}
gcc_assert (cl);
if (cl2)
cl2->next = cl->next;
gfc_free_expr (cl->length);
free (cl);
}
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.type == BT_CLASS
&& (CLASS_DATA (comp)->attr.class_pointer
|| CLASS_DATA (comp)->attr.allocatable))))
{
t = FAILURE;
gfc_error ("The NULL in the structure constructor at %L is "
"being applied to component '%s', 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 ("Interface mismatch for procedure-pointer component "
"'%s' in structure constructor at %L: %s",
comp->name, &cons->expr->where, err);
return FAILURE;
}
}
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 = FAILURE;
gfc_error ("The element in the structure constructor at %L, "
"for pointer component '%s' 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 = FAILURE;
gfc_error ("Pointer initialization target at %L "
"must not be ALLOCATABLE ", &cons->expr->where);
}
if (!a.save)
{
t = FAILURE;
gfc_error ("Pointer initialization target at %L "
"must have the SAVE attribute", &cons->expr->where);
}
}
/* F2003, C1272 (3). */
if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
&& (gfc_impure_variable (cons->expr->symtree->n.sym)
|| gfc_is_coindexed (cons->expr)))
{
t = FAILURE;
gfc_error ("Invalid expression in the structure constructor for "
"pointer component '%s' at %L in PURE procedure",
comp->name, &cons->expr->where);
}
if (gfc_implicit_pure (NULL)
&& cons->expr->expr_type == EXPR_VARIABLE
&& (gfc_impure_variable (cons->expr->symtree->n.sym)
|| gfc_is_coindexed (cons->expr)))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
}
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. */
typedef enum
{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
proc_type;
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->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 '%s' 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 ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
&e->where);
if (n == 0)
gfc_error ("GENERIC procedure '%s' 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
|| sym->attr.flavor == FL_DERIVED)
return false;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
/* 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 || gfc_option.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. */
gfc_try
gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
{
gfc_intrinsic_sym* isym = NULL;
const char* symstd;
if (sym->formal)
return SUCCESS;
/* Already resolved. */
if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
return SUCCESS;
/* 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)
isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
else if (!sym->attr.subroutine)
isym = gfc_find_function (sym->name);
if (isym)
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
&& !sym->attr.implicit_type)
gfc_warning ("Type specified for intrinsic function '%s' at %L is"
" ignored", sym->name, &sym->declared_at);
if (!sym->attr.function &&
gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
return FAILURE;
sym->ts = isym->ts;
}
else if ((isym = gfc_find_subroutine (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
{
gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
" specifier", sym->name, &sym->declared_at);
return FAILURE;
}
if (!sym->attr.subroutine &&
gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
return FAILURE;
}
else
{
gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
&sym->declared_at);
return FAILURE;
}
gfc_copy_formal_args_intr (sym, isym);
/* Check it is actually available in the standard settings. */
if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
== FAILURE)
{
gfc_error ("The intrinsic '%s' 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 FAILURE;
}
return SUCCESS;
}
/* Resolve a procedure expression, like passing it to a called procedure or as
RHS for a procedure pointer assignment. */
static gfc_try
resolve_procedure_expression (gfc_expr* expr)
{
gfc_symbol* sym;
if (expr->expr_type != EXPR_VARIABLE)
return SUCCESS;
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 SUCCESS;
/* 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 ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
" itself recursively. Declare it RECURSIVE or use"
" -frecursive", sym->name, &expr->where);
return SUCCESS;
}
/* 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 gfc_try
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
bool no_formal_args)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
gfc_try return_value = FAILURE;
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) != SUCCESS)
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
|| 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 '%s' 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 '%s' 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 '%s' is"
" used as actual argument at %L",
sym->name, &e->where) == FAILURE)
goto cleanup;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
{
gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' 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 '%s' 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) == FAILURE)
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 '%s' 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) == FAILURE)
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.c (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) != SUCCESS)
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 (strncmp ("%VAL", arg->name, 4) == 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.c. */
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 (strncmp ("%LOC", arg->name, 4) == 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;
}
}
}
/* 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 = SUCCESS;
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 gfc_try
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 SUCCESS;
}
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 SUCCESS;
}
else
return SUCCESS;
/* 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))
{
gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
"MISSING, it cannot be the actual argument of an "
"ELEMENTAL procedure unless there is a non-optional "
"argument with the same rank (12.4.1.5)",
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 FAILURE;
/* Elemental procedure's array actual arguments must conform. */
if (e != NULL)
{
if (gfc_check_conformance (arg->expr, e,
"elemental procedure") == FAILURE)
return FAILURE;
}
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->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 '%s' of "
"ELEMENTAL subroutine '%s' 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 FAILURE;
}
return SUCCESS;
}
/* 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.c.
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;
}
static void
resolve_global_procedure (gfc_symbol *sym, locus *where,
gfc_actual_arglist **actual, int sub)
{
gfc_gsymbol * gsym;
gfc_namespace *ns;
enum gfc_symbol_type type;
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
gsym = gfc_get_gsymbol (sym->name);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
gfc_global_used (gsym, where);
if (gfc_option.flag_whole_file
&& (sym->attr.if_source == IFSRC_UNKNOWN
|| sym->attr.if_source == IFSRC_IFBODY)
&& gsym->type != GSYM_UNKNOWN
&& gsym->ns
&& gsym->ns->resolved != -1
&& gsym->ns->proc_name
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
gfc_symbol *def_sym;
/* Resolve the gsymbol namespace if needed. */
if (!gsym->ns->resolved)
{
gfc_dt_list *old_dt_list;
struct gfc_omp_saved_state old_omp_state;
/* Stash away derived types so that the backend_decls do not
get mixed up. */
old_dt_list = gfc_derived_types;
gfc_derived_types = NULL;
/* And stash away openmp state. */
gfc_omp_save_and_clear_state (&old_omp_state);
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;
/* And openmp state. */
gfc_omp_restore_state (&old_omp_state);
}
/* 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;
}
}
def_sym = gsym->ns->proc_name;
if (def_sym->attr.entry_master)
{
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;
}
}
/* Differences in constant character lengths. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER)
{
long int l1 = 0, l2 = 0;
gfc_charlen *cl1 = sym->ts.u.cl;
gfc_charlen *cl2 = def_sym->ts.u.cl;
if (cl1 != NULL
&& cl1->length != NULL
&& cl1->length->expr_type == EXPR_CONSTANT)
l1 = mpz_get_si (cl1->length->value.integer);
if (cl2 != NULL
&& cl2->length != NULL
&& cl2->length->expr_type == EXPR_CONSTANT)
l2 = mpz_get_si (cl2->length->value.integer);
if (l1 && l2 && l1 != l2)
gfc_error ("Character length mismatch in return type of "
"function '%s' at %L (%ld/%ld)", sym->name,
&sym->declared_at, l1, l2);
}
/* Type mismatch of function return type and expected type. */
if (sym->attr.function
&& !gfc_compare_types (&sym->ts, &def_sym->ts))
gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
gfc_typename (&def_sym->ts));
if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
{
gfc_formal_arglist *arg = def_sym->formal;
for ( ; arg; arg = arg->next)
if (!arg->sym)
continue;
/* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
else if (arg->sym->attr.allocatable
|| arg->sym->attr.asynchronous
|| arg->sym->attr.optional
|| arg->sym->attr.pointer
|| arg->sym->attr.target
|| arg->sym->attr.value
|| arg->sym->attr.volatile_)
{
gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
"has an attribute that requires an explicit "
"interface for this procedure", arg->sym->name,
sym->name, &sym->declared_at);
break;
}
/* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
else if (arg->sym && arg->sym->as
&& arg->sym->as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
"argument '%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
/* TS 29113, 6.2. */
else if (arg->sym && arg->sym->as
&& arg->sym->as->type == AS_ASSUMED_RANK)
{
gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
"argument '%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
/* F2008, 12.4.2.2 (2c) */
else if (arg->sym->attr.codimension)
{
gfc_error ("Procedure '%s' at %L with coarray dummy argument "
"'%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
/* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
else if (false) /* TODO: is a parametrized derived type */
{
gfc_error ("Procedure '%s' at %L with parametrized derived "
"type argument '%s' must have an explicit "
"interface", sym->name, &sym->declared_at,
arg->sym->name);
break;
}
/* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
else if (arg->sym->ts.type == BT_CLASS)
{
gfc_error ("Procedure '%s' at %L with polymorphic dummy "
"argument '%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
/* As assumed-type is unlimited polymorphic (cf. above).
See also TS 29113, Note 6.1. */
else if (arg->sym->ts.type == BT_ASSUMED)
{
gfc_error ("Procedure '%s' at %L with assumed-type dummy "
"argument '%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
}
if (def_sym->attr.function)
{
/* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
if (def_sym->as && def_sym->as->rank
&& (!sym->as || sym->as->rank != def_sym->as->rank))
gfc_error ("The reference to function '%s' at %L either needs an "
"explicit INTERFACE or the rank is incorrect", sym->name,
where);
/* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
if ((def_sym->result->attr.pointer
|| def_sym->result->attr.allocatable)
&& (sym->attr.if_source != IFSRC_IFBODY
|| def_sym->result->attr.pointer
!= sym->result->attr.pointer
|| def_sym->result->attr.allocatable
!= sym->result->attr.allocatable))
gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
"result must have an explicit interface", sym->name,
where);
/* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
&& def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
&& cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Nonconstant character-length function '%s' at %L "
"must have an explicit interface", sym->name,
&sym->declared_at);
}
}
}
/* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
if (def_sym->attr.elemental && !sym->attr.elemental)
{
gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
"interface", sym->name, &sym->declared_at);
}
/* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
{
gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
"an explicit interface", sym->name, &sym->declared_at);
}
if (gfc_option.flag_whole_file == 1
|| ((gfc_option.warn_std & GFC_STD_LEGACY)
&& !(gfc_option.warn_std & GFC_STD_GNU)))
gfc_errors_to_warnings (1);
if (sym->attr.if_source != IFSRC_IFBODY)
gfc_procedure_use (def_sym, actual, where);
gfc_errors_to_warnings (0);
}
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 gfc_try
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 SUCCESS;
else if (m == MATCH_ERROR)
return FAILURE;
generic:
if (!intr)
for (intr = sym->generic; intr; intr = intr->next)
if (intr->sym->attr.flavor == FL_DERIVED)
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))
{
gfc_error ("There is no specific function for the generic '%s' "
"at %L", expr->symtree->n.sym->name, &expr->where);
return FAILURE;
}
if (intr)
{
if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
false) != SUCCESS)
return FAILURE;
return resolve_structure_cons (expr, 0);
}
m = gfc_intrinsic_func_interface (expr, 0);
if (m == MATCH_YES)
return SUCCESS;
if (m == MATCH_NO)
gfc_error ("Generic function '%s' at %L is not consistent with a "
"specific intrinsic interface", expr->symtree->n.sym->name,
&expr->where);
return FAILURE;
}
/* 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 '%s' 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;
if (sym->as != NULL)
expr->rank = sym->as->rank;
return MATCH_YES;
}
static gfc_try
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 SUCCESS;
if (m == MATCH_ERROR)
return FAILURE;
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 '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
return SUCCESS;
}
/* Resolve a procedure call not known to be generic nor specific. */
static gfc_try
resolve_unknown_f (gfc_expr *expr)
{
gfc_symbol *sym;
gfc_typespec *ts;
sym = expr->symtree->n.sym;
if (sym->attr.dummy)
{
sym->attr.proc = PROC_DUMMY;
expr->value.function.name = sym->name;
goto set_type;
}
/* See if we have an intrinsic function reference. */
if (gfc_is_intrinsic (sym, 0, expr->where))
{
if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
return SUCCESS;
return FAILURE;
}
/* The reference is to an external name. */
sym->attr.proc = PROC_EXTERNAL;
expr->value.function.name = sym->name;
expr->value.function.esym = expr->symtree->n.sym;
if (sym->as != NULL)
expr->rank = sym->as->rank;
/* Type of the expression is either the type of the symbol or the
default type of the symbol. */
set_type:
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
if (sym->ts.type != BT_UNKNOWN)
expr->ts = sym->ts;
else
{
ts = gfc_get_default_type (sym->name, sym->ns);
if (ts->type == BT_UNKNOWN)
{
gfc_error ("Function '%s' at %L has no IMPLICIT type",
sym->name, &expr->where);
return FAILURE;
}
else
expr->ts = *ts;
}
return SUCCESS;
}
/* Return true, if the symbol is an external procedure. */
static bool
is_external_proc (gfc_symbol *sym)
{
if (!sym->attr.dummy && !sym->attr.contained
&& !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.proc_pointer
&& !sym->attr.use_assoc
&& sym->name)
return true;
return false;
}
/* Figure out if a function reference is pure or not. Also set the name
of the function for a potential error message. Return nonzero if the
function is PURE, zero if not. */
static int
pure_stmt_function (gfc_expr *, gfc_symbol *);
static int
pure_function (gfc_expr *e, const char **name)
{
int pure;
*name = NULL;
if (e->symtree != NULL
&& e->symtree->n.sym != NULL
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
return pure_stmt_function (e, e->symtree->n.sym);
if (e->value.function.esym)
{
pure = gfc_pure (e->value.function.esym);
*name = e->value.function.esym->name;
}
else if (e->value.function.isym)
{
pure = e->value.function.isym->pure
|| e->value.function.isym->elemental;
*name = e->value.function.isym->name;
}
else
{
/* Implicit functions are not pure. */
pure = 0;
*name = e->value.function.name;
}
return pure;
}
static bool
impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
int *f ATTRIBUTE_UNUSED)
{
const char *name;
/* Don't bother recursing into other statement functions
since they will be checked individually for purity. */
if (e->expr_type != EXPR_FUNCTION
|| !e->symtree
|| e->symtree->n.sym == sym
|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
return false;
return pure_function (e, &name) ? false : true;
}
static int
pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
{
return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
}
static gfc_try
is_scalar_expr_ptr (gfc_expr *expr)
{
gfc_try retval = SUCCESS;
gfc_ref *ref;
int start;
int end;
/* See if we have a gfc_ref, which means we have a substring, array
reference, or a component. */
if (expr->ref != NULL)
{
ref = expr->ref;
while (ref->next != NULL)
ref = ref->next;
switch (ref->type)
{
case REF_SUBSTRING:
if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
|| gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
retval = FAILURE;
break;
case REF_ARRAY:
if (ref->u.ar.type == AR_ELEMENT)
retval = SUCCESS;
else if (ref->u.ar.type == AR_FULL)
{
/* The user can give a full array if the array is of size 1. */
if (ref->u.ar.as != NULL
&& ref->u.ar.as->rank == 1
&& ref->u.ar.as->type == AS_EXPLICIT
&& ref->u.ar.as->lower[0] != NULL
&& ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
&& ref->u.ar.as->upper[0] != NULL
&& ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
{
/* If we have a character string, we need to check if
its length is one. */
if (expr->ts.type == BT_CHARACTER)
{
if (expr->ts.u.cl == NULL
|| expr->ts.u.cl->length == NULL
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
!= 0)
retval = FAILURE;
}
else
{
/* We have constant lower and upper bounds. If the
difference between is 1, it can be considered a
scalar.
FIXME: Use gfc_dep_compare_expr instead. */
start = (int) mpz_get_si
(ref->u.ar.as->lower[0]->value.integer);
end = (int) mpz_get_si
(ref->u.ar.as->upper[0]->value.integer);
if (end - start + 1 != 1)
retval = FAILURE;
}
}
else
retval = FAILURE;
}
else
retval = FAILURE;
break;
default:
retval = SUCCESS;
break;
}
}
else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
{
/* Character string. Make sure it's of length 1. */
if (expr->ts.u.cl == NULL
|| expr->ts.u.cl->length == NULL
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
retval = FAILURE;
}
else if (expr->rank != 0)
retval = FAILURE;
return retval;
}
/* Match one of the iso_c_binding functions (c_associated or c_loc)
and, in the case of c_associated, set the binding label based on
the arguments. */
static gfc_try
gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
gfc_symbol **new_sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
int optional_arg = 0;
gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
gfc_typespec *arg_ts;
symbol_attribute arg_attr;
if (args->expr->expr_type == EXPR_CONSTANT
|| args->expr->expr_type == EXPR_OP
|| args->expr->expr_type == EXPR_NULL)
{
gfc_error ("Argument to '%s' at %L is not a variable",
sym->name, &(args->expr->where));
return FAILURE;
}
args_sym = args->expr->symtree->n.sym;
/* The typespec for the actual arg should be that stored in the expr
and not necessarily that of the expr symbol (args_sym), because
the actual expression could be a part-ref of the expr symbol. */
arg_ts = &(args->expr->ts);
arg_attr = gfc_expr_attr (args->expr);
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
/* If the user gave two args then they are providing something for
the optional arg (the second cptr). Therefore, set the name and
binding label to the c_associated for two cptrs. Otherwise,
set c_associated to expect one cptr. */
if (args->next)
{
/* two args. */
sprintf (name, "%s_2", sym->name);
optional_arg = 1;
}
else
{
/* one arg. */
sprintf (name, "%s_1", sym->name);
optional_arg = 0;
}
/* Get a new symbol for the version of c_associated that
will get called. */
*new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
sprintf (name, "%s", sym->name);
/* Error check the call. */
if (args->next != NULL)
{
gfc_error_now ("More actual than formal arguments in '%s' "
"call at %L", name, &(args->expr->where));
retval = FAILURE;
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
gfc_ref *ref;
bool seen_section;
/* Make sure we have either the target or pointer attribute. */
if (!arg_attr.target && !arg_attr.pointer)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
"a TARGET or an associated pointer",
args_sym->name,
sym->name, &(args->expr->where));
retval = FAILURE;
}
if (gfc_is_coindexed (args->expr))
{
gfc_error_now ("Coindexed argument not permitted"
" in '%s' call at %L", name,
&(args->expr->where));
retval = FAILURE;
}
/* Follow references to make sure there are no array
sections. */
seen_section = false;
for (ref=args->expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_ARRAY)
{
if (ref->u.ar.type == AR_SECTION)
seen_section = true;
if (ref->u.ar.type != AR_ELEMENT)
{
gfc_ref *r;
for (r = ref->next; r; r=r->next)
if (r->type == REF_COMPONENT)
{
gfc_error_now ("Array section not permitted"
" in '%s' call at %L", name,
&(args->expr->where));
retval = FAILURE;
break;
}
}
}
}
if (seen_section && retval == SUCCESS)
gfc_warning ("Array section in '%s' call at %L", name,
&(args->expr->where));
/* See if we have interoperable type and type param. */
if (gfc_verify_c_interop (arg_ts) == SUCCESS
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
{
if (args_sym->attr.target == 1)
{
/* Case 1a, section 15.1.2.5, J3/04-007: variable that
has the target attribute and is interoperable. */
/* Case 1b, section 15.1.2.5, J3/04-007: allocated
allocatable variable that has the TARGET attribute and
is not an array of zero size. */
if (args_sym->attr.allocatable == 1)
{
if (args_sym->attr.dimension != 0
&& (args_sym->as && args_sym->as->rank == 0))
{
gfc_error_now ("Allocatable variable '%s' used as a "
"parameter to '%s' at %L must not be "
"an array of zero size",
args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
}
else
{
/* A non-allocatable target variable with C
interoperable type and type parameters must be
interoperable. */
if (args_sym && args_sym->attr.dimension)
{
if (args_sym->as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Assumed-shape array '%s' at %L "
"cannot be an argument to the "
"procedure '%s' because "
"it is not C interoperable",
args_sym->name,
&(args->expr->where), sym<