/* Perform type resolution on the various structures.
|
/* Perform type resolution on the various structures.
|
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Andy Vaught
|
Contributed by Andy Vaught
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "flags.h"
|
#include "flags.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "obstack.h"
|
#include "obstack.h"
|
#include "bitmap.h"
|
#include "bitmap.h"
|
#include "arith.h" /* For gfc_compare_expr(). */
|
#include "arith.h" /* For gfc_compare_expr(). */
|
#include "dependency.h"
|
#include "dependency.h"
|
#include "data.h"
|
#include "data.h"
|
#include "target-memory.h" /* for gfc_simplify_transfer */
|
#include "target-memory.h" /* for gfc_simplify_transfer */
|
|
|
/* Types used in equivalence statements. */
|
/* Types used in equivalence statements. */
|
|
|
typedef enum seq_type
|
typedef enum seq_type
|
{
|
{
|
SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
|
SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
|
}
|
}
|
seq_type;
|
seq_type;
|
|
|
/* Stack to keep track of the nesting of blocks as we move through the
|
/* Stack to keep track of the nesting of blocks as we move through the
|
code. See resolve_branch() and resolve_code(). */
|
code. See resolve_branch() and resolve_code(). */
|
|
|
typedef struct code_stack
|
typedef struct code_stack
|
{
|
{
|
struct gfc_code *head, *current;
|
struct gfc_code *head, *current;
|
struct code_stack *prev;
|
struct code_stack *prev;
|
|
|
/* This bitmap keeps track of the targets valid for a branch from
|
/* This bitmap keeps track of the targets valid for a branch from
|
inside this block except for END {IF|SELECT}s of enclosing
|
inside this block except for END {IF|SELECT}s of enclosing
|
blocks. */
|
blocks. */
|
bitmap reachable_labels;
|
bitmap reachable_labels;
|
}
|
}
|
code_stack;
|
code_stack;
|
|
|
static code_stack *cs_base = NULL;
|
static code_stack *cs_base = NULL;
|
|
|
|
|
/* Nonzero if we're inside a FORALL block. */
|
/* Nonzero if we're inside a FORALL block. */
|
|
|
static int forall_flag;
|
static int forall_flag;
|
|
|
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
|
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
|
|
|
static int omp_workshare_flag;
|
static int omp_workshare_flag;
|
|
|
/* Nonzero if we are processing a formal arglist. The corresponding function
|
/* Nonzero if we are processing a formal arglist. The corresponding function
|
resets the flag each time that it is read. */
|
resets the flag each time that it is read. */
|
static int formal_arg_flag = 0;
|
static int formal_arg_flag = 0;
|
|
|
/* True if we are resolving a specification expression. */
|
/* True if we are resolving a specification expression. */
|
static int specification_expr = 0;
|
static int specification_expr = 0;
|
|
|
/* The id of the last entry seen. */
|
/* The id of the last entry seen. */
|
static int current_entry_id;
|
static int current_entry_id;
|
|
|
/* We use bitmaps to determine if a branch target is valid. */
|
/* We use bitmaps to determine if a branch target is valid. */
|
static bitmap_obstack labels_obstack;
|
static bitmap_obstack labels_obstack;
|
|
|
int
|
int
|
gfc_is_formal_arg (void)
|
gfc_is_formal_arg (void)
|
{
|
{
|
return formal_arg_flag;
|
return formal_arg_flag;
|
}
|
}
|
|
|
/* Is the symbol host associated? */
|
/* Is the symbol host associated? */
|
static bool
|
static bool
|
is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
|
is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
|
{
|
{
|
for (ns = ns->parent; ns; ns = ns->parent)
|
for (ns = ns->parent; ns; ns = ns->parent)
|
{
|
{
|
if (sym->ns == ns)
|
if (sym->ns == ns)
|
return true;
|
return true;
|
}
|
}
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
|
/* 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
|
an ABSTRACT derived-type. If where is not NULL, an error message with that
|
locus is printed, optionally using name. */
|
locus is printed, optionally using name. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
|
resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
|
{
|
{
|
if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
|
if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
|
{
|
{
|
if (where)
|
if (where)
|
{
|
{
|
if (name)
|
if (name)
|
gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
|
gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
|
name, where, ts->u.derived->name);
|
name, where, ts->u.derived->name);
|
else
|
else
|
gfc_error ("ABSTRACT type '%s' used at %L",
|
gfc_error ("ABSTRACT type '%s' used at %L",
|
ts->u.derived->name, where);
|
ts->u.derived->name, where);
|
}
|
}
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve types of formal argument lists. These have to be done early so that
|
/* 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
|
the formal argument lists of module procedures can be copied to the
|
containing module before the individual procedures are resolved
|
containing module before the individual procedures are resolved
|
individually. We also resolve argument lists of procedures in interface
|
individually. We also resolve argument lists of procedures in interface
|
blocks because they are self-contained scoping units.
|
blocks because they are self-contained scoping units.
|
|
|
Since a dummy argument cannot be a non-dummy procedure, the only
|
Since a dummy argument cannot be a non-dummy procedure, the only
|
resort left for untyped names are the IMPLICIT types. */
|
resort left for untyped names are the IMPLICIT types. */
|
|
|
static void
|
static void
|
resolve_formal_arglist (gfc_symbol *proc)
|
resolve_formal_arglist (gfc_symbol *proc)
|
{
|
{
|
gfc_formal_arglist *f;
|
gfc_formal_arglist *f;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
int i;
|
int i;
|
|
|
if (proc->result != NULL)
|
if (proc->result != NULL)
|
sym = proc->result;
|
sym = proc->result;
|
else
|
else
|
sym = proc;
|
sym = proc;
|
|
|
if (gfc_elemental (proc)
|
if (gfc_elemental (proc)
|
|| sym->attr.pointer || sym->attr.allocatable
|
|| sym->attr.pointer || sym->attr.allocatable
|
|| (sym->as && sym->as->rank > 0))
|
|| (sym->as && sym->as->rank > 0))
|
{
|
{
|
proc->attr.always_explicit = 1;
|
proc->attr.always_explicit = 1;
|
sym->attr.always_explicit = 1;
|
sym->attr.always_explicit = 1;
|
}
|
}
|
|
|
formal_arg_flag = 1;
|
formal_arg_flag = 1;
|
|
|
for (f = proc->formal; f; f = f->next)
|
for (f = proc->formal; f; f = f->next)
|
{
|
{
|
sym = f->sym;
|
sym = f->sym;
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
{
|
{
|
/* Alternate return placeholder. */
|
/* Alternate return placeholder. */
|
if (gfc_elemental (proc))
|
if (gfc_elemental (proc))
|
gfc_error ("Alternate return specifier in elemental subroutine "
|
gfc_error ("Alternate return specifier in elemental subroutine "
|
"'%s' at %L is not allowed", proc->name,
|
"'%s' at %L is not allowed", proc->name,
|
&proc->declared_at);
|
&proc->declared_at);
|
if (proc->attr.function)
|
if (proc->attr.function)
|
gfc_error ("Alternate return specifier in function "
|
gfc_error ("Alternate return specifier in function "
|
"'%s' at %L is not allowed", proc->name,
|
"'%s' at %L is not allowed", proc->name,
|
&proc->declared_at);
|
&proc->declared_at);
|
continue;
|
continue;
|
}
|
}
|
|
|
if (sym->attr.if_source != IFSRC_UNKNOWN)
|
if (sym->attr.if_source != IFSRC_UNKNOWN)
|
resolve_formal_arglist (sym);
|
resolve_formal_arglist (sym);
|
|
|
if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
|
if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
|
{
|
{
|
if (gfc_pure (proc) && !gfc_pure (sym))
|
if (gfc_pure (proc) && !gfc_pure (sym))
|
{
|
{
|
gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
|
gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
|
"also be PURE", sym->name, &sym->declared_at);
|
"also be PURE", sym->name, &sym->declared_at);
|
continue;
|
continue;
|
}
|
}
|
|
|
if (gfc_elemental (proc))
|
if (gfc_elemental (proc))
|
{
|
{
|
gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
|
gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
|
"procedure", &sym->declared_at);
|
"procedure", &sym->declared_at);
|
continue;
|
continue;
|
}
|
}
|
|
|
if (sym->attr.function
|
if (sym->attr.function
|
&& sym->ts.type == BT_UNKNOWN
|
&& sym->ts.type == BT_UNKNOWN
|
&& sym->attr.intrinsic)
|
&& sym->attr.intrinsic)
|
{
|
{
|
gfc_intrinsic_sym *isym;
|
gfc_intrinsic_sym *isym;
|
isym = gfc_find_function (sym->name);
|
isym = gfc_find_function (sym->name);
|
if (isym == NULL || !isym->specific)
|
if (isym == NULL || !isym->specific)
|
{
|
{
|
gfc_error ("Unable to find a specific INTRINSIC procedure "
|
gfc_error ("Unable to find a specific INTRINSIC procedure "
|
"for the reference '%s' at %L", sym->name,
|
"for the reference '%s' at %L", sym->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
}
|
}
|
sym->ts = isym->ts;
|
sym->ts = isym->ts;
|
}
|
}
|
|
|
continue;
|
continue;
|
}
|
}
|
|
|
if (sym->ts.type == BT_UNKNOWN)
|
if (sym->ts.type == BT_UNKNOWN)
|
{
|
{
|
if (!sym->attr.function || sym->result == sym)
|
if (!sym->attr.function || sym->result == sym)
|
gfc_set_default_type (sym, 1, sym->ns);
|
gfc_set_default_type (sym, 1, sym->ns);
|
}
|
}
|
|
|
gfc_resolve_array_spec (sym->as, 0);
|
gfc_resolve_array_spec (sym->as, 0);
|
|
|
/* We can't tell if an array with dimension (:) is assumed or deferred
|
/* 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.
|
shape until we know if it has the pointer or allocatable attributes.
|
*/
|
*/
|
if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
|
if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
|
&& !(sym->attr.pointer || sym->attr.allocatable))
|
&& !(sym->attr.pointer || sym->attr.allocatable))
|
{
|
{
|
sym->as->type = AS_ASSUMED_SHAPE;
|
sym->as->type = AS_ASSUMED_SHAPE;
|
for (i = 0; i < sym->as->rank; i++)
|
for (i = 0; i < sym->as->rank; i++)
|
sym->as->lower[i] = gfc_int_expr (1);
|
sym->as->lower[i] = gfc_int_expr (1);
|
}
|
}
|
|
|
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
|
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
|
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|
|| sym->attr.optional)
|
|| sym->attr.optional)
|
{
|
{
|
proc->attr.always_explicit = 1;
|
proc->attr.always_explicit = 1;
|
if (proc->result)
|
if (proc->result)
|
proc->result->attr.always_explicit = 1;
|
proc->result->attr.always_explicit = 1;
|
}
|
}
|
|
|
/* If the flavor is unknown at this point, it has to be a variable.
|
/* If the flavor is unknown at this point, it has to be a variable.
|
A procedure specification would have already set the type. */
|
A procedure specification would have already set the type. */
|
|
|
if (sym->attr.flavor == FL_UNKNOWN)
|
if (sym->attr.flavor == FL_UNKNOWN)
|
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
|
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
|
|
|
if (gfc_pure (proc) && !sym->attr.pointer
|
if (gfc_pure (proc) && !sym->attr.pointer
|
&& sym->attr.flavor != FL_PROCEDURE)
|
&& sym->attr.flavor != FL_PROCEDURE)
|
{
|
{
|
if (proc->attr.function && sym->attr.intent != INTENT_IN)
|
if (proc->attr.function && sym->attr.intent != INTENT_IN)
|
gfc_error ("Argument '%s' of pure function '%s' at %L must be "
|
gfc_error ("Argument '%s' of pure function '%s' at %L must be "
|
"INTENT(IN)", sym->name, proc->name,
|
"INTENT(IN)", sym->name, proc->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
|
|
if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
|
if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
|
gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
|
gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
|
"have its INTENT specified", sym->name, proc->name,
|
"have its INTENT specified", sym->name, proc->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
}
|
}
|
|
|
if (gfc_elemental (proc))
|
if (gfc_elemental (proc))
|
{
|
{
|
if (sym->as != NULL)
|
if (sym->as != NULL)
|
{
|
{
|
gfc_error ("Argument '%s' of elemental procedure at %L must "
|
gfc_error ("Argument '%s' of elemental procedure at %L must "
|
"be scalar", sym->name, &sym->declared_at);
|
"be scalar", sym->name, &sym->declared_at);
|
continue;
|
continue;
|
}
|
}
|
|
|
if (sym->attr.pointer)
|
if (sym->attr.pointer)
|
{
|
{
|
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
|
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
|
"have the POINTER attribute", sym->name,
|
"have the POINTER attribute", sym->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
continue;
|
continue;
|
}
|
}
|
|
|
if (sym->attr.flavor == FL_PROCEDURE)
|
if (sym->attr.flavor == FL_PROCEDURE)
|
{
|
{
|
gfc_error ("Dummy procedure '%s' not allowed in elemental "
|
gfc_error ("Dummy procedure '%s' not allowed in elemental "
|
"procedure '%s' at %L", sym->name, proc->name,
|
"procedure '%s' at %L", sym->name, proc->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
continue;
|
continue;
|
}
|
}
|
}
|
}
|
|
|
/* Each dummy shall be specified to be scalar. */
|
/* Each dummy shall be specified to be scalar. */
|
if (proc->attr.proc == PROC_ST_FUNCTION)
|
if (proc->attr.proc == PROC_ST_FUNCTION)
|
{
|
{
|
if (sym->as != NULL)
|
if (sym->as != NULL)
|
{
|
{
|
gfc_error ("Argument '%s' of statement function at %L must "
|
gfc_error ("Argument '%s' of statement function at %L must "
|
"be scalar", sym->name, &sym->declared_at);
|
"be scalar", sym->name, &sym->declared_at);
|
continue;
|
continue;
|
}
|
}
|
|
|
if (sym->ts.type == BT_CHARACTER)
|
if (sym->ts.type == BT_CHARACTER)
|
{
|
{
|
gfc_charlen *cl = sym->ts.u.cl;
|
gfc_charlen *cl = sym->ts.u.cl;
|
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
|
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("Character-valued argument '%s' of statement "
|
gfc_error ("Character-valued argument '%s' of statement "
|
"function at %L must have constant length",
|
"function at %L must have constant length",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
continue;
|
continue;
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
formal_arg_flag = 0;
|
formal_arg_flag = 0;
|
}
|
}
|
|
|
|
|
/* Work function called when searching for symbols that have argument lists
|
/* Work function called when searching for symbols that have argument lists
|
associated with them. */
|
associated with them. */
|
|
|
static void
|
static void
|
find_arglists (gfc_symbol *sym)
|
find_arglists (gfc_symbol *sym)
|
{
|
{
|
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
|
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
|
return;
|
return;
|
|
|
resolve_formal_arglist (sym);
|
resolve_formal_arglist (sym);
|
}
|
}
|
|
|
|
|
/* Given a namespace, resolve all formal argument lists within the namespace.
|
/* Given a namespace, resolve all formal argument lists within the namespace.
|
*/
|
*/
|
|
|
static void
|
static void
|
resolve_formal_arglists (gfc_namespace *ns)
|
resolve_formal_arglists (gfc_namespace *ns)
|
{
|
{
|
if (ns == NULL)
|
if (ns == NULL)
|
return;
|
return;
|
|
|
gfc_traverse_ns (ns, find_arglists);
|
gfc_traverse_ns (ns, find_arglists);
|
}
|
}
|
|
|
|
|
static void
|
static void
|
resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
|
resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
|
|
/* If this namespace is not a function or an entry master function,
|
/* If this namespace is not a function or an entry master function,
|
ignore it. */
|
ignore it. */
|
if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
|
if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
|
|| sym->attr.entry_master)
|
|| sym->attr.entry_master)
|
return;
|
return;
|
|
|
/* Try to find out of what the return type is. */
|
/* Try to find out of what the return type is. */
|
if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
|
if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
|
{
|
{
|
t = gfc_set_default_type (sym->result, 0, ns);
|
t = gfc_set_default_type (sym->result, 0, ns);
|
|
|
if (t == FAILURE && !sym->result->attr.untyped)
|
if (t == FAILURE && !sym->result->attr.untyped)
|
{
|
{
|
if (sym->result == sym)
|
if (sym->result == sym)
|
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
|
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
else if (!sym->result->attr.proc_pointer)
|
else if (!sym->result->attr.proc_pointer)
|
gfc_error ("Result '%s' of contained function '%s' at %L has "
|
gfc_error ("Result '%s' of contained function '%s' at %L has "
|
"no IMPLICIT type", sym->result->name, sym->name,
|
"no IMPLICIT type", sym->result->name, sym->name,
|
&sym->result->declared_at);
|
&sym->result->declared_at);
|
sym->result->attr.untyped = 1;
|
sym->result->attr.untyped = 1;
|
}
|
}
|
}
|
}
|
|
|
/* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
|
/* 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:
|
type, lists the only ways a character length value of * can be used:
|
dummy arguments of procedures, named constants, and function results
|
dummy arguments of procedures, named constants, and function results
|
in external functions. Internal function results and results of module
|
in external functions. Internal function results and results of module
|
procedures are not on this list, ergo, not permitted. */
|
procedures are not on this list, ergo, not permitted. */
|
|
|
if (sym->result->ts.type == BT_CHARACTER)
|
if (sym->result->ts.type == BT_CHARACTER)
|
{
|
{
|
gfc_charlen *cl = sym->result->ts.u.cl;
|
gfc_charlen *cl = sym->result->ts.u.cl;
|
if (!cl || !cl->length)
|
if (!cl || !cl->length)
|
{
|
{
|
/* See if this is a module-procedure and adapt error message
|
/* See if this is a module-procedure and adapt error message
|
accordingly. */
|
accordingly. */
|
bool module_proc;
|
bool module_proc;
|
gcc_assert (ns->parent && ns->parent->proc_name);
|
gcc_assert (ns->parent && ns->parent->proc_name);
|
module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
|
module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
|
|
|
gfc_error ("Character-valued %s '%s' at %L must not be"
|
gfc_error ("Character-valued %s '%s' at %L must not be"
|
" assumed length",
|
" assumed length",
|
module_proc ? _("module procedure")
|
module_proc ? _("module procedure")
|
: _("internal function"),
|
: _("internal function"),
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
|
/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
|
introduce duplicates. */
|
introduce duplicates. */
|
|
|
static void
|
static void
|
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
|
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
|
{
|
{
|
gfc_formal_arglist *f, *new_arglist;
|
gfc_formal_arglist *f, *new_arglist;
|
gfc_symbol *new_sym;
|
gfc_symbol *new_sym;
|
|
|
for (; new_args != NULL; new_args = new_args->next)
|
for (; new_args != NULL; new_args = new_args->next)
|
{
|
{
|
new_sym = new_args->sym;
|
new_sym = new_args->sym;
|
/* See if this arg is already in the formal argument list. */
|
/* See if this arg is already in the formal argument list. */
|
for (f = proc->formal; f; f = f->next)
|
for (f = proc->formal; f; f = f->next)
|
{
|
{
|
if (new_sym == f->sym)
|
if (new_sym == f->sym)
|
break;
|
break;
|
}
|
}
|
|
|
if (f)
|
if (f)
|
continue;
|
continue;
|
|
|
/* Add a new argument. Argument order is not important. */
|
/* Add a new argument. Argument order is not important. */
|
new_arglist = gfc_get_formal_arglist ();
|
new_arglist = gfc_get_formal_arglist ();
|
new_arglist->sym = new_sym;
|
new_arglist->sym = new_sym;
|
new_arglist->next = proc->formal;
|
new_arglist->next = proc->formal;
|
proc->formal = new_arglist;
|
proc->formal = new_arglist;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Flag the arguments that are not present in all entries. */
|
/* Flag the arguments that are not present in all entries. */
|
|
|
static void
|
static void
|
check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
|
check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
|
{
|
{
|
gfc_formal_arglist *f, *head;
|
gfc_formal_arglist *f, *head;
|
head = new_args;
|
head = new_args;
|
|
|
for (f = proc->formal; f; f = f->next)
|
for (f = proc->formal; f; f = f->next)
|
{
|
{
|
if (f->sym == NULL)
|
if (f->sym == NULL)
|
continue;
|
continue;
|
|
|
for (new_args = head; new_args; new_args = new_args->next)
|
for (new_args = head; new_args; new_args = new_args->next)
|
{
|
{
|
if (new_args->sym == f->sym)
|
if (new_args->sym == f->sym)
|
break;
|
break;
|
}
|
}
|
|
|
if (new_args)
|
if (new_args)
|
continue;
|
continue;
|
|
|
f->sym->attr.not_always_present = 1;
|
f->sym->attr.not_always_present = 1;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve alternate entry points. If a symbol has multiple entry points we
|
/* 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
|
create a new master symbol for the main routine, and turn the existing
|
symbol into an entry point. */
|
symbol into an entry point. */
|
|
|
static void
|
static void
|
resolve_entries (gfc_namespace *ns)
|
resolve_entries (gfc_namespace *ns)
|
{
|
{
|
gfc_namespace *old_ns;
|
gfc_namespace *old_ns;
|
gfc_code *c;
|
gfc_code *c;
|
gfc_symbol *proc;
|
gfc_symbol *proc;
|
gfc_entry_list *el;
|
gfc_entry_list *el;
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
static int master_count = 0;
|
static int master_count = 0;
|
|
|
if (ns->proc_name == NULL)
|
if (ns->proc_name == NULL)
|
return;
|
return;
|
|
|
/* No need to do anything if this procedure doesn't have alternate entry
|
/* No need to do anything if this procedure doesn't have alternate entry
|
points. */
|
points. */
|
if (!ns->entries)
|
if (!ns->entries)
|
return;
|
return;
|
|
|
/* We may already have resolved alternate entry points. */
|
/* We may already have resolved alternate entry points. */
|
if (ns->proc_name->attr.entry_master)
|
if (ns->proc_name->attr.entry_master)
|
return;
|
return;
|
|
|
/* If this isn't a procedure something has gone horribly wrong. */
|
/* If this isn't a procedure something has gone horribly wrong. */
|
gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
|
gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
|
|
|
/* Remember the current namespace. */
|
/* Remember the current namespace. */
|
old_ns = gfc_current_ns;
|
old_ns = gfc_current_ns;
|
|
|
gfc_current_ns = ns;
|
gfc_current_ns = ns;
|
|
|
/* Add the main entry point to the list of entry points. */
|
/* Add the main entry point to the list of entry points. */
|
el = gfc_get_entry_list ();
|
el = gfc_get_entry_list ();
|
el->sym = ns->proc_name;
|
el->sym = ns->proc_name;
|
el->id = 0;
|
el->id = 0;
|
el->next = ns->entries;
|
el->next = ns->entries;
|
ns->entries = el;
|
ns->entries = el;
|
ns->proc_name->attr.entry = 1;
|
ns->proc_name->attr.entry = 1;
|
|
|
/* If it is a module function, it needs to be in the right namespace
|
/* 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
|
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
|
need for this arose in get_proc_name, where these beasts were
|
left in their own namespace, to keep prior references linked to
|
left in their own namespace, to keep prior references linked to
|
the entry declaration.*/
|
the entry declaration.*/
|
if (ns->proc_name->attr.function
|
if (ns->proc_name->attr.function
|
&& ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
|
&& ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
|
el->sym->ns = ns;
|
el->sym->ns = ns;
|
|
|
/* Do the same for entries where the master is not a module
|
/* Do the same for entries where the master is not a module
|
procedure. These are retained in the module namespace because
|
procedure. These are retained in the module namespace because
|
of the module procedure declaration. */
|
of the module procedure declaration. */
|
for (el = el->next; el; el = el->next)
|
for (el = el->next; el; el = el->next)
|
if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
|
if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
|
&& el->sym->attr.mod_proc)
|
&& el->sym->attr.mod_proc)
|
el->sym->ns = ns;
|
el->sym->ns = ns;
|
el = ns->entries;
|
el = ns->entries;
|
|
|
/* Add an entry statement for it. */
|
/* Add an entry statement for it. */
|
c = gfc_get_code ();
|
c = gfc_get_code ();
|
c->op = EXEC_ENTRY;
|
c->op = EXEC_ENTRY;
|
c->ext.entry = el;
|
c->ext.entry = el;
|
c->next = ns->code;
|
c->next = ns->code;
|
ns->code = c;
|
ns->code = c;
|
|
|
/* Create a new symbol for the master function. */
|
/* Create a new symbol for the master function. */
|
/* Give the internal function a unique name (within this file).
|
/* Give the internal function a unique name (within this file).
|
Also include the function name so the user has some hope of figuring
|
Also include the function name so the user has some hope of figuring
|
out what is going on. */
|
out what is going on. */
|
snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
|
snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
|
master_count++, ns->proc_name->name);
|
master_count++, ns->proc_name->name);
|
gfc_get_ha_symbol (name, &proc);
|
gfc_get_ha_symbol (name, &proc);
|
gcc_assert (proc != NULL);
|
gcc_assert (proc != NULL);
|
|
|
gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
|
gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
|
if (ns->proc_name->attr.subroutine)
|
if (ns->proc_name->attr.subroutine)
|
gfc_add_subroutine (&proc->attr, proc->name, NULL);
|
gfc_add_subroutine (&proc->attr, proc->name, NULL);
|
else
|
else
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_typespec *ts, *fts;
|
gfc_typespec *ts, *fts;
|
gfc_array_spec *as, *fas;
|
gfc_array_spec *as, *fas;
|
gfc_add_function (&proc->attr, proc->name, NULL);
|
gfc_add_function (&proc->attr, proc->name, NULL);
|
proc->result = proc;
|
proc->result = proc;
|
fas = ns->entries->sym->as;
|
fas = ns->entries->sym->as;
|
fas = fas ? fas : ns->entries->sym->result->as;
|
fas = fas ? fas : ns->entries->sym->result->as;
|
fts = &ns->entries->sym->result->ts;
|
fts = &ns->entries->sym->result->ts;
|
if (fts->type == BT_UNKNOWN)
|
if (fts->type == BT_UNKNOWN)
|
fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
|
fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
|
for (el = ns->entries->next; el; el = el->next)
|
for (el = ns->entries->next; el; el = el->next)
|
{
|
{
|
ts = &el->sym->result->ts;
|
ts = &el->sym->result->ts;
|
as = el->sym->as;
|
as = el->sym->as;
|
as = as ? as : el->sym->result->as;
|
as = as ? as : el->sym->result->as;
|
if (ts->type == BT_UNKNOWN)
|
if (ts->type == BT_UNKNOWN)
|
ts = gfc_get_default_type (el->sym->result->name, NULL);
|
ts = gfc_get_default_type (el->sym->result->name, NULL);
|
|
|
if (! gfc_compare_types (ts, fts)
|
if (! gfc_compare_types (ts, fts)
|
|| (el->sym->result->attr.dimension
|
|| (el->sym->result->attr.dimension
|
!= ns->entries->sym->result->attr.dimension)
|
!= ns->entries->sym->result->attr.dimension)
|
|| (el->sym->result->attr.pointer
|
|| (el->sym->result->attr.pointer
|
!= ns->entries->sym->result->attr.pointer))
|
!= ns->entries->sym->result->attr.pointer))
|
break;
|
break;
|
else if (as && fas && ns->entries->sym->result != el->sym->result
|
else if (as && fas && ns->entries->sym->result != el->sym->result
|
&& gfc_compare_array_spec (as, fas) == 0)
|
&& gfc_compare_array_spec (as, fas) == 0)
|
gfc_error ("Function %s at %L has entries with mismatched "
|
gfc_error ("Function %s at %L has entries with mismatched "
|
"array specifications", ns->entries->sym->name,
|
"array specifications", ns->entries->sym->name,
|
&ns->entries->sym->declared_at);
|
&ns->entries->sym->declared_at);
|
/* The characteristics need to match and thus both need to have
|
/* The characteristics need to match and thus both need to have
|
the same string length, i.e. both len=*, or both len=4.
|
the same string length, i.e. both len=*, or both len=4.
|
Having both len=<variable> is also possible, but difficult to
|
Having both len=<variable> is also possible, but difficult to
|
check at compile time. */
|
check at compile time. */
|
else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
|
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 && fts->u.cl->length))
|
||(!ts->u.cl->length && fts->u.cl->length))
|
|| (ts->u.cl->length
|
|| (ts->u.cl->length
|
&& ts->u.cl->length->expr_type
|
&& ts->u.cl->length->expr_type
|
!= fts->u.cl->length->expr_type)
|
!= fts->u.cl->length->expr_type)
|
|| (ts->u.cl->length
|
|| (ts->u.cl->length
|
&& ts->u.cl->length->expr_type == EXPR_CONSTANT
|
&& ts->u.cl->length->expr_type == EXPR_CONSTANT
|
&& mpz_cmp (ts->u.cl->length->value.integer,
|
&& mpz_cmp (ts->u.cl->length->value.integer,
|
fts->u.cl->length->value.integer) != 0)))
|
fts->u.cl->length->value.integer) != 0)))
|
gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
|
gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
|
"entries returning variables of different "
|
"entries returning variables of different "
|
"string lengths", ns->entries->sym->name,
|
"string lengths", ns->entries->sym->name,
|
&ns->entries->sym->declared_at);
|
&ns->entries->sym->declared_at);
|
}
|
}
|
|
|
if (el == NULL)
|
if (el == NULL)
|
{
|
{
|
sym = ns->entries->sym->result;
|
sym = ns->entries->sym->result;
|
/* All result types the same. */
|
/* All result types the same. */
|
proc->ts = *fts;
|
proc->ts = *fts;
|
if (sym->attr.dimension)
|
if (sym->attr.dimension)
|
gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
|
gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
|
if (sym->attr.pointer)
|
if (sym->attr.pointer)
|
gfc_add_pointer (&proc->attr, NULL);
|
gfc_add_pointer (&proc->attr, NULL);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Otherwise the result will be passed through a union by
|
/* Otherwise the result will be passed through a union by
|
reference. */
|
reference. */
|
proc->attr.mixed_entry_master = 1;
|
proc->attr.mixed_entry_master = 1;
|
for (el = ns->entries; el; el = el->next)
|
for (el = ns->entries; el; el = el->next)
|
{
|
{
|
sym = el->sym->result;
|
sym = el->sym->result;
|
if (sym->attr.dimension)
|
if (sym->attr.dimension)
|
{
|
{
|
if (el == ns->entries)
|
if (el == ns->entries)
|
gfc_error ("FUNCTION result %s can't be an array in "
|
gfc_error ("FUNCTION result %s can't be an array in "
|
"FUNCTION %s at %L", sym->name,
|
"FUNCTION %s at %L", sym->name,
|
ns->entries->sym->name, &sym->declared_at);
|
ns->entries->sym->name, &sym->declared_at);
|
else
|
else
|
gfc_error ("ENTRY result %s can't be an array in "
|
gfc_error ("ENTRY result %s can't be an array in "
|
"FUNCTION %s at %L", sym->name,
|
"FUNCTION %s at %L", sym->name,
|
ns->entries->sym->name, &sym->declared_at);
|
ns->entries->sym->name, &sym->declared_at);
|
}
|
}
|
else if (sym->attr.pointer)
|
else if (sym->attr.pointer)
|
{
|
{
|
if (el == ns->entries)
|
if (el == ns->entries)
|
gfc_error ("FUNCTION result %s can't be a POINTER in "
|
gfc_error ("FUNCTION result %s can't be a POINTER in "
|
"FUNCTION %s at %L", sym->name,
|
"FUNCTION %s at %L", sym->name,
|
ns->entries->sym->name, &sym->declared_at);
|
ns->entries->sym->name, &sym->declared_at);
|
else
|
else
|
gfc_error ("ENTRY result %s can't be a POINTER in "
|
gfc_error ("ENTRY result %s can't be a POINTER in "
|
"FUNCTION %s at %L", sym->name,
|
"FUNCTION %s at %L", sym->name,
|
ns->entries->sym->name, &sym->declared_at);
|
ns->entries->sym->name, &sym->declared_at);
|
}
|
}
|
else
|
else
|
{
|
{
|
ts = &sym->ts;
|
ts = &sym->ts;
|
if (ts->type == BT_UNKNOWN)
|
if (ts->type == BT_UNKNOWN)
|
ts = gfc_get_default_type (sym->name, NULL);
|
ts = gfc_get_default_type (sym->name, NULL);
|
switch (ts->type)
|
switch (ts->type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
if (ts->kind == gfc_default_integer_kind)
|
if (ts->kind == gfc_default_integer_kind)
|
sym = NULL;
|
sym = NULL;
|
break;
|
break;
|
case BT_REAL:
|
case BT_REAL:
|
if (ts->kind == gfc_default_real_kind
|
if (ts->kind == gfc_default_real_kind
|
|| ts->kind == gfc_default_double_kind)
|
|| ts->kind == gfc_default_double_kind)
|
sym = NULL;
|
sym = NULL;
|
break;
|
break;
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
if (ts->kind == gfc_default_complex_kind)
|
if (ts->kind == gfc_default_complex_kind)
|
sym = NULL;
|
sym = NULL;
|
break;
|
break;
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
if (ts->kind == gfc_default_logical_kind)
|
if (ts->kind == gfc_default_logical_kind)
|
sym = NULL;
|
sym = NULL;
|
break;
|
break;
|
case BT_UNKNOWN:
|
case BT_UNKNOWN:
|
/* We will issue error elsewhere. */
|
/* We will issue error elsewhere. */
|
sym = NULL;
|
sym = NULL;
|
break;
|
break;
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
if (sym)
|
if (sym)
|
{
|
{
|
if (el == ns->entries)
|
if (el == ns->entries)
|
gfc_error ("FUNCTION result %s can't be of type %s "
|
gfc_error ("FUNCTION result %s can't be of type %s "
|
"in FUNCTION %s at %L", sym->name,
|
"in FUNCTION %s at %L", sym->name,
|
gfc_typename (ts), ns->entries->sym->name,
|
gfc_typename (ts), ns->entries->sym->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
else
|
else
|
gfc_error ("ENTRY result %s can't be of type %s "
|
gfc_error ("ENTRY result %s can't be of type %s "
|
"in FUNCTION %s at %L", sym->name,
|
"in FUNCTION %s at %L", sym->name,
|
gfc_typename (ts), ns->entries->sym->name,
|
gfc_typename (ts), ns->entries->sym->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
proc->attr.access = ACCESS_PRIVATE;
|
proc->attr.access = ACCESS_PRIVATE;
|
proc->attr.entry_master = 1;
|
proc->attr.entry_master = 1;
|
|
|
/* Merge all the entry point arguments. */
|
/* Merge all the entry point arguments. */
|
for (el = ns->entries; el; el = el->next)
|
for (el = ns->entries; el; el = el->next)
|
merge_argument_lists (proc, el->sym->formal);
|
merge_argument_lists (proc, el->sym->formal);
|
|
|
/* Check the master formal arguments for any that are not
|
/* Check the master formal arguments for any that are not
|
present in all entry points. */
|
present in all entry points. */
|
for (el = ns->entries; el; el = el->next)
|
for (el = ns->entries; el; el = el->next)
|
check_argument_lists (proc, el->sym->formal);
|
check_argument_lists (proc, el->sym->formal);
|
|
|
/* Use the master function for the function body. */
|
/* Use the master function for the function body. */
|
ns->proc_name = proc;
|
ns->proc_name = proc;
|
|
|
/* Finalize the new symbols. */
|
/* Finalize the new symbols. */
|
gfc_commit_symbols ();
|
gfc_commit_symbols ();
|
|
|
/* Restore the original namespace. */
|
/* Restore the original namespace. */
|
gfc_current_ns = old_ns;
|
gfc_current_ns = old_ns;
|
}
|
}
|
|
|
|
|
static bool
|
static bool
|
has_default_initializer (gfc_symbol *der)
|
has_default_initializer (gfc_symbol *der)
|
{
|
{
|
gfc_component *c;
|
gfc_component *c;
|
|
|
gcc_assert (der->attr.flavor == FL_DERIVED);
|
gcc_assert (der->attr.flavor == FL_DERIVED);
|
for (c = der->components; c; c = c->next)
|
for (c = der->components; c; c = c->next)
|
if ((c->ts.type != BT_DERIVED && c->initializer)
|
if ((c->ts.type != BT_DERIVED && c->initializer)
|
|| (c->ts.type == BT_DERIVED
|
|| (c->ts.type == BT_DERIVED
|
&& (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
|
&& (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
|
break;
|
break;
|
|
|
return c != NULL;
|
return c != NULL;
|
}
|
}
|
|
|
/* Resolve common variables. */
|
/* Resolve common variables. */
|
static void
|
static void
|
resolve_common_vars (gfc_symbol *sym, bool named_common)
|
resolve_common_vars (gfc_symbol *sym, bool named_common)
|
{
|
{
|
gfc_symbol *csym = sym;
|
gfc_symbol *csym = sym;
|
|
|
for (; csym; csym = csym->common_next)
|
for (; csym; csym = csym->common_next)
|
{
|
{
|
if (csym->value || csym->attr.data)
|
if (csym->value || csym->attr.data)
|
{
|
{
|
if (!csym->ns->is_block_data)
|
if (!csym->ns->is_block_data)
|
gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
|
gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
|
"but only in BLOCK DATA initialization is "
|
"but only in BLOCK DATA initialization is "
|
"allowed", csym->name, &csym->declared_at);
|
"allowed", csym->name, &csym->declared_at);
|
else if (!named_common)
|
else if (!named_common)
|
gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
|
gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
|
"in a blank COMMON but initialization is only "
|
"in a blank COMMON but initialization is only "
|
"allowed in named common blocks", csym->name,
|
"allowed in named common blocks", csym->name,
|
&csym->declared_at);
|
&csym->declared_at);
|
}
|
}
|
|
|
if (csym->ts.type != BT_DERIVED)
|
if (csym->ts.type != BT_DERIVED)
|
continue;
|
continue;
|
|
|
if (!(csym->ts.u.derived->attr.sequence
|
if (!(csym->ts.u.derived->attr.sequence
|
|| csym->ts.u.derived->attr.is_bind_c))
|
|| csym->ts.u.derived->attr.is_bind_c))
|
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
|
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
|
"has neither the SEQUENCE nor the BIND(C) "
|
"has neither the SEQUENCE nor the BIND(C) "
|
"attribute", csym->name, &csym->declared_at);
|
"attribute", csym->name, &csym->declared_at);
|
if (csym->ts.u.derived->attr.alloc_comp)
|
if (csym->ts.u.derived->attr.alloc_comp)
|
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
|
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
|
"has an ultimate component that is "
|
"has an ultimate component that is "
|
"allocatable", csym->name, &csym->declared_at);
|
"allocatable", csym->name, &csym->declared_at);
|
if (has_default_initializer (csym->ts.u.derived))
|
if (has_default_initializer (csym->ts.u.derived))
|
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
|
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
|
"may not have default initializer", csym->name,
|
"may not have default initializer", csym->name,
|
&csym->declared_at);
|
&csym->declared_at);
|
|
|
if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
|
if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
|
gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
|
gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
|
}
|
}
|
}
|
}
|
|
|
/* Resolve common blocks. */
|
/* Resolve common blocks. */
|
static void
|
static void
|
resolve_common_blocks (gfc_symtree *common_root)
|
resolve_common_blocks (gfc_symtree *common_root)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
|
|
if (common_root == NULL)
|
if (common_root == NULL)
|
return;
|
return;
|
|
|
if (common_root->left)
|
if (common_root->left)
|
resolve_common_blocks (common_root->left);
|
resolve_common_blocks (common_root->left);
|
if (common_root->right)
|
if (common_root->right)
|
resolve_common_blocks (common_root->right);
|
resolve_common_blocks (common_root->right);
|
|
|
resolve_common_vars (common_root->n.common->head, true);
|
resolve_common_vars (common_root->n.common->head, true);
|
|
|
gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
|
gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
|
if (sym == NULL)
|
if (sym == NULL)
|
return;
|
return;
|
|
|
if (sym->attr.flavor == FL_PARAMETER)
|
if (sym->attr.flavor == FL_PARAMETER)
|
gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
|
gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
|
sym->name, &common_root->n.common->where, &sym->declared_at);
|
sym->name, &common_root->n.common->where, &sym->declared_at);
|
|
|
if (sym->attr.intrinsic)
|
if (sym->attr.intrinsic)
|
gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
|
gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
|
sym->name, &common_root->n.common->where);
|
sym->name, &common_root->n.common->where);
|
else if (sym->attr.result
|
else if (sym->attr.result
|
|| gfc_is_function_return_value (sym, gfc_current_ns))
|
|| gfc_is_function_return_value (sym, gfc_current_ns))
|
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
|
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
|
"that is also a function result", sym->name,
|
"that is also a function result", sym->name,
|
&common_root->n.common->where);
|
&common_root->n.common->where);
|
else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
|
else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
|
&& sym->attr.proc != PROC_ST_FUNCTION)
|
&& sym->attr.proc != PROC_ST_FUNCTION)
|
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
|
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
|
"that is also a global procedure", sym->name,
|
"that is also a global procedure", sym->name,
|
&common_root->n.common->where);
|
&common_root->n.common->where);
|
}
|
}
|
|
|
|
|
/* Resolve contained function types. Because contained functions can call one
|
/* Resolve contained function types. Because contained functions can call one
|
another, they have to be worked out before any of the contained procedures
|
another, they have to be worked out before any of the contained procedures
|
can be resolved.
|
can be resolved.
|
|
|
The good news is that if a function doesn't already have a type, the only
|
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
|
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
|
by definition contained functions are contained namespace they're contained
|
in, not in a sibling or parent namespace. */
|
in, not in a sibling or parent namespace. */
|
|
|
static void
|
static void
|
resolve_contained_functions (gfc_namespace *ns)
|
resolve_contained_functions (gfc_namespace *ns)
|
{
|
{
|
gfc_namespace *child;
|
gfc_namespace *child;
|
gfc_entry_list *el;
|
gfc_entry_list *el;
|
|
|
resolve_formal_arglists (ns);
|
resolve_formal_arglists (ns);
|
|
|
for (child = ns->contained; child; child = child->sibling)
|
for (child = ns->contained; child; child = child->sibling)
|
{
|
{
|
/* Resolve alternate entry points first. */
|
/* Resolve alternate entry points first. */
|
resolve_entries (child);
|
resolve_entries (child);
|
|
|
/* Then check function return types. */
|
/* Then check function return types. */
|
resolve_contained_fntype (child->proc_name, child);
|
resolve_contained_fntype (child->proc_name, child);
|
for (el = child->entries; el; el = el->next)
|
for (el = child->entries; el; el = el->next)
|
resolve_contained_fntype (el->sym, child);
|
resolve_contained_fntype (el->sym, child);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve all of the elements of a structure constructor and make sure that
|
/* Resolve all of the elements of a structure constructor and make sure that
|
the types are correct. */
|
the types are correct. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_structure_cons (gfc_expr *expr)
|
resolve_structure_cons (gfc_expr *expr)
|
{
|
{
|
gfc_constructor *cons;
|
gfc_constructor *cons;
|
gfc_component *comp;
|
gfc_component *comp;
|
gfc_try t;
|
gfc_try t;
|
symbol_attribute a;
|
symbol_attribute a;
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
cons = expr->value.constructor;
|
cons = expr->value.constructor;
|
/* A constructor may have references if it is the result of substituting a
|
/* 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
|
parameter variable. In this case we just pull out the component we
|
want. */
|
want. */
|
if (expr->ref)
|
if (expr->ref)
|
comp = expr->ref->u.c.sym->components;
|
comp = expr->ref->u.c.sym->components;
|
else
|
else
|
comp = expr->ts.u.derived->components;
|
comp = expr->ts.u.derived->components;
|
|
|
/* See if the user is trying to invoke a structure constructor for one of
|
/* See if the user is trying to invoke a structure constructor for one of
|
the iso_c_binding derived types. */
|
the iso_c_binding derived types. */
|
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
|
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
|
&& expr->ts.u.derived->ts.is_iso_c && cons
|
&& expr->ts.u.derived->ts.is_iso_c && cons
|
&& (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
|
&& (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
|
{
|
{
|
gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
|
gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
|
expr->ts.u.derived->name, &(expr->where));
|
expr->ts.u.derived->name, &(expr->where));
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Return if structure constructor is c_null_(fun)prt. */
|
/* Return if structure constructor is c_null_(fun)prt. */
|
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
|
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
|
&& expr->ts.u.derived->ts.is_iso_c && cons
|
&& expr->ts.u.derived->ts.is_iso_c && cons
|
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
|
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
for (; comp; comp = comp->next, cons = cons->next)
|
for (; comp; comp = comp->next, cons = cons->next)
|
{
|
{
|
int rank;
|
int rank;
|
|
|
if (!cons->expr)
|
if (!cons->expr)
|
continue;
|
continue;
|
|
|
if (gfc_resolve_expr (cons->expr) == FAILURE)
|
if (gfc_resolve_expr (cons->expr) == FAILURE)
|
{
|
{
|
t = FAILURE;
|
t = FAILURE;
|
continue;
|
continue;
|
}
|
}
|
|
|
rank = comp->as ? comp->as->rank : 0;
|
rank = comp->as ? comp->as->rank : 0;
|
if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
|
if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
|
&& (comp->attr.allocatable || cons->expr->rank))
|
&& (comp->attr.allocatable || cons->expr->rank))
|
{
|
{
|
gfc_error ("The rank of the element in the derived type "
|
gfc_error ("The rank of the element in the derived type "
|
"constructor at %L does not match that of the "
|
"constructor at %L does not match that of the "
|
"component (%d/%d)", &cons->expr->where,
|
"component (%d/%d)", &cons->expr->where,
|
cons->expr->rank, rank);
|
cons->expr->rank, rank);
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
|
|
/* If we don't have the right type, try to convert it. */
|
/* If we don't have the right type, try to convert it. */
|
|
|
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
|
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
|
{
|
{
|
t = FAILURE;
|
t = FAILURE;
|
if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
|
if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
|
gfc_error ("The element in the derived type constructor at %L, "
|
gfc_error ("The element in the derived type constructor at %L, "
|
"for pointer component '%s', is %s but should be %s",
|
"for pointer component '%s', is %s but should be %s",
|
&cons->expr->where, comp->name,
|
&cons->expr->where, comp->name,
|
gfc_basic_typename (cons->expr->ts.type),
|
gfc_basic_typename (cons->expr->ts.type),
|
gfc_basic_typename (comp->ts.type));
|
gfc_basic_typename (comp->ts.type));
|
else
|
else
|
t = gfc_convert_type (cons->expr, &comp->ts, 1);
|
t = gfc_convert_type (cons->expr, &comp->ts, 1);
|
}
|
}
|
|
|
if (cons->expr->expr_type == EXPR_NULL
|
if (cons->expr->expr_type == EXPR_NULL
|
&& !(comp->attr.pointer || comp->attr.allocatable
|
&& !(comp->attr.pointer || comp->attr.allocatable
|
|| comp->attr.proc_pointer
|
|| comp->attr.proc_pointer
|
|| (comp->ts.type == BT_CLASS
|
|| (comp->ts.type == BT_CLASS
|
&& (comp->ts.u.derived->components->attr.pointer
|
&& (comp->ts.u.derived->components->attr.pointer
|
|| comp->ts.u.derived->components->attr.allocatable))))
|
|| comp->ts.u.derived->components->attr.allocatable))))
|
{
|
{
|
t = FAILURE;
|
t = FAILURE;
|
gfc_error ("The NULL in the derived type constructor at %L is "
|
gfc_error ("The NULL in the derived type constructor at %L is "
|
"being applied to component '%s', which is neither "
|
"being applied to component '%s', which is neither "
|
"a POINTER nor ALLOCATABLE", &cons->expr->where,
|
"a POINTER nor ALLOCATABLE", &cons->expr->where,
|
comp->name);
|
comp->name);
|
}
|
}
|
|
|
if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
|
if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
|
continue;
|
continue;
|
|
|
a = gfc_expr_attr (cons->expr);
|
a = gfc_expr_attr (cons->expr);
|
|
|
if (!a.pointer && !a.target)
|
if (!a.pointer && !a.target)
|
{
|
{
|
t = FAILURE;
|
t = FAILURE;
|
gfc_error ("The element in the derived type constructor at %L, "
|
gfc_error ("The element in the derived type constructor at %L, "
|
"for pointer component '%s' should be a POINTER or "
|
"for pointer component '%s' should be a POINTER or "
|
"a TARGET", &cons->expr->where, comp->name);
|
"a TARGET", &cons->expr->where, comp->name);
|
}
|
}
|
|
|
/* F2003, C1272 (3). */
|
/* F2003, C1272 (3). */
|
if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
|
if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
|
&& gfc_impure_variable (cons->expr->symtree->n.sym))
|
&& gfc_impure_variable (cons->expr->symtree->n.sym))
|
{
|
{
|
t = FAILURE;
|
t = FAILURE;
|
gfc_error ("Invalid expression in the derived type constructor for pointer "
|
gfc_error ("Invalid expression in the derived type constructor for pointer "
|
"component '%s' at %L in PURE procedure", comp->name,
|
"component '%s' at %L in PURE procedure", comp->name,
|
&cons->expr->where);
|
&cons->expr->where);
|
}
|
}
|
}
|
}
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
/****************** Expression name resolution ******************/
|
/****************** Expression name resolution ******************/
|
|
|
/* Returns 0 if a symbol was not declared with a type or
|
/* Returns 0 if a symbol was not declared with a type or
|
attribute declaration statement, nonzero otherwise. */
|
attribute declaration statement, nonzero otherwise. */
|
|
|
static int
|
static int
|
was_declared (gfc_symbol *sym)
|
was_declared (gfc_symbol *sym)
|
{
|
{
|
symbol_attribute a;
|
symbol_attribute a;
|
|
|
a = sym->attr;
|
a = sym->attr;
|
|
|
if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
|
if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
|
return 1;
|
return 1;
|
|
|
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|
|| a.optional || a.pointer || a.save || a.target || a.volatile_
|
|| a.optional || a.pointer || a.save || a.target || a.volatile_
|
|| a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
|
|| a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
|
|| a.asynchronous)
|
|| a.asynchronous)
|
return 1;
|
return 1;
|
|
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/* Determine if a symbol is generic or not. */
|
/* Determine if a symbol is generic or not. */
|
|
|
static int
|
static int
|
generic_sym (gfc_symbol *sym)
|
generic_sym (gfc_symbol *sym)
|
{
|
{
|
gfc_symbol *s;
|
gfc_symbol *s;
|
|
|
if (sym->attr.generic ||
|
if (sym->attr.generic ||
|
(sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
|
(sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
|
return 1;
|
return 1;
|
|
|
if (was_declared (sym) || sym->ns->parent == NULL)
|
if (was_declared (sym) || sym->ns->parent == NULL)
|
return 0;
|
return 0;
|
|
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
|
|
|
if (s != NULL)
|
if (s != NULL)
|
{
|
{
|
if (s == sym)
|
if (s == sym)
|
return 0;
|
return 0;
|
else
|
else
|
return generic_sym (s);
|
return generic_sym (s);
|
}
|
}
|
|
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/* Determine if a symbol is specific or not. */
|
/* Determine if a symbol is specific or not. */
|
|
|
static int
|
static int
|
specific_sym (gfc_symbol *sym)
|
specific_sym (gfc_symbol *sym)
|
{
|
{
|
gfc_symbol *s;
|
gfc_symbol *s;
|
|
|
if (sym->attr.if_source == IFSRC_IFBODY
|
if (sym->attr.if_source == IFSRC_IFBODY
|
|| sym->attr.proc == PROC_MODULE
|
|| sym->attr.proc == PROC_MODULE
|
|| sym->attr.proc == PROC_INTERNAL
|
|| sym->attr.proc == PROC_INTERNAL
|
|| sym->attr.proc == PROC_ST_FUNCTION
|
|| sym->attr.proc == PROC_ST_FUNCTION
|
|| (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
|
|| (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
|
|| sym->attr.external)
|
|| sym->attr.external)
|
return 1;
|
return 1;
|
|
|
if (was_declared (sym) || sym->ns->parent == NULL)
|
if (was_declared (sym) || sym->ns->parent == NULL)
|
return 0;
|
return 0;
|
|
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
|
|
|
return (s == NULL) ? 0 : specific_sym (s);
|
return (s == NULL) ? 0 : specific_sym (s);
|
}
|
}
|
|
|
|
|
/* Figure out if the procedure is specific, generic or unknown. */
|
/* Figure out if the procedure is specific, generic or unknown. */
|
|
|
typedef enum
|
typedef enum
|
{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
|
{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
|
proc_type;
|
proc_type;
|
|
|
static proc_type
|
static proc_type
|
procedure_kind (gfc_symbol *sym)
|
procedure_kind (gfc_symbol *sym)
|
{
|
{
|
if (generic_sym (sym))
|
if (generic_sym (sym))
|
return PTYPE_GENERIC;
|
return PTYPE_GENERIC;
|
|
|
if (specific_sym (sym))
|
if (specific_sym (sym))
|
return PTYPE_SPECIFIC;
|
return PTYPE_SPECIFIC;
|
|
|
return PTYPE_UNKNOWN;
|
return PTYPE_UNKNOWN;
|
}
|
}
|
|
|
/* Check references to assumed size arrays. The flag need_full_assumed_size
|
/* Check references to assumed size arrays. The flag need_full_assumed_size
|
is nonzero when matching actual arguments. */
|
is nonzero when matching actual arguments. */
|
|
|
static int need_full_assumed_size = 0;
|
static int need_full_assumed_size = 0;
|
|
|
static bool
|
static bool
|
check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
|
check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
|
{
|
{
|
if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
|
if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
|
return false;
|
return false;
|
|
|
/* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
|
/* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
|
What should it be? */
|
What should it be? */
|
if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
|
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.as->type == AS_ASSUMED_SIZE)
|
&& (e->ref->u.ar.type == AR_FULL))
|
&& (e->ref->u.ar.type == AR_FULL))
|
{
|
{
|
gfc_error ("The upper bound in the last dimension must "
|
gfc_error ("The upper bound in the last dimension must "
|
"appear in the reference to the assumed size "
|
"appear in the reference to the assumed size "
|
"array '%s' at %L", sym->name, &e->where);
|
"array '%s' at %L", sym->name, &e->where);
|
return true;
|
return true;
|
}
|
}
|
return false;
|
return false;
|
}
|
}
|
|
|
|
|
/* Look for bad assumed size array references in argument expressions
|
/* Look for bad assumed size array references in argument expressions
|
of elemental and array valued intrinsic procedures. Since this is
|
of elemental and array valued intrinsic procedures. Since this is
|
called from procedure resolution functions, it only recurses at
|
called from procedure resolution functions, it only recurses at
|
operators. */
|
operators. */
|
|
|
static bool
|
static bool
|
resolve_assumed_size_actual (gfc_expr *e)
|
resolve_assumed_size_actual (gfc_expr *e)
|
{
|
{
|
if (e == NULL)
|
if (e == NULL)
|
return false;
|
return false;
|
|
|
switch (e->expr_type)
|
switch (e->expr_type)
|
{
|
{
|
case EXPR_VARIABLE:
|
case EXPR_VARIABLE:
|
if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
|
if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
|
return true;
|
return true;
|
break;
|
break;
|
|
|
case EXPR_OP:
|
case EXPR_OP:
|
if (resolve_assumed_size_actual (e->value.op.op1)
|
if (resolve_assumed_size_actual (e->value.op.op1)
|
|| resolve_assumed_size_actual (e->value.op.op2))
|
|| resolve_assumed_size_actual (e->value.op.op2))
|
return true;
|
return true;
|
break;
|
break;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
return false;
|
return false;
|
}
|
}
|
|
|
|
|
/* Check a generic procedure, passed as an actual argument, to see if
|
/* 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
|
there is a matching specific name. If none, it is an error, and if
|
more than one, the reference is ambiguous. */
|
more than one, the reference is ambiguous. */
|
static int
|
static int
|
count_specific_procs (gfc_expr *e)
|
count_specific_procs (gfc_expr *e)
|
{
|
{
|
int n;
|
int n;
|
gfc_interface *p;
|
gfc_interface *p;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
|
|
n = 0;
|
n = 0;
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
|
|
for (p = sym->generic; p; p = p->next)
|
for (p = sym->generic; p; p = p->next)
|
if (strcmp (sym->name, p->sym->name) == 0)
|
if (strcmp (sym->name, p->sym->name) == 0)
|
{
|
{
|
e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
|
e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
|
sym->name);
|
sym->name);
|
n++;
|
n++;
|
}
|
}
|
|
|
if (n > 1)
|
if (n > 1)
|
gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
|
gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
|
&e->where);
|
&e->where);
|
|
|
if (n == 0)
|
if (n == 0)
|
gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
|
gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
|
"argument at %L", sym->name, &e->where);
|
"argument at %L", sym->name, &e->where);
|
|
|
return n;
|
return n;
|
}
|
}
|
|
|
|
|
/* See if a call to sym could possibly be a not allowed RECURSION because of
|
/* See if a call to sym could possibly be a not allowed RECURSION because of
|
a missing RECURIVE declaration. This means that either sym is the current
|
a missing RECURIVE declaration. This means that either sym is the current
|
context itself, or sym is the parent of a contained procedure calling its
|
context itself, or sym is the parent of a contained procedure calling its
|
non-RECURSIVE containing procedure.
|
non-RECURSIVE containing procedure.
|
This also works if sym is an ENTRY. */
|
This also works if sym is an ENTRY. */
|
|
|
static bool
|
static bool
|
is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
|
is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
|
{
|
{
|
gfc_symbol* proc_sym;
|
gfc_symbol* proc_sym;
|
gfc_symbol* context_proc;
|
gfc_symbol* context_proc;
|
gfc_namespace* real_context;
|
gfc_namespace* real_context;
|
|
|
if (sym->attr.flavor == FL_PROGRAM)
|
if (sym->attr.flavor == FL_PROGRAM)
|
return false;
|
return false;
|
|
|
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
|
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
|
|
|
/* If we've got an ENTRY, find real procedure. */
|
/* If we've got an ENTRY, find real procedure. */
|
if (sym->attr.entry && sym->ns->entries)
|
if (sym->attr.entry && sym->ns->entries)
|
proc_sym = sym->ns->entries->sym;
|
proc_sym = sym->ns->entries->sym;
|
else
|
else
|
proc_sym = sym;
|
proc_sym = sym;
|
|
|
/* If sym is RECURSIVE, all is well of course. */
|
/* If sym is RECURSIVE, all is well of course. */
|
if (proc_sym->attr.recursive || gfc_option.flag_recursive)
|
if (proc_sym->attr.recursive || gfc_option.flag_recursive)
|
return false;
|
return false;
|
|
|
/* Find the context procedure's "real" symbol if it has entries.
|
/* 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
|
We look for a procedure symbol, so recurse on the parents if we don't
|
find one (like in case of a BLOCK construct). */
|
find one (like in case of a BLOCK construct). */
|
for (real_context = context; ; real_context = real_context->parent)
|
for (real_context = context; ; real_context = real_context->parent)
|
{
|
{
|
/* We should find something, eventually! */
|
/* We should find something, eventually! */
|
gcc_assert (real_context);
|
gcc_assert (real_context);
|
|
|
context_proc = (real_context->entries ? real_context->entries->sym
|
context_proc = (real_context->entries ? real_context->entries->sym
|
: real_context->proc_name);
|
: real_context->proc_name);
|
|
|
/* In some special cases, there may not be a proc_name, like for this
|
/* In some special cases, there may not be a proc_name, like for this
|
invalid code:
|
invalid code:
|
real(bad_kind()) function foo () ...
|
real(bad_kind()) function foo () ...
|
when checking the call to bad_kind ().
|
when checking the call to bad_kind ().
|
In these cases, we simply return here and assume that the
|
In these cases, we simply return here and assume that the
|
call is ok. */
|
call is ok. */
|
if (!context_proc)
|
if (!context_proc)
|
return false;
|
return false;
|
|
|
if (context_proc->attr.flavor != FL_LABEL)
|
if (context_proc->attr.flavor != FL_LABEL)
|
break;
|
break;
|
}
|
}
|
|
|
/* A call from sym's body to itself is recursion, of course. */
|
/* A call from sym's body to itself is recursion, of course. */
|
if (context_proc == proc_sym)
|
if (context_proc == proc_sym)
|
return true;
|
return true;
|
|
|
/* The same is true if context is a contained procedure and sym the
|
/* The same is true if context is a contained procedure and sym the
|
containing one. */
|
containing one. */
|
if (context_proc->attr.contained)
|
if (context_proc->attr.contained)
|
{
|
{
|
gfc_symbol* parent_proc;
|
gfc_symbol* parent_proc;
|
|
|
gcc_assert (context->parent);
|
gcc_assert (context->parent);
|
parent_proc = (context->parent->entries ? context->parent->entries->sym
|
parent_proc = (context->parent->entries ? context->parent->entries->sym
|
: context->parent->proc_name);
|
: context->parent->proc_name);
|
|
|
if (parent_proc == proc_sym)
|
if (parent_proc == proc_sym)
|
return true;
|
return true;
|
}
|
}
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
|
|
/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
|
/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
|
its typespec and formal argument list. */
|
its typespec and formal argument list. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_intrinsic (gfc_symbol *sym, locus *loc)
|
resolve_intrinsic (gfc_symbol *sym, locus *loc)
|
{
|
{
|
gfc_intrinsic_sym* isym;
|
gfc_intrinsic_sym* isym;
|
const char* symstd;
|
const char* symstd;
|
|
|
if (sym->formal)
|
if (sym->formal)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* We already know this one is an intrinsic, so we don't call
|
/* 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_is_intrinsic for full checking but rather use gfc_find_function and
|
gfc_find_subroutine directly to check whether it is a function or
|
gfc_find_subroutine directly to check whether it is a function or
|
subroutine. */
|
subroutine. */
|
|
|
if ((isym = gfc_find_function (sym->name)))
|
if ((isym = gfc_find_function (sym->name)))
|
{
|
{
|
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
|
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
|
&& !sym->attr.implicit_type)
|
&& !sym->attr.implicit_type)
|
gfc_warning ("Type specified for intrinsic function '%s' at %L is"
|
gfc_warning ("Type specified for intrinsic function '%s' at %L is"
|
" ignored", sym->name, &sym->declared_at);
|
" ignored", sym->name, &sym->declared_at);
|
|
|
if (!sym->attr.function &&
|
if (!sym->attr.function &&
|
gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
|
gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
sym->ts = isym->ts;
|
sym->ts = isym->ts;
|
}
|
}
|
else if ((isym = gfc_find_subroutine (sym->name)))
|
else if ((isym = gfc_find_subroutine (sym->name)))
|
{
|
{
|
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
|
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
|
{
|
{
|
gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
|
gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
|
" specifier", sym->name, &sym->declared_at);
|
" specifier", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!sym->attr.subroutine &&
|
if (!sym->attr.subroutine &&
|
gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
|
gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
|
gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
gfc_copy_formal_args_intr (sym, isym);
|
gfc_copy_formal_args_intr (sym, isym);
|
|
|
/* Check it is actually available in the standard settings. */
|
/* Check it is actually available in the standard settings. */
|
if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
|
if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
|
== FAILURE)
|
== FAILURE)
|
{
|
{
|
gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
|
gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
|
" available in the current standard settings but %s. Use"
|
" available in the current standard settings but %s. Use"
|
" an appropriate -std=* option or enable -fall-intrinsics"
|
" an appropriate -std=* option or enable -fall-intrinsics"
|
" in order to use it.",
|
" in order to use it.",
|
sym->name, &sym->declared_at, symstd);
|
sym->name, &sym->declared_at, symstd);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a procedure expression, like passing it to a called procedure or as
|
/* Resolve a procedure expression, like passing it to a called procedure or as
|
RHS for a procedure pointer assignment. */
|
RHS for a procedure pointer assignment. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_procedure_expression (gfc_expr* expr)
|
resolve_procedure_expression (gfc_expr* expr)
|
{
|
{
|
gfc_symbol* sym;
|
gfc_symbol* sym;
|
|
|
if (expr->expr_type != EXPR_VARIABLE)
|
if (expr->expr_type != EXPR_VARIABLE)
|
return SUCCESS;
|
return SUCCESS;
|
gcc_assert (expr->symtree);
|
gcc_assert (expr->symtree);
|
|
|
sym = expr->symtree->n.sym;
|
sym = expr->symtree->n.sym;
|
|
|
if (sym->attr.intrinsic)
|
if (sym->attr.intrinsic)
|
resolve_intrinsic (sym, &expr->where);
|
resolve_intrinsic (sym, &expr->where);
|
|
|
if (sym->attr.flavor != FL_PROCEDURE
|
if (sym->attr.flavor != FL_PROCEDURE
|
|| (sym->attr.function && sym->result == sym))
|
|| (sym->attr.function && sym->result == sym))
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* A non-RECURSIVE procedure that is used as procedure expression within its
|
/* A non-RECURSIVE procedure that is used as procedure expression within its
|
own body is in danger of being called recursively. */
|
own body is in danger of being called recursively. */
|
if (is_illegal_recursion (sym, gfc_current_ns))
|
if (is_illegal_recursion (sym, gfc_current_ns))
|
gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
|
gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
|
" itself recursively. Declare it RECURSIVE or use"
|
" itself recursively. Declare it RECURSIVE or use"
|
" -frecursive", sym->name, &expr->where);
|
" -frecursive", sym->name, &expr->where);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve an actual argument list. Most of the time, this is just
|
/* Resolve an actual argument list. Most of the time, this is just
|
resolving the expressions in the list.
|
resolving the expressions in the list.
|
The exception is that we sometimes have to decide whether arguments
|
The exception is that we sometimes have to decide whether arguments
|
that look like procedure arguments are really simple variable
|
that look like procedure arguments are really simple variable
|
references. */
|
references. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
|
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
|
bool no_formal_args)
|
bool no_formal_args)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_symtree *parent_st;
|
gfc_symtree *parent_st;
|
gfc_expr *e;
|
gfc_expr *e;
|
int save_need_full_assumed_size;
|
int save_need_full_assumed_size;
|
gfc_component *comp;
|
gfc_component *comp;
|
|
|
for (; arg; arg = arg->next)
|
for (; arg; arg = arg->next)
|
{
|
{
|
e = arg->expr;
|
e = arg->expr;
|
if (e == NULL)
|
if (e == NULL)
|
{
|
{
|
/* Check the label is a valid branching target. */
|
/* Check the label is a valid branching target. */
|
if (arg->label)
|
if (arg->label)
|
{
|
{
|
if (arg->label->defined == ST_LABEL_UNKNOWN)
|
if (arg->label->defined == ST_LABEL_UNKNOWN)
|
{
|
{
|
gfc_error ("Label %d referenced at %L is never defined",
|
gfc_error ("Label %d referenced at %L is never defined",
|
arg->label->value, &arg->label->where);
|
arg->label->value, &arg->label->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
continue;
|
continue;
|
}
|
}
|
|
|
if (gfc_is_proc_ptr_comp (e, &comp))
|
if (gfc_is_proc_ptr_comp (e, &comp))
|
{
|
{
|
e->ts = comp->ts;
|
e->ts = comp->ts;
|
if (e->expr_type == EXPR_PPC)
|
if (e->expr_type == EXPR_PPC)
|
{
|
{
|
if (comp->as != NULL)
|
if (comp->as != NULL)
|
e->rank = comp->as->rank;
|
e->rank = comp->as->rank;
|
e->expr_type = EXPR_FUNCTION;
|
e->expr_type = EXPR_FUNCTION;
|
}
|
}
|
if (gfc_resolve_expr (e) == FAILURE)
|
if (gfc_resolve_expr (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
goto argument_list;
|
goto argument_list;
|
}
|
}
|
|
|
if (e->expr_type == EXPR_VARIABLE
|
if (e->expr_type == EXPR_VARIABLE
|
&& e->symtree->n.sym->attr.generic
|
&& e->symtree->n.sym->attr.generic
|
&& no_formal_args
|
&& no_formal_args
|
&& count_specific_procs (e) != 1)
|
&& count_specific_procs (e) != 1)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (e->ts.type != BT_PROCEDURE)
|
if (e->ts.type != BT_PROCEDURE)
|
{
|
{
|
save_need_full_assumed_size = need_full_assumed_size;
|
save_need_full_assumed_size = need_full_assumed_size;
|
if (e->expr_type != EXPR_VARIABLE)
|
if (e->expr_type != EXPR_VARIABLE)
|
need_full_assumed_size = 0;
|
need_full_assumed_size = 0;
|
if (gfc_resolve_expr (e) != SUCCESS)
|
if (gfc_resolve_expr (e) != SUCCESS)
|
return FAILURE;
|
return FAILURE;
|
need_full_assumed_size = save_need_full_assumed_size;
|
need_full_assumed_size = save_need_full_assumed_size;
|
goto argument_list;
|
goto argument_list;
|
}
|
}
|
|
|
/* See if the expression node should really be a variable reference. */
|
/* See if the expression node should really be a variable reference. */
|
|
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
|
|
if (sym->attr.flavor == FL_PROCEDURE
|
if (sym->attr.flavor == FL_PROCEDURE
|
|| sym->attr.intrinsic
|
|| sym->attr.intrinsic
|
|| sym->attr.external)
|
|| sym->attr.external)
|
{
|
{
|
int actual_ok;
|
int actual_ok;
|
|
|
/* If a procedure is not already determined to be something else
|
/* If a procedure is not already determined to be something else
|
check if it is intrinsic. */
|
check if it is intrinsic. */
|
if (!sym->attr.intrinsic
|
if (!sym->attr.intrinsic
|
&& !(sym->attr.external || sym->attr.use_assoc
|
&& !(sym->attr.external || sym->attr.use_assoc
|
|| sym->attr.if_source == IFSRC_IFBODY)
|
|| sym->attr.if_source == IFSRC_IFBODY)
|
&& gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
|
&& gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
|
sym->attr.intrinsic = 1;
|
sym->attr.intrinsic = 1;
|
|
|
if (sym->attr.proc == PROC_ST_FUNCTION)
|
if (sym->attr.proc == PROC_ST_FUNCTION)
|
{
|
{
|
gfc_error ("Statement function '%s' at %L is not allowed as an "
|
gfc_error ("Statement function '%s' at %L is not allowed as an "
|
"actual argument", sym->name, &e->where);
|
"actual argument", sym->name, &e->where);
|
}
|
}
|
|
|
actual_ok = gfc_intrinsic_actual_ok (sym->name,
|
actual_ok = gfc_intrinsic_actual_ok (sym->name,
|
sym->attr.subroutine);
|
sym->attr.subroutine);
|
if (sym->attr.intrinsic && actual_ok == 0)
|
if (sym->attr.intrinsic && actual_ok == 0)
|
{
|
{
|
gfc_error ("Intrinsic '%s' at %L is not allowed as an "
|
gfc_error ("Intrinsic '%s' at %L is not allowed as an "
|
"actual argument", sym->name, &e->where);
|
"actual argument", sym->name, &e->where);
|
}
|
}
|
|
|
if (sym->attr.contained && !sym->attr.use_assoc
|
if (sym->attr.contained && !sym->attr.use_assoc
|
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
|
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
|
{
|
{
|
gfc_error ("Internal procedure '%s' is not allowed as an "
|
gfc_error ("Internal procedure '%s' is not allowed as an "
|
"actual argument at %L", sym->name, &e->where);
|
"actual argument at %L", sym->name, &e->where);
|
}
|
}
|
|
|
if (sym->attr.elemental && !sym->attr.intrinsic)
|
if (sym->attr.elemental && !sym->attr.intrinsic)
|
{
|
{
|
gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
|
gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
|
"allowed as an actual argument at %L", sym->name,
|
"allowed as an actual argument at %L", sym->name,
|
&e->where);
|
&e->where);
|
}
|
}
|
|
|
/* Check if a generic interface has a specific procedure
|
/* Check if a generic interface has a specific procedure
|
with the same name before emitting an error. */
|
with the same name before emitting an error. */
|
if (sym->attr.generic && count_specific_procs (e) != 1)
|
if (sym->attr.generic && count_specific_procs (e) != 1)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Just in case a specific was found for the expression. */
|
/* Just in case a specific was found for the expression. */
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
|
|
/* If the symbol is the function that names the current (or
|
/* If the symbol is the function that names the current (or
|
parent) scope, then we really have a variable reference. */
|
parent) scope, then we really have a variable reference. */
|
|
|
if (gfc_is_function_return_value (sym, sym->ns))
|
if (gfc_is_function_return_value (sym, sym->ns))
|
goto got_variable;
|
goto got_variable;
|
|
|
/* If all else fails, see if we have a specific intrinsic. */
|
/* If all else fails, see if we have a specific intrinsic. */
|
if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
|
if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
|
{
|
{
|
gfc_intrinsic_sym *isym;
|
gfc_intrinsic_sym *isym;
|
|
|
isym = gfc_find_function (sym->name);
|
isym = gfc_find_function (sym->name);
|
if (isym == NULL || !isym->specific)
|
if (isym == NULL || !isym->specific)
|
{
|
{
|
gfc_error ("Unable to find a specific INTRINSIC procedure "
|
gfc_error ("Unable to find a specific INTRINSIC procedure "
|
"for the reference '%s' at %L", sym->name,
|
"for the reference '%s' at %L", sym->name,
|
&e->where);
|
&e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
sym->ts = isym->ts;
|
sym->ts = isym->ts;
|
sym->attr.intrinsic = 1;
|
sym->attr.intrinsic = 1;
|
sym->attr.function = 1;
|
sym->attr.function = 1;
|
}
|
}
|
|
|
if (gfc_resolve_expr (e) == FAILURE)
|
if (gfc_resolve_expr (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
goto argument_list;
|
goto argument_list;
|
}
|
}
|
|
|
/* See if the name is a module procedure in a parent unit. */
|
/* See if the name is a module procedure in a parent unit. */
|
|
|
if (was_declared (sym) || sym->ns->parent == NULL)
|
if (was_declared (sym) || sym->ns->parent == NULL)
|
goto got_variable;
|
goto got_variable;
|
|
|
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
|
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);
|
gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (parent_st == NULL)
|
if (parent_st == NULL)
|
goto got_variable;
|
goto got_variable;
|
|
|
sym = parent_st->n.sym;
|
sym = parent_st->n.sym;
|
e->symtree = parent_st; /* Point to the right thing. */
|
e->symtree = parent_st; /* Point to the right thing. */
|
|
|
if (sym->attr.flavor == FL_PROCEDURE
|
if (sym->attr.flavor == FL_PROCEDURE
|
|| sym->attr.intrinsic
|
|| sym->attr.intrinsic
|
|| sym->attr.external)
|
|| sym->attr.external)
|
{
|
{
|
if (gfc_resolve_expr (e) == FAILURE)
|
if (gfc_resolve_expr (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
goto argument_list;
|
goto argument_list;
|
}
|
}
|
|
|
got_variable:
|
got_variable:
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
e->ts = sym->ts;
|
e->ts = sym->ts;
|
if (sym->as != NULL)
|
if (sym->as != NULL)
|
{
|
{
|
e->rank = sym->as->rank;
|
e->rank = sym->as->rank;
|
e->ref = gfc_get_ref ();
|
e->ref = gfc_get_ref ();
|
e->ref->type = REF_ARRAY;
|
e->ref->type = REF_ARRAY;
|
e->ref->u.ar.type = AR_FULL;
|
e->ref->u.ar.type = AR_FULL;
|
e->ref->u.ar.as = sym->as;
|
e->ref->u.ar.as = sym->as;
|
}
|
}
|
|
|
/* Expressions are assigned a default ts.type of BT_PROCEDURE in
|
/* Expressions are assigned a default ts.type of BT_PROCEDURE in
|
primary.c (match_actual_arg). If above code determines that it
|
primary.c (match_actual_arg). If above code determines that it
|
is a variable instead, it needs to be resolved as it was not
|
is a variable instead, it needs to be resolved as it was not
|
done at the beginning of this function. */
|
done at the beginning of this function. */
|
save_need_full_assumed_size = need_full_assumed_size;
|
save_need_full_assumed_size = need_full_assumed_size;
|
if (e->expr_type != EXPR_VARIABLE)
|
if (e->expr_type != EXPR_VARIABLE)
|
need_full_assumed_size = 0;
|
need_full_assumed_size = 0;
|
if (gfc_resolve_expr (e) != SUCCESS)
|
if (gfc_resolve_expr (e) != SUCCESS)
|
return FAILURE;
|
return FAILURE;
|
need_full_assumed_size = save_need_full_assumed_size;
|
need_full_assumed_size = save_need_full_assumed_size;
|
|
|
argument_list:
|
argument_list:
|
/* Check argument list functions %VAL, %LOC and %REF. There is
|
/* Check argument list functions %VAL, %LOC and %REF. There is
|
nothing to do for %REF. */
|
nothing to do for %REF. */
|
if (arg->name && arg->name[0] == '%')
|
if (arg->name && arg->name[0] == '%')
|
{
|
{
|
if (strncmp ("%VAL", arg->name, 4) == 0)
|
if (strncmp ("%VAL", arg->name, 4) == 0)
|
{
|
{
|
if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
|
if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
|
{
|
{
|
gfc_error ("By-value argument at %L is not of numeric "
|
gfc_error ("By-value argument at %L is not of numeric "
|
"type", &e->where);
|
"type", &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (e->rank)
|
if (e->rank)
|
{
|
{
|
gfc_error ("By-value argument at %L cannot be an array or "
|
gfc_error ("By-value argument at %L cannot be an array or "
|
"an array section", &e->where);
|
"an array section", &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Intrinsics are still PROC_UNKNOWN here. However,
|
/* Intrinsics are still PROC_UNKNOWN here. However,
|
since same file external procedures are not resolvable
|
since same file external procedures are not resolvable
|
in gfortran, it is a good deal easier to leave them to
|
in gfortran, it is a good deal easier to leave them to
|
intrinsic.c. */
|
intrinsic.c. */
|
if (ptype != PROC_UNKNOWN
|
if (ptype != PROC_UNKNOWN
|
&& ptype != PROC_DUMMY
|
&& ptype != PROC_DUMMY
|
&& ptype != PROC_EXTERNAL
|
&& ptype != PROC_EXTERNAL
|
&& ptype != PROC_MODULE)
|
&& ptype != PROC_MODULE)
|
{
|
{
|
gfc_error ("By-value argument at %L is not allowed "
|
gfc_error ("By-value argument at %L is not allowed "
|
"in this context", &e->where);
|
"in this context", &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Statement functions have already been excluded above. */
|
/* Statement functions have already been excluded above. */
|
else if (strncmp ("%LOC", arg->name, 4) == 0
|
else if (strncmp ("%LOC", arg->name, 4) == 0
|
&& e->ts.type == BT_PROCEDURE)
|
&& e->ts.type == BT_PROCEDURE)
|
{
|
{
|
if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
|
if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
|
{
|
{
|
gfc_error ("Passing internal procedure at %L by location "
|
gfc_error ("Passing internal procedure at %L by location "
|
"not allowed", &e->where);
|
"not allowed", &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Do the checks of the actual argument list that are specific to elemental
|
/* 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
|
procedures. If called with c == NULL, we have a function, otherwise if
|
expr == NULL, we have a subroutine. */
|
expr == NULL, we have a subroutine. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
|
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
|
{
|
{
|
gfc_actual_arglist *arg0;
|
gfc_actual_arglist *arg0;
|
gfc_actual_arglist *arg;
|
gfc_actual_arglist *arg;
|
gfc_symbol *esym = NULL;
|
gfc_symbol *esym = NULL;
|
gfc_intrinsic_sym *isym = NULL;
|
gfc_intrinsic_sym *isym = NULL;
|
gfc_expr *e = NULL;
|
gfc_expr *e = NULL;
|
gfc_intrinsic_arg *iformal = NULL;
|
gfc_intrinsic_arg *iformal = NULL;
|
gfc_formal_arglist *eformal = NULL;
|
gfc_formal_arglist *eformal = NULL;
|
bool formal_optional = false;
|
bool formal_optional = false;
|
bool set_by_optional = false;
|
bool set_by_optional = false;
|
int i;
|
int i;
|
int rank = 0;
|
int rank = 0;
|
|
|
/* Is this an elemental procedure? */
|
/* Is this an elemental procedure? */
|
if (expr && expr->value.function.actual != NULL)
|
if (expr && expr->value.function.actual != NULL)
|
{
|
{
|
if (expr->value.function.esym != NULL
|
if (expr->value.function.esym != NULL
|
&& expr->value.function.esym->attr.elemental)
|
&& expr->value.function.esym->attr.elemental)
|
{
|
{
|
arg0 = expr->value.function.actual;
|
arg0 = expr->value.function.actual;
|
esym = expr->value.function.esym;
|
esym = expr->value.function.esym;
|
}
|
}
|
else if (expr->value.function.isym != NULL
|
else if (expr->value.function.isym != NULL
|
&& expr->value.function.isym->elemental)
|
&& expr->value.function.isym->elemental)
|
{
|
{
|
arg0 = expr->value.function.actual;
|
arg0 = expr->value.function.actual;
|
isym = expr->value.function.isym;
|
isym = expr->value.function.isym;
|
}
|
}
|
else
|
else
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
else if (c && c->ext.actual != NULL)
|
else if (c && c->ext.actual != NULL)
|
{
|
{
|
arg0 = c->ext.actual;
|
arg0 = c->ext.actual;
|
|
|
if (c->resolved_sym)
|
if (c->resolved_sym)
|
esym = c->resolved_sym;
|
esym = c->resolved_sym;
|
else
|
else
|
esym = c->symtree->n.sym;
|
esym = c->symtree->n.sym;
|
gcc_assert (esym);
|
gcc_assert (esym);
|
|
|
if (!esym->attr.elemental)
|
if (!esym->attr.elemental)
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
else
|
else
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* The rank of an elemental is the rank of its array argument(s). */
|
/* The rank of an elemental is the rank of its array argument(s). */
|
for (arg = arg0; arg; arg = arg->next)
|
for (arg = arg0; arg; arg = arg->next)
|
{
|
{
|
if (arg->expr != NULL && arg->expr->rank > 0)
|
if (arg->expr != NULL && arg->expr->rank > 0)
|
{
|
{
|
rank = arg->expr->rank;
|
rank = arg->expr->rank;
|
if (arg->expr->expr_type == EXPR_VARIABLE
|
if (arg->expr->expr_type == EXPR_VARIABLE
|
&& arg->expr->symtree->n.sym->attr.optional)
|
&& arg->expr->symtree->n.sym->attr.optional)
|
set_by_optional = true;
|
set_by_optional = true;
|
|
|
/* Function specific; set the result rank and shape. */
|
/* Function specific; set the result rank and shape. */
|
if (expr)
|
if (expr)
|
{
|
{
|
expr->rank = rank;
|
expr->rank = rank;
|
if (!expr->shape && arg->expr->shape)
|
if (!expr->shape && arg->expr->shape)
|
{
|
{
|
expr->shape = gfc_get_shape (rank);
|
expr->shape = gfc_get_shape (rank);
|
for (i = 0; i < rank; i++)
|
for (i = 0; i < rank; i++)
|
mpz_init_set (expr->shape[i], arg->expr->shape[i]);
|
mpz_init_set (expr->shape[i], arg->expr->shape[i]);
|
}
|
}
|
}
|
}
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
/* If it is an array, it shall not be supplied as an actual argument
|
/* 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
|
to an elemental procedure unless an array of the same rank is supplied
|
as an actual argument corresponding to a nonoptional dummy argument of
|
as an actual argument corresponding to a nonoptional dummy argument of
|
that elemental procedure(12.4.1.5). */
|
that elemental procedure(12.4.1.5). */
|
formal_optional = false;
|
formal_optional = false;
|
if (isym)
|
if (isym)
|
iformal = isym->formal;
|
iformal = isym->formal;
|
else
|
else
|
eformal = esym->formal;
|
eformal = esym->formal;
|
|
|
for (arg = arg0; arg; arg = arg->next)
|
for (arg = arg0; arg; arg = arg->next)
|
{
|
{
|
if (eformal)
|
if (eformal)
|
{
|
{
|
if (eformal->sym && eformal->sym->attr.optional)
|
if (eformal->sym && eformal->sym->attr.optional)
|
formal_optional = true;
|
formal_optional = true;
|
eformal = eformal->next;
|
eformal = eformal->next;
|
}
|
}
|
else if (isym && iformal)
|
else if (isym && iformal)
|
{
|
{
|
if (iformal->optional)
|
if (iformal->optional)
|
formal_optional = true;
|
formal_optional = true;
|
iformal = iformal->next;
|
iformal = iformal->next;
|
}
|
}
|
else if (isym)
|
else if (isym)
|
formal_optional = true;
|
formal_optional = true;
|
|
|
if (pedantic && arg->expr != NULL
|
if (pedantic && arg->expr != NULL
|
&& arg->expr->expr_type == EXPR_VARIABLE
|
&& arg->expr->expr_type == EXPR_VARIABLE
|
&& arg->expr->symtree->n.sym->attr.optional
|
&& arg->expr->symtree->n.sym->attr.optional
|
&& formal_optional
|
&& formal_optional
|
&& arg->expr->rank
|
&& arg->expr->rank
|
&& (set_by_optional || arg->expr->rank != rank)
|
&& (set_by_optional || arg->expr->rank != rank)
|
&& !(isym && isym->id == GFC_ISYM_CONVERSION))
|
&& !(isym && isym->id == GFC_ISYM_CONVERSION))
|
{
|
{
|
gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
|
gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
|
"MISSING, it cannot be the actual argument of an "
|
"MISSING, it cannot be the actual argument of an "
|
"ELEMENTAL procedure unless there is a non-optional "
|
"ELEMENTAL procedure unless there is a non-optional "
|
"argument with the same rank (12.4.1.5)",
|
"argument with the same rank (12.4.1.5)",
|
arg->expr->symtree->n.sym->name, &arg->expr->where);
|
arg->expr->symtree->n.sym->name, &arg->expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
for (arg = arg0; arg; arg = arg->next)
|
for (arg = arg0; arg; arg = arg->next)
|
{
|
{
|
if (arg->expr == NULL || arg->expr->rank == 0)
|
if (arg->expr == NULL || arg->expr->rank == 0)
|
continue;
|
continue;
|
|
|
/* Being elemental, the last upper bound of an assumed size array
|
/* Being elemental, the last upper bound of an assumed size array
|
argument must be present. */
|
argument must be present. */
|
if (resolve_assumed_size_actual (arg->expr))
|
if (resolve_assumed_size_actual (arg->expr))
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Elemental procedure's array actual arguments must conform. */
|
/* Elemental procedure's array actual arguments must conform. */
|
if (e != NULL)
|
if (e != NULL)
|
{
|
{
|
if (gfc_check_conformance (arg->expr, e,
|
if (gfc_check_conformance (arg->expr, e,
|
"elemental procedure") == FAILURE)
|
"elemental procedure") == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else
|
else
|
e = arg->expr;
|
e = arg->expr;
|
}
|
}
|
|
|
/* INTENT(OUT) is only allowed for subroutines; if any actual argument
|
/* 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. */
|
is an array, the intent inout/out variable needs to be also an array. */
|
if (rank > 0 && esym && expr == NULL)
|
if (rank > 0 && esym && expr == NULL)
|
for (eformal = esym->formal, arg = arg0; arg && eformal;
|
for (eformal = esym->formal, arg = arg0; arg && eformal;
|
arg = arg->next, eformal = eformal->next)
|
arg = arg->next, eformal = eformal->next)
|
if ((eformal->sym->attr.intent == INTENT_OUT
|
if ((eformal->sym->attr.intent == INTENT_OUT
|
|| eformal->sym->attr.intent == INTENT_INOUT)
|
|| eformal->sym->attr.intent == INTENT_INOUT)
|
&& arg->expr && arg->expr->rank == 0)
|
&& arg->expr && arg->expr->rank == 0)
|
{
|
{
|
gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
|
gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
|
"ELEMENTAL subroutine '%s' is a scalar, but another "
|
"ELEMENTAL subroutine '%s' is a scalar, but another "
|
"actual argument is an array", &arg->expr->where,
|
"actual argument is an array", &arg->expr->where,
|
(eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
|
(eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
|
: "INOUT", eformal->sym->name, esym->name);
|
: "INOUT", eformal->sym->name, esym->name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Go through each actual argument in ACTUAL and see if it can be
|
/* Go through each actual argument in ACTUAL and see if it can be
|
implemented as an inlined, non-copying intrinsic. FNSYM is the
|
implemented as an inlined, non-copying intrinsic. FNSYM is the
|
function being called, or NULL if not known. */
|
function being called, or NULL if not known. */
|
|
|
static void
|
static void
|
find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
|
find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
|
{
|
{
|
gfc_actual_arglist *ap;
|
gfc_actual_arglist *ap;
|
gfc_expr *expr;
|
gfc_expr *expr;
|
|
|
for (ap = actual; ap; ap = ap->next)
|
for (ap = actual; ap; ap = ap->next)
|
if (ap->expr
|
if (ap->expr
|
&& (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
|
&& (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
|
&& !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
|
&& !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
|
NOT_ELEMENTAL))
|
NOT_ELEMENTAL))
|
ap->expr->inline_noncopying_intrinsic = 1;
|
ap->expr->inline_noncopying_intrinsic = 1;
|
}
|
}
|
|
|
|
|
/* This function does the checking of references to global procedures
|
/* This function does the checking of references to global procedures
|
as defined in sections 18.1 and 14.1, respectively, of the Fortran
|
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
|
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
|
one if it does not already exist. If it already exists, then the
|
reference being resolved must correspond to the type of gsymbol.
|
reference being resolved must correspond to the type of gsymbol.
|
Otherwise, the new symbol is equipped with the attributes of the
|
Otherwise, the new symbol is equipped with the attributes of the
|
reference. The corresponding code that is called in creating
|
reference. The corresponding code that is called in creating
|
global entities is parse.c.
|
global entities is parse.c.
|
|
|
In addition, for all but -std=legacy, the gsymbols are used to
|
In addition, for all but -std=legacy, the gsymbols are used to
|
check the interfaces of external procedures from the same file.
|
check the interfaces of external procedures from the same file.
|
The namespace of the gsymbol is resolved and then, once this is
|
The namespace of the gsymbol is resolved and then, once this is
|
done the interface is checked. */
|
done the interface is checked. */
|
|
|
|
|
static bool
|
static bool
|
not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
|
not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
|
{
|
{
|
if (!gsym_ns->proc_name->attr.recursive)
|
if (!gsym_ns->proc_name->attr.recursive)
|
return true;
|
return true;
|
|
|
if (sym->ns == gsym_ns)
|
if (sym->ns == gsym_ns)
|
return false;
|
return false;
|
|
|
if (sym->ns->parent && sym->ns->parent == gsym_ns)
|
if (sym->ns->parent && sym->ns->parent == gsym_ns)
|
return false;
|
return false;
|
|
|
return true;
|
return true;
|
}
|
}
|
|
|
static bool
|
static bool
|
not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
|
not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
|
{
|
{
|
if (gsym_ns->entries)
|
if (gsym_ns->entries)
|
{
|
{
|
gfc_entry_list *entry = gsym_ns->entries;
|
gfc_entry_list *entry = gsym_ns->entries;
|
|
|
for (; entry; entry = entry->next)
|
for (; entry; entry = entry->next)
|
{
|
{
|
if (strcmp (sym->name, entry->sym->name) == 0)
|
if (strcmp (sym->name, entry->sym->name) == 0)
|
{
|
{
|
if (strcmp (gsym_ns->proc_name->name,
|
if (strcmp (gsym_ns->proc_name->name,
|
sym->ns->proc_name->name) == 0)
|
sym->ns->proc_name->name) == 0)
|
return false;
|
return false;
|
|
|
if (sym->ns->parent
|
if (sym->ns->parent
|
&& strcmp (gsym_ns->proc_name->name,
|
&& strcmp (gsym_ns->proc_name->name,
|
sym->ns->parent->proc_name->name) == 0)
|
sym->ns->parent->proc_name->name) == 0)
|
return false;
|
return false;
|
}
|
}
|
}
|
}
|
}
|
}
|
return true;
|
return true;
|
}
|
}
|
|
|
static void
|
static void
|
resolve_global_procedure (gfc_symbol *sym, locus *where,
|
resolve_global_procedure (gfc_symbol *sym, locus *where,
|
gfc_actual_arglist **actual, int sub)
|
gfc_actual_arglist **actual, int sub)
|
{
|
{
|
gfc_gsymbol * gsym;
|
gfc_gsymbol * gsym;
|
gfc_namespace *ns;
|
gfc_namespace *ns;
|
enum gfc_symbol_type type;
|
enum gfc_symbol_type type;
|
|
|
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
|
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
|
|
|
gsym = gfc_get_gsymbol (sym->name);
|
gsym = gfc_get_gsymbol (sym->name);
|
|
|
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
|
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
|
gfc_global_used (gsym, where);
|
gfc_global_used (gsym, where);
|
|
|
if (gfc_option.flag_whole_file
|
if (gfc_option.flag_whole_file
|
&& sym->attr.if_source == IFSRC_UNKNOWN
|
&& sym->attr.if_source == IFSRC_UNKNOWN
|
&& gsym->type != GSYM_UNKNOWN
|
&& gsym->type != GSYM_UNKNOWN
|
&& gsym->ns
|
&& gsym->ns
|
&& gsym->ns->resolved != -1
|
&& gsym->ns->resolved != -1
|
&& gsym->ns->proc_name
|
&& gsym->ns->proc_name
|
&& not_in_recursive (sym, gsym->ns)
|
&& not_in_recursive (sym, gsym->ns)
|
&& not_entry_self_reference (sym, gsym->ns))
|
&& not_entry_self_reference (sym, gsym->ns))
|
{
|
{
|
/* Resolve the gsymbol namespace if needed. */
|
/* Resolve the gsymbol namespace if needed. */
|
if (!gsym->ns->resolved)
|
if (!gsym->ns->resolved)
|
{
|
{
|
gfc_dt_list *old_dt_list;
|
gfc_dt_list *old_dt_list;
|
|
|
/* Stash away derived types so that the backend_decls do not
|
/* Stash away derived types so that the backend_decls do not
|
get mixed up. */
|
get mixed up. */
|
old_dt_list = gfc_derived_types;
|
old_dt_list = gfc_derived_types;
|
gfc_derived_types = NULL;
|
gfc_derived_types = NULL;
|
|
|
gfc_resolve (gsym->ns);
|
gfc_resolve (gsym->ns);
|
|
|
/* Store the new derived types with the global namespace. */
|
/* Store the new derived types with the global namespace. */
|
if (gfc_derived_types)
|
if (gfc_derived_types)
|
gsym->ns->derived_types = gfc_derived_types;
|
gsym->ns->derived_types = gfc_derived_types;
|
|
|
/* Restore the derived types of this namespace. */
|
/* Restore the derived types of this namespace. */
|
gfc_derived_types = old_dt_list;
|
gfc_derived_types = old_dt_list;
|
}
|
}
|
|
|
/* Make sure that translation for the gsymbol occurs before
|
/* Make sure that translation for the gsymbol occurs before
|
the procedure currently being resolved. */
|
the procedure currently being resolved. */
|
ns = gfc_global_ns_list;
|
ns = gfc_global_ns_list;
|
for (; ns && ns != gsym->ns; ns = ns->sibling)
|
for (; ns && ns != gsym->ns; ns = ns->sibling)
|
{
|
{
|
if (ns->sibling == gsym->ns)
|
if (ns->sibling == gsym->ns)
|
{
|
{
|
ns->sibling = gsym->ns->sibling;
|
ns->sibling = gsym->ns->sibling;
|
gsym->ns->sibling = gfc_global_ns_list;
|
gsym->ns->sibling = gfc_global_ns_list;
|
gfc_global_ns_list = gsym->ns;
|
gfc_global_ns_list = gsym->ns;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
/* Differences in constant character lengths. */
|
/* Differences in constant character lengths. */
|
if (sym->attr.function && sym->ts.type == BT_CHARACTER)
|
if (sym->attr.function && sym->ts.type == BT_CHARACTER)
|
{
|
{
|
long int l1 = 0, l2 = 0;
|
long int l1 = 0, l2 = 0;
|
gfc_charlen *cl1 = sym->ts.u.cl;
|
gfc_charlen *cl1 = sym->ts.u.cl;
|
gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl;
|
gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl;
|
|
|
if (cl1 != NULL
|
if (cl1 != NULL
|
&& cl1->length != NULL
|
&& cl1->length != NULL
|
&& cl1->length->expr_type == EXPR_CONSTANT)
|
&& cl1->length->expr_type == EXPR_CONSTANT)
|
l1 = mpz_get_si (cl1->length->value.integer);
|
l1 = mpz_get_si (cl1->length->value.integer);
|
|
|
if (cl2 != NULL
|
if (cl2 != NULL
|
&& cl2->length != NULL
|
&& cl2->length != NULL
|
&& cl2->length->expr_type == EXPR_CONSTANT)
|
&& cl2->length->expr_type == EXPR_CONSTANT)
|
l2 = mpz_get_si (cl2->length->value.integer);
|
l2 = mpz_get_si (cl2->length->value.integer);
|
|
|
if (l1 && l2 && l1 != l2)
|
if (l1 && l2 && l1 != l2)
|
gfc_error ("Character length mismatch in return type of "
|
gfc_error ("Character length mismatch in return type of "
|
"function '%s' at %L (%ld/%ld)", sym->name,
|
"function '%s' at %L (%ld/%ld)", sym->name,
|
&sym->declared_at, l1, l2);
|
&sym->declared_at, l1, l2);
|
}
|
}
|
|
|
/* Type mismatch of function return type and expected type. */
|
/* Type mismatch of function return type and expected type. */
|
if (sym->attr.function
|
if (sym->attr.function
|
&& !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts))
|
&& !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts))
|
gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
|
gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
|
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
|
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
|
gfc_typename (&gsym->ns->proc_name->ts));
|
gfc_typename (&gsym->ns->proc_name->ts));
|
|
|
if (gsym->ns->proc_name->formal)
|
if (gsym->ns->proc_name->formal)
|
{
|
{
|
gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
|
gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
|
for ( ; arg; arg = arg->next)
|
for ( ; arg; arg = arg->next)
|
if (!arg->sym)
|
if (!arg->sym)
|
continue;
|
continue;
|
/* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
|
/* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
|
else if (arg->sym->attr.allocatable
|
else if (arg->sym->attr.allocatable
|
|| arg->sym->attr.asynchronous
|
|| arg->sym->attr.asynchronous
|
|| arg->sym->attr.optional
|
|| arg->sym->attr.optional
|
|| arg->sym->attr.pointer
|
|| arg->sym->attr.pointer
|
|| arg->sym->attr.target
|
|| arg->sym->attr.target
|
|| arg->sym->attr.value
|
|| arg->sym->attr.value
|
|| arg->sym->attr.volatile_)
|
|| arg->sym->attr.volatile_)
|
{
|
{
|
gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
|
gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
|
"has an attribute that requires an explicit "
|
"has an attribute that requires an explicit "
|
"interface for this procedure", arg->sym->name,
|
"interface for this procedure", arg->sym->name,
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
break;
|
break;
|
}
|
}
|
/* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
|
/* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
|
else if (arg->sym && arg->sym->as
|
else if (arg->sym && arg->sym->as
|
&& arg->sym->as->type == AS_ASSUMED_SHAPE)
|
&& arg->sym->as->type == AS_ASSUMED_SHAPE)
|
{
|
{
|
gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
|
gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
|
"argument '%s' must have an explicit interface",
|
"argument '%s' must have an explicit interface",
|
sym->name, &sym->declared_at, arg->sym->name);
|
sym->name, &sym->declared_at, arg->sym->name);
|
break;
|
break;
|
}
|
}
|
/* F2008, 12.4.2.2 (2c) */
|
/* F2008, 12.4.2.2 (2c) */
|
else if (false) /* TODO: is co-array */
|
else if (false) /* TODO: is co-array */
|
{
|
{
|
gfc_error ("Procedure '%s' at %L with coarray dummy argument "
|
gfc_error ("Procedure '%s' at %L with coarray dummy argument "
|
"'%s' must have an explicit interface",
|
"'%s' must have an explicit interface",
|
sym->name, &sym->declared_at, arg->sym->name);
|
sym->name, &sym->declared_at, arg->sym->name);
|
break;
|
break;
|
}
|
}
|
/* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
|
/* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
|
else if (false) /* TODO: is a parametrized derived type */
|
else if (false) /* TODO: is a parametrized derived type */
|
{
|
{
|
gfc_error ("Procedure '%s' at %L with parametrized derived "
|
gfc_error ("Procedure '%s' at %L with parametrized derived "
|
"type argument '%s' must have an explicit "
|
"type argument '%s' must have an explicit "
|
"interface", sym->name, &sym->declared_at,
|
"interface", sym->name, &sym->declared_at,
|
arg->sym->name);
|
arg->sym->name);
|
break;
|
break;
|
}
|
}
|
/* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
|
/* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
|
else if (arg->sym->ts.type == BT_CLASS)
|
else if (arg->sym->ts.type == BT_CLASS)
|
{
|
{
|
gfc_error ("Procedure '%s' at %L with polymorphic dummy "
|
gfc_error ("Procedure '%s' at %L with polymorphic dummy "
|
"argument '%s' must have an explicit interface",
|
"argument '%s' must have an explicit interface",
|
sym->name, &sym->declared_at, arg->sym->name);
|
sym->name, &sym->declared_at, arg->sym->name);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
if (gsym->ns->proc_name->attr.function)
|
if (gsym->ns->proc_name->attr.function)
|
{
|
{
|
/* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
|
/* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
|
if (gsym->ns->proc_name->as
|
if (gsym->ns->proc_name->as
|
&& gsym->ns->proc_name->as->rank
|
&& gsym->ns->proc_name->as->rank
|
&& (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
|
&& (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
|
gfc_error ("The reference to function '%s' at %L either needs an "
|
gfc_error ("The reference to function '%s' at %L either needs an "
|
"explicit INTERFACE or the rank is incorrect", sym->name,
|
"explicit INTERFACE or the rank is incorrect", sym->name,
|
where);
|
where);
|
|
|
/* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
|
/* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
|
if (gsym->ns->proc_name->result->attr.pointer
|
if (gsym->ns->proc_name->result->attr.pointer
|
|| gsym->ns->proc_name->result->attr.allocatable)
|
|| gsym->ns->proc_name->result->attr.allocatable)
|
gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
|
gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
|
"result must have an explicit interface", sym->name,
|
"result must have an explicit interface", sym->name,
|
where);
|
where);
|
|
|
/* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
|
/* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
|
if (sym->ts.type == BT_CHARACTER
|
if (sym->ts.type == BT_CHARACTER
|
&& gsym->ns->proc_name->ts.u.cl->length != NULL)
|
&& gsym->ns->proc_name->ts.u.cl->length != NULL)
|
{
|
{
|
gfc_charlen *cl = sym->ts.u.cl;
|
gfc_charlen *cl = sym->ts.u.cl;
|
|
|
if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
|
if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
|
&& cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
|
&& cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("Nonconstant character-length function '%s' at %L "
|
gfc_error ("Nonconstant character-length function '%s' at %L "
|
"must have an explicit interface", sym->name,
|
"must have an explicit interface", sym->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
|
/* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
|
if (gsym->ns->proc_name->attr.elemental)
|
if (gsym->ns->proc_name->attr.elemental)
|
{
|
{
|
gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
|
gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
|
"interface", sym->name, &sym->declared_at);
|
"interface", sym->name, &sym->declared_at);
|
}
|
}
|
|
|
/* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
|
/* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
|
if (gsym->ns->proc_name->attr.is_bind_c)
|
if (gsym->ns->proc_name->attr.is_bind_c)
|
{
|
{
|
gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
|
gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
|
"an explicit interface", sym->name, &sym->declared_at);
|
"an explicit interface", sym->name, &sym->declared_at);
|
}
|
}
|
|
|
if (gfc_option.flag_whole_file == 1
|
if (gfc_option.flag_whole_file == 1
|
|| ((gfc_option.warn_std & GFC_STD_LEGACY)
|
|| ((gfc_option.warn_std & GFC_STD_LEGACY)
|
&& !(gfc_option.warn_std & GFC_STD_GNU)))
|
&& !(gfc_option.warn_std & GFC_STD_GNU)))
|
gfc_errors_to_warnings (1);
|
gfc_errors_to_warnings (1);
|
|
|
gfc_procedure_use (gsym->ns->proc_name, actual, where);
|
gfc_procedure_use (gsym->ns->proc_name, actual, where);
|
|
|
gfc_errors_to_warnings (0);
|
gfc_errors_to_warnings (0);
|
}
|
}
|
|
|
if (gsym->type == GSYM_UNKNOWN)
|
if (gsym->type == GSYM_UNKNOWN)
|
{
|
{
|
gsym->type = type;
|
gsym->type = type;
|
gsym->where = *where;
|
gsym->where = *where;
|
}
|
}
|
|
|
gsym->used = 1;
|
gsym->used = 1;
|
}
|
}
|
|
|
|
|
/************* Function resolution *************/
|
/************* Function resolution *************/
|
|
|
/* Resolve a function call known to be generic.
|
/* Resolve a function call known to be generic.
|
Section 14.1.2.4.1. */
|
Section 14.1.2.4.1. */
|
|
|
static match
|
static match
|
resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
|
resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
|
{
|
{
|
gfc_symbol *s;
|
gfc_symbol *s;
|
|
|
if (sym->attr.generic)
|
if (sym->attr.generic)
|
{
|
{
|
s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
|
s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
|
if (s != NULL)
|
if (s != NULL)
|
{
|
{
|
expr->value.function.name = s->name;
|
expr->value.function.name = s->name;
|
expr->value.function.esym = s;
|
expr->value.function.esym = s;
|
|
|
if (s->ts.type != BT_UNKNOWN)
|
if (s->ts.type != BT_UNKNOWN)
|
expr->ts = s->ts;
|
expr->ts = s->ts;
|
else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
|
else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
|
expr->ts = s->result->ts;
|
expr->ts = s->result->ts;
|
|
|
if (s->as != NULL)
|
if (s->as != NULL)
|
expr->rank = s->as->rank;
|
expr->rank = s->as->rank;
|
else if (s->result != NULL && s->result->as != NULL)
|
else if (s->result != NULL && s->result->as != NULL)
|
expr->rank = s->result->as->rank;
|
expr->rank = s->result->as->rank;
|
|
|
gfc_set_sym_referenced (expr->value.function.esym);
|
gfc_set_sym_referenced (expr->value.function.esym);
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
/* TODO: Need to search for elemental references in generic
|
/* TODO: Need to search for elemental references in generic
|
interface. */
|
interface. */
|
}
|
}
|
|
|
if (sym->attr.intrinsic)
|
if (sym->attr.intrinsic)
|
return gfc_intrinsic_func_interface (expr, 0);
|
return gfc_intrinsic_func_interface (expr, 0);
|
|
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
resolve_generic_f (gfc_expr *expr)
|
resolve_generic_f (gfc_expr *expr)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
match m;
|
match m;
|
|
|
sym = expr->symtree->n.sym;
|
sym = expr->symtree->n.sym;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
m = resolve_generic_f0 (expr, sym);
|
m = resolve_generic_f0 (expr, sym);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
return SUCCESS;
|
return SUCCESS;
|
else if (m == MATCH_ERROR)
|
else if (m == MATCH_ERROR)
|
return FAILURE;
|
return FAILURE;
|
|
|
generic:
|
generic:
|
if (sym->ns->parent == NULL)
|
if (sym->ns->parent == NULL)
|
break;
|
break;
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
break;
|
break;
|
if (!generic_sym (sym))
|
if (!generic_sym (sym))
|
goto generic;
|
goto generic;
|
}
|
}
|
|
|
/* Last ditch attempt. See if the reference is to an intrinsic
|
/* Last ditch attempt. See if the reference is to an intrinsic
|
that possesses a matching interface. 14.1.2.4 */
|
that possesses a matching interface. 14.1.2.4 */
|
if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
|
if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
|
{
|
{
|
gfc_error ("There is no specific function for the generic '%s' at %L",
|
gfc_error ("There is no specific function for the generic '%s' at %L",
|
expr->symtree->n.sym->name, &expr->where);
|
expr->symtree->n.sym->name, &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
m = gfc_intrinsic_func_interface (expr, 0);
|
m = gfc_intrinsic_func_interface (expr, 0);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
return SUCCESS;
|
return SUCCESS;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Generic function '%s' at %L is not consistent with a "
|
gfc_error ("Generic function '%s' at %L is not consistent with a "
|
"specific intrinsic interface", expr->symtree->n.sym->name,
|
"specific intrinsic interface", expr->symtree->n.sym->name,
|
&expr->where);
|
&expr->where);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Resolve a function call known to be specific. */
|
/* Resolve a function call known to be specific. */
|
|
|
static match
|
static match
|
resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
|
resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
|
{
|
{
|
match m;
|
match m;
|
|
|
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
|
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
|
{
|
{
|
if (sym->attr.dummy)
|
if (sym->attr.dummy)
|
{
|
{
|
sym->attr.proc = PROC_DUMMY;
|
sym->attr.proc = PROC_DUMMY;
|
goto found;
|
goto found;
|
}
|
}
|
|
|
sym->attr.proc = PROC_EXTERNAL;
|
sym->attr.proc = PROC_EXTERNAL;
|
goto found;
|
goto found;
|
}
|
}
|
|
|
if (sym->attr.proc == PROC_MODULE
|
if (sym->attr.proc == PROC_MODULE
|
|| sym->attr.proc == PROC_ST_FUNCTION
|
|| sym->attr.proc == PROC_ST_FUNCTION
|
|| sym->attr.proc == PROC_INTERNAL)
|
|| sym->attr.proc == PROC_INTERNAL)
|
goto found;
|
goto found;
|
|
|
if (sym->attr.intrinsic)
|
if (sym->attr.intrinsic)
|
{
|
{
|
m = gfc_intrinsic_func_interface (expr, 1);
|
m = gfc_intrinsic_func_interface (expr, 1);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
return MATCH_YES;
|
return MATCH_YES;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
|
gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
|
"with an intrinsic", sym->name, &expr->where);
|
"with an intrinsic", sym->name, &expr->where);
|
|
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
found:
|
found:
|
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
|
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
|
|
|
if (sym->result)
|
if (sym->result)
|
expr->ts = sym->result->ts;
|
expr->ts = sym->result->ts;
|
else
|
else
|
expr->ts = sym->ts;
|
expr->ts = sym->ts;
|
expr->value.function.name = sym->name;
|
expr->value.function.name = sym->name;
|
expr->value.function.esym = sym;
|
expr->value.function.esym = sym;
|
if (sym->as != NULL)
|
if (sym->as != NULL)
|
expr->rank = sym->as->rank;
|
expr->rank = sym->as->rank;
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
resolve_specific_f (gfc_expr *expr)
|
resolve_specific_f (gfc_expr *expr)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
match m;
|
match m;
|
|
|
sym = expr->symtree->n.sym;
|
sym = expr->symtree->n.sym;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
m = resolve_specific_f0 (sym, expr);
|
m = resolve_specific_f0 (sym, expr);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
return SUCCESS;
|
return SUCCESS;
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (sym->ns->parent == NULL)
|
if (sym->ns->parent == NULL)
|
break;
|
break;
|
|
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
break;
|
break;
|
}
|
}
|
|
|
gfc_error ("Unable to resolve the specific function '%s' at %L",
|
gfc_error ("Unable to resolve the specific function '%s' at %L",
|
expr->symtree->n.sym->name, &expr->where);
|
expr->symtree->n.sym->name, &expr->where);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a procedure call not known to be generic nor specific. */
|
/* Resolve a procedure call not known to be generic nor specific. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_unknown_f (gfc_expr *expr)
|
resolve_unknown_f (gfc_expr *expr)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_typespec *ts;
|
gfc_typespec *ts;
|
|
|
sym = expr->symtree->n.sym;
|
sym = expr->symtree->n.sym;
|
|
|
if (sym->attr.dummy)
|
if (sym->attr.dummy)
|
{
|
{
|
sym->attr.proc = PROC_DUMMY;
|
sym->attr.proc = PROC_DUMMY;
|
expr->value.function.name = sym->name;
|
expr->value.function.name = sym->name;
|
goto set_type;
|
goto set_type;
|
}
|
}
|
|
|
/* See if we have an intrinsic function reference. */
|
/* See if we have an intrinsic function reference. */
|
|
|
if (gfc_is_intrinsic (sym, 0, expr->where))
|
if (gfc_is_intrinsic (sym, 0, expr->where))
|
{
|
{
|
if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
|
if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
|
return SUCCESS;
|
return SUCCESS;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* The reference is to an external name. */
|
/* The reference is to an external name. */
|
|
|
sym->attr.proc = PROC_EXTERNAL;
|
sym->attr.proc = PROC_EXTERNAL;
|
expr->value.function.name = sym->name;
|
expr->value.function.name = sym->name;
|
expr->value.function.esym = expr->symtree->n.sym;
|
expr->value.function.esym = expr->symtree->n.sym;
|
|
|
if (sym->as != NULL)
|
if (sym->as != NULL)
|
expr->rank = sym->as->rank;
|
expr->rank = sym->as->rank;
|
|
|
/* Type of the expression is either the type of the symbol or the
|
/* Type of the expression is either the type of the symbol or the
|
default type of the symbol. */
|
default type of the symbol. */
|
|
|
set_type:
|
set_type:
|
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
|
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
|
|
|
if (sym->ts.type != BT_UNKNOWN)
|
if (sym->ts.type != BT_UNKNOWN)
|
expr->ts = sym->ts;
|
expr->ts = sym->ts;
|
else
|
else
|
{
|
{
|
ts = gfc_get_default_type (sym->name, sym->ns);
|
ts = gfc_get_default_type (sym->name, sym->ns);
|
|
|
if (ts->type == BT_UNKNOWN)
|
if (ts->type == BT_UNKNOWN)
|
{
|
{
|
gfc_error ("Function '%s' at %L has no IMPLICIT type",
|
gfc_error ("Function '%s' at %L has no IMPLICIT type",
|
sym->name, &expr->where);
|
sym->name, &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else
|
else
|
expr->ts = *ts;
|
expr->ts = *ts;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Return true, if the symbol is an external procedure. */
|
/* Return true, if the symbol is an external procedure. */
|
static bool
|
static bool
|
is_external_proc (gfc_symbol *sym)
|
is_external_proc (gfc_symbol *sym)
|
{
|
{
|
if (!sym->attr.dummy && !sym->attr.contained
|
if (!sym->attr.dummy && !sym->attr.contained
|
&& !(sym->attr.intrinsic
|
&& !(sym->attr.intrinsic
|
|| gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
|
|| gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
|
&& sym->attr.proc != PROC_ST_FUNCTION
|
&& sym->attr.proc != PROC_ST_FUNCTION
|
&& !sym->attr.use_assoc
|
&& !sym->attr.use_assoc
|
&& sym->name)
|
&& sym->name)
|
return true;
|
return true;
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
|
|
/* Figure out if a function reference is pure or not. Also set the name
|
/* 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
|
of the function for a potential error message. Return nonzero if the
|
function is PURE, zero if not. */
|
function is PURE, zero if not. */
|
static int
|
static int
|
pure_stmt_function (gfc_expr *, gfc_symbol *);
|
pure_stmt_function (gfc_expr *, gfc_symbol *);
|
|
|
static int
|
static int
|
pure_function (gfc_expr *e, const char **name)
|
pure_function (gfc_expr *e, const char **name)
|
{
|
{
|
int pure;
|
int pure;
|
|
|
*name = NULL;
|
*name = NULL;
|
|
|
if (e->symtree != NULL
|
if (e->symtree != NULL
|
&& e->symtree->n.sym != NULL
|
&& e->symtree->n.sym != NULL
|
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
|
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
|
return pure_stmt_function (e, e->symtree->n.sym);
|
return pure_stmt_function (e, e->symtree->n.sym);
|
|
|
if (e->value.function.esym)
|
if (e->value.function.esym)
|
{
|
{
|
pure = gfc_pure (e->value.function.esym);
|
pure = gfc_pure (e->value.function.esym);
|
*name = e->value.function.esym->name;
|
*name = e->value.function.esym->name;
|
}
|
}
|
else if (e->value.function.isym)
|
else if (e->value.function.isym)
|
{
|
{
|
pure = e->value.function.isym->pure
|
pure = e->value.function.isym->pure
|
|| e->value.function.isym->elemental;
|
|| e->value.function.isym->elemental;
|
*name = e->value.function.isym->name;
|
*name = e->value.function.isym->name;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Implicit functions are not pure. */
|
/* Implicit functions are not pure. */
|
pure = 0;
|
pure = 0;
|
*name = e->value.function.name;
|
*name = e->value.function.name;
|
}
|
}
|
|
|
return pure;
|
return pure;
|
}
|
}
|
|
|
|
|
static bool
|
static bool
|
impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
|
impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
|
int *f ATTRIBUTE_UNUSED)
|
int *f ATTRIBUTE_UNUSED)
|
{
|
{
|
const char *name;
|
const char *name;
|
|
|
/* Don't bother recursing into other statement functions
|
/* Don't bother recursing into other statement functions
|
since they will be checked individually for purity. */
|
since they will be checked individually for purity. */
|
if (e->expr_type != EXPR_FUNCTION
|
if (e->expr_type != EXPR_FUNCTION
|
|| !e->symtree
|
|| !e->symtree
|
|| e->symtree->n.sym == sym
|
|| e->symtree->n.sym == sym
|
|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
|
|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
|
return false;
|
return false;
|
|
|
return pure_function (e, &name) ? false : true;
|
return pure_function (e, &name) ? false : true;
|
}
|
}
|
|
|
|
|
static int
|
static int
|
pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
|
pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
|
{
|
{
|
return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
|
return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
is_scalar_expr_ptr (gfc_expr *expr)
|
is_scalar_expr_ptr (gfc_expr *expr)
|
{
|
{
|
gfc_try retval = SUCCESS;
|
gfc_try retval = SUCCESS;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
int start;
|
int start;
|
int end;
|
int end;
|
|
|
/* See if we have a gfc_ref, which means we have a substring, array
|
/* See if we have a gfc_ref, which means we have a substring, array
|
reference, or a component. */
|
reference, or a component. */
|
if (expr->ref != NULL)
|
if (expr->ref != NULL)
|
{
|
{
|
ref = expr->ref;
|
ref = expr->ref;
|
while (ref->next != NULL)
|
while (ref->next != NULL)
|
ref = ref->next;
|
ref = ref->next;
|
|
|
switch (ref->type)
|
switch (ref->type)
|
{
|
{
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
if (ref->u.ss.length != NULL
|
if (ref->u.ss.length != NULL
|
&& ref->u.ss.length->length != NULL
|
&& ref->u.ss.length->length != NULL
|
&& ref->u.ss.start
|
&& ref->u.ss.start
|
&& ref->u.ss.start->expr_type == EXPR_CONSTANT
|
&& ref->u.ss.start->expr_type == EXPR_CONSTANT
|
&& ref->u.ss.end
|
&& ref->u.ss.end
|
&& ref->u.ss.end->expr_type == EXPR_CONSTANT)
|
&& ref->u.ss.end->expr_type == EXPR_CONSTANT)
|
{
|
{
|
start = (int) mpz_get_si (ref->u.ss.start->value.integer);
|
start = (int) mpz_get_si (ref->u.ss.start->value.integer);
|
end = (int) mpz_get_si (ref->u.ss.end->value.integer);
|
end = (int) mpz_get_si (ref->u.ss.end->value.integer);
|
if (end - start + 1 != 1)
|
if (end - start + 1 != 1)
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
else
|
else
|
retval = FAILURE;
|
retval = FAILURE;
|
break;
|
break;
|
case REF_ARRAY:
|
case REF_ARRAY:
|
if (ref->u.ar.type == AR_ELEMENT)
|
if (ref->u.ar.type == AR_ELEMENT)
|
retval = SUCCESS;
|
retval = SUCCESS;
|
else if (ref->u.ar.type == AR_FULL)
|
else if (ref->u.ar.type == AR_FULL)
|
{
|
{
|
/* The user can give a full array if the array is of size 1. */
|
/* The user can give a full array if the array is of size 1. */
|
if (ref->u.ar.as != NULL
|
if (ref->u.ar.as != NULL
|
&& ref->u.ar.as->rank == 1
|
&& ref->u.ar.as->rank == 1
|
&& ref->u.ar.as->type == AS_EXPLICIT
|
&& ref->u.ar.as->type == AS_EXPLICIT
|
&& ref->u.ar.as->lower[0] != NULL
|
&& ref->u.ar.as->lower[0] != NULL
|
&& ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
|
&& ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
|
&& ref->u.ar.as->upper[0] != NULL
|
&& ref->u.ar.as->upper[0] != NULL
|
&& ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
|
&& ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
|
{
|
{
|
/* If we have a character string, we need to check if
|
/* If we have a character string, we need to check if
|
its length is one. */
|
its length is one. */
|
if (expr->ts.type == BT_CHARACTER)
|
if (expr->ts.type == BT_CHARACTER)
|
{
|
{
|
if (expr->ts.u.cl == NULL
|
if (expr->ts.u.cl == NULL
|
|| expr->ts.u.cl->length == NULL
|
|| expr->ts.u.cl->length == NULL
|
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
|
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
|
!= 0)
|
!= 0)
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* We have constant lower and upper bounds. If the
|
/* We have constant lower and upper bounds. If the
|
difference between is 1, it can be considered a
|
difference between is 1, it can be considered a
|
scalar. */
|
scalar. */
|
start = (int) mpz_get_si
|
start = (int) mpz_get_si
|
(ref->u.ar.as->lower[0]->value.integer);
|
(ref->u.ar.as->lower[0]->value.integer);
|
end = (int) mpz_get_si
|
end = (int) mpz_get_si
|
(ref->u.ar.as->upper[0]->value.integer);
|
(ref->u.ar.as->upper[0]->value.integer);
|
if (end - start + 1 != 1)
|
if (end - start + 1 != 1)
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
}
|
}
|
else
|
else
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
else
|
else
|
retval = FAILURE;
|
retval = FAILURE;
|
break;
|
break;
|
default:
|
default:
|
retval = SUCCESS;
|
retval = SUCCESS;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
|
else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
|
{
|
{
|
/* Character string. Make sure it's of length 1. */
|
/* Character string. Make sure it's of length 1. */
|
if (expr->ts.u.cl == NULL
|
if (expr->ts.u.cl == NULL
|
|| expr->ts.u.cl->length == NULL
|
|| expr->ts.u.cl->length == NULL
|
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
|
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
else if (expr->rank != 0)
|
else if (expr->rank != 0)
|
retval = FAILURE;
|
retval = FAILURE;
|
|
|
return retval;
|
return retval;
|
}
|
}
|
|
|
|
|
/* Match one of the iso_c_binding functions (c_associated or c_loc)
|
/* 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
|
and, in the case of c_associated, set the binding label based on
|
the arguments. */
|
the arguments. */
|
|
|
static gfc_try
|
static gfc_try
|
gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
|
gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
|
gfc_symbol **new_sym)
|
gfc_symbol **new_sym)
|
{
|
{
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
|
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
|
int optional_arg = 0, is_pointer = 0;
|
int optional_arg = 0, is_pointer = 0;
|
gfc_try retval = SUCCESS;
|
gfc_try retval = SUCCESS;
|
gfc_symbol *args_sym;
|
gfc_symbol *args_sym;
|
gfc_typespec *arg_ts;
|
gfc_typespec *arg_ts;
|
|
|
if (args->expr->expr_type == EXPR_CONSTANT
|
if (args->expr->expr_type == EXPR_CONSTANT
|
|| args->expr->expr_type == EXPR_OP
|
|| args->expr->expr_type == EXPR_OP
|
|| args->expr->expr_type == EXPR_NULL)
|
|| args->expr->expr_type == EXPR_NULL)
|
{
|
{
|
gfc_error ("Argument to '%s' at %L is not a variable",
|
gfc_error ("Argument to '%s' at %L is not a variable",
|
sym->name, &(args->expr->where));
|
sym->name, &(args->expr->where));
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
args_sym = args->expr->symtree->n.sym;
|
args_sym = args->expr->symtree->n.sym;
|
|
|
/* The typespec for the actual arg should be that stored in the expr
|
/* The typespec for the actual arg should be that stored in the expr
|
and not necessarily that of the expr symbol (args_sym), because
|
and not necessarily that of the expr symbol (args_sym), because
|
the actual expression could be a part-ref of the expr symbol. */
|
the actual expression could be a part-ref of the expr symbol. */
|
arg_ts = &(args->expr->ts);
|
arg_ts = &(args->expr->ts);
|
|
|
is_pointer = gfc_is_data_pointer (args->expr);
|
is_pointer = gfc_is_data_pointer (args->expr);
|
|
|
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
|
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
|
{
|
{
|
/* If the user gave two args then they are providing something for
|
/* If the user gave two args then they are providing something for
|
the optional arg (the second cptr). Therefore, set the name and
|
the optional arg (the second cptr). Therefore, set the name and
|
binding label to the c_associated for two cptrs. Otherwise,
|
binding label to the c_associated for two cptrs. Otherwise,
|
set c_associated to expect one cptr. */
|
set c_associated to expect one cptr. */
|
if (args->next)
|
if (args->next)
|
{
|
{
|
/* two args. */
|
/* two args. */
|
sprintf (name, "%s_2", sym->name);
|
sprintf (name, "%s_2", sym->name);
|
sprintf (binding_label, "%s_2", sym->binding_label);
|
sprintf (binding_label, "%s_2", sym->binding_label);
|
optional_arg = 1;
|
optional_arg = 1;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* one arg. */
|
/* one arg. */
|
sprintf (name, "%s_1", sym->name);
|
sprintf (name, "%s_1", sym->name);
|
sprintf (binding_label, "%s_1", sym->binding_label);
|
sprintf (binding_label, "%s_1", sym->binding_label);
|
optional_arg = 0;
|
optional_arg = 0;
|
}
|
}
|
|
|
/* Get a new symbol for the version of c_associated that
|
/* Get a new symbol for the version of c_associated that
|
will get called. */
|
will get called. */
|
*new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
|
*new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
|
}
|
}
|
else if (sym->intmod_sym_id == ISOCBINDING_LOC
|
else if (sym->intmod_sym_id == ISOCBINDING_LOC
|
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC)
|
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC)
|
{
|
{
|
sprintf (name, "%s", sym->name);
|
sprintf (name, "%s", sym->name);
|
sprintf (binding_label, "%s", sym->binding_label);
|
sprintf (binding_label, "%s", sym->binding_label);
|
|
|
/* Error check the call. */
|
/* Error check the call. */
|
if (args->next != NULL)
|
if (args->next != NULL)
|
{
|
{
|
gfc_error_now ("More actual than formal arguments in '%s' "
|
gfc_error_now ("More actual than formal arguments in '%s' "
|
"call at %L", name, &(args->expr->where));
|
"call at %L", name, &(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
|
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
|
{
|
{
|
/* Make sure we have either the target or pointer attribute. */
|
/* Make sure we have either the target or pointer attribute. */
|
if (!args_sym->attr.target && !is_pointer)
|
if (!args_sym->attr.target && !is_pointer)
|
{
|
{
|
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
|
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
|
"a TARGET or an associated pointer",
|
"a TARGET or an associated pointer",
|
args_sym->name,
|
args_sym->name,
|
sym->name, &(args->expr->where));
|
sym->name, &(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
|
|
/* See if we have interoperable type and type param. */
|
/* See if we have interoperable type and type param. */
|
if (verify_c_interop (arg_ts) == SUCCESS
|
if (verify_c_interop (arg_ts) == SUCCESS
|
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
|
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
|
{
|
{
|
if (args_sym->attr.target == 1)
|
if (args_sym->attr.target == 1)
|
{
|
{
|
/* Case 1a, section 15.1.2.5, J3/04-007: variable that
|
/* Case 1a, section 15.1.2.5, J3/04-007: variable that
|
has the target attribute and is interoperable. */
|
has the target attribute and is interoperable. */
|
/* Case 1b, section 15.1.2.5, J3/04-007: allocated
|
/* Case 1b, section 15.1.2.5, J3/04-007: allocated
|
allocatable variable that has the TARGET attribute and
|
allocatable variable that has the TARGET attribute and
|
is not an array of zero size. */
|
is not an array of zero size. */
|
if (args_sym->attr.allocatable == 1)
|
if (args_sym->attr.allocatable == 1)
|
{
|
{
|
if (args_sym->attr.dimension != 0
|
if (args_sym->attr.dimension != 0
|
&& (args_sym->as && args_sym->as->rank == 0))
|
&& (args_sym->as && args_sym->as->rank == 0))
|
{
|
{
|
gfc_error_now ("Allocatable variable '%s' used as a "
|
gfc_error_now ("Allocatable variable '%s' used as a "
|
"parameter to '%s' at %L must not be "
|
"parameter to '%s' at %L must not be "
|
"an array of zero size",
|
"an array of zero size",
|
args_sym->name, sym->name,
|
args_sym->name, sym->name,
|
&(args->expr->where));
|
&(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
/* A non-allocatable target variable with C
|
/* A non-allocatable target variable with C
|
interoperable type and type parameters must be
|
interoperable type and type parameters must be
|
interoperable. */
|
interoperable. */
|
if (args_sym && args_sym->attr.dimension)
|
if (args_sym && args_sym->attr.dimension)
|
{
|
{
|
if (args_sym->as->type == AS_ASSUMED_SHAPE)
|
if (args_sym->as->type == AS_ASSUMED_SHAPE)
|
{
|
{
|
gfc_error ("Assumed-shape array '%s' at %L "
|
gfc_error ("Assumed-shape array '%s' at %L "
|
"cannot be an argument to the "
|
"cannot be an argument to the "
|
"procedure '%s' because "
|
"procedure '%s' because "
|
"it is not C interoperable",
|
"it is not C interoperable",
|
args_sym->name,
|
args_sym->name,
|
&(args->expr->where), sym->name);
|
&(args->expr->where), sym->name);
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
else if (args_sym->as->type == AS_DEFERRED)
|
else if (args_sym->as->type == AS_DEFERRED)
|
{
|
{
|
gfc_error ("Deferred-shape array '%s' at %L "
|
gfc_error ("Deferred-shape array '%s' at %L "
|
"cannot be an argument to the "
|
"cannot be an argument to the "
|
"procedure '%s' because "
|
"procedure '%s' because "
|
"it is not C interoperable",
|
"it is not C interoperable",
|
args_sym->name,
|
args_sym->name,
|
&(args->expr->where), sym->name);
|
&(args->expr->where), sym->name);
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Make sure it's not a character string. Arrays of
|
/* Make sure it's not a character string. Arrays of
|
any type should be ok if the variable is of a C
|
any type should be ok if the variable is of a C
|
interoperable type. */
|
interoperable type. */
|
if (arg_ts->type == BT_CHARACTER)
|
if (arg_ts->type == BT_CHARACTER)
|
if (arg_ts->u.cl != NULL
|
if (arg_ts->u.cl != NULL
|
&& (arg_ts->u.cl->length == NULL
|
&& (arg_ts->u.cl->length == NULL
|
|| arg_ts->u.cl->length->expr_type
|
|| arg_ts->u.cl->length->expr_type
|
!= EXPR_CONSTANT
|
!= EXPR_CONSTANT
|
|| mpz_cmp_si
|
|| mpz_cmp_si
|
(arg_ts->u.cl->length->value.integer, 1)
|
(arg_ts->u.cl->length->value.integer, 1)
|
!= 0)
|
!= 0)
|
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
|
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
|
{
|
{
|
gfc_error_now ("CHARACTER argument '%s' to '%s' "
|
gfc_error_now ("CHARACTER argument '%s' to '%s' "
|
"at %L must have a length of 1",
|
"at %L must have a length of 1",
|
args_sym->name, sym->name,
|
args_sym->name, sym->name,
|
&(args->expr->where));
|
&(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
else if (is_pointer
|
else if (is_pointer
|
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
|
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
|
{
|
{
|
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
|
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
|
scalar pointer. */
|
scalar pointer. */
|
gfc_error_now ("Argument '%s' to '%s' at %L must be an "
|
gfc_error_now ("Argument '%s' to '%s' at %L must be an "
|
"associated scalar POINTER", args_sym->name,
|
"associated scalar POINTER", args_sym->name,
|
sym->name, &(args->expr->where));
|
sym->name, &(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
/* The parameter is not required to be C interoperable. If it
|
/* The parameter is not required to be C interoperable. If it
|
is not C interoperable, it must be a nonpolymorphic scalar
|
is not C interoperable, it must be a nonpolymorphic scalar
|
with no length type parameters. It still must have either
|
with no length type parameters. It still must have either
|
the pointer or target attribute, and it can be
|
the pointer or target attribute, and it can be
|
allocatable (but must be allocated when c_loc is called). */
|
allocatable (but must be allocated when c_loc is called). */
|
if (args->expr->rank != 0
|
if (args->expr->rank != 0
|
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
|
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
|
{
|
{
|
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
|
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
|
"scalar", args_sym->name, sym->name,
|
"scalar", args_sym->name, sym->name,
|
&(args->expr->where));
|
&(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
else if (arg_ts->type == BT_CHARACTER
|
else if (arg_ts->type == BT_CHARACTER
|
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
|
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
|
{
|
{
|
gfc_error_now ("CHARACTER argument '%s' to '%s' at "
|
gfc_error_now ("CHARACTER argument '%s' to '%s' at "
|
"%L must have a length of 1",
|
"%L must have a length of 1",
|
args_sym->name, sym->name,
|
args_sym->name, sym->name,
|
&(args->expr->where));
|
&(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
|
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
|
{
|
{
|
if (args_sym->attr.flavor != FL_PROCEDURE)
|
if (args_sym->attr.flavor != FL_PROCEDURE)
|
{
|
{
|
/* TODO: Update this error message to allow for procedure
|
/* TODO: Update this error message to allow for procedure
|
pointers once they are implemented. */
|
pointers once they are implemented. */
|
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
|
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
|
"procedure",
|
"procedure",
|
args_sym->name, sym->name,
|
args_sym->name, sym->name,
|
&(args->expr->where));
|
&(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
else if (args_sym->attr.is_bind_c != 1)
|
else if (args_sym->attr.is_bind_c != 1)
|
{
|
{
|
gfc_error_now ("Parameter '%s' to '%s' at %L must be "
|
gfc_error_now ("Parameter '%s' to '%s' at %L must be "
|
"BIND(C)",
|
"BIND(C)",
|
args_sym->name, sym->name,
|
args_sym->name, sym->name,
|
&(args->expr->where));
|
&(args->expr->where));
|
retval = FAILURE;
|
retval = FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* for c_loc/c_funloc, the new symbol is the same as the old one */
|
/* for c_loc/c_funloc, the new symbol is the same as the old one */
|
*new_sym = sym;
|
*new_sym = sym;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
|
gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
|
"iso_c_binding function: '%s'!\n", sym->name);
|
"iso_c_binding function: '%s'!\n", sym->name);
|
}
|
}
|
|
|
return retval;
|
return retval;
|
}
|
}
|
|
|
|
|
/* Resolve a function call, which means resolving the arguments, then figuring
|
/* Resolve a function call, which means resolving the arguments, then figuring
|
out which entity the name refers to. */
|
out which entity the name refers to. */
|
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
|
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
|
to INTENT(OUT) or INTENT(INOUT). */
|
to INTENT(OUT) or INTENT(INOUT). */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_function (gfc_expr *expr)
|
resolve_function (gfc_expr *expr)
|
{
|
{
|
gfc_actual_arglist *arg;
|
gfc_actual_arglist *arg;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
const char *name;
|
const char *name;
|
gfc_try t;
|
gfc_try t;
|
int temp;
|
int temp;
|
procedure_type p = PROC_INTRINSIC;
|
procedure_type p = PROC_INTRINSIC;
|
bool no_formal_args;
|
bool no_formal_args;
|
|
|
sym = NULL;
|
sym = NULL;
|
if (expr->symtree)
|
if (expr->symtree)
|
sym = expr->symtree->n.sym;
|
sym = expr->symtree->n.sym;
|
|
|
/* If this is a procedure pointer component, it has already been resolved. */
|
/* If this is a procedure pointer component, it has already been resolved. */
|
if (gfc_is_proc_ptr_comp (expr, NULL))
|
if (gfc_is_proc_ptr_comp (expr, NULL))
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (sym && sym->attr.intrinsic
|
if (sym && sym->attr.intrinsic
|
&& resolve_intrinsic (sym, &expr->where) == FAILURE)
|
&& resolve_intrinsic (sym, &expr->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
|
if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
|
{
|
{
|
gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
|
gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* If this ia a deferred TBP with an abstract interface (which may
|
/* If this ia a deferred TBP with an abstract interface (which may
|
of course be referenced), expr->value.function.esym will be set. */
|
of course be referenced), expr->value.function.esym will be set. */
|
if (sym && sym->attr.abstract && !expr->value.function.esym)
|
if (sym && sym->attr.abstract && !expr->value.function.esym)
|
{
|
{
|
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
|
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
|
sym->name, &expr->where);
|
sym->name, &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Switch off assumed size checking and do this again for certain kinds
|
/* Switch off assumed size checking and do this again for certain kinds
|
of procedure, once the procedure itself is resolved. */
|
of procedure, once the procedure itself is resolved. */
|
need_full_assumed_size++;
|
need_full_assumed_size++;
|
|
|
if (expr->symtree && expr->symtree->n.sym)
|
if (expr->symtree && expr->symtree->n.sym)
|
p = expr->symtree->n.sym->attr.proc;
|
p = expr->symtree->n.sym->attr.proc;
|
|
|
no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
|
no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
|
if (resolve_actual_arglist (expr->value.function.actual,
|
if (resolve_actual_arglist (expr->value.function.actual,
|
p, no_formal_args) == FAILURE)
|
p, no_formal_args) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Need to setup the call to the correct c_associated, depending on
|
/* Need to setup the call to the correct c_associated, depending on
|
the number of cptrs to user gives to compare. */
|
the number of cptrs to user gives to compare. */
|
if (sym && sym->attr.is_iso_c == 1)
|
if (sym && sym->attr.is_iso_c == 1)
|
{
|
{
|
if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
|
if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
|
== FAILURE)
|
== FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Get the symtree for the new symbol (resolved func).
|
/* Get the symtree for the new symbol (resolved func).
|
the old one will be freed later, when it's no longer used. */
|
the old one will be freed later, when it's no longer used. */
|
gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
|
gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
|
}
|
}
|
|
|
/* Resume assumed_size checking. */
|
/* Resume assumed_size checking. */
|
need_full_assumed_size--;
|
need_full_assumed_size--;
|
|
|
/* If the procedure is external, check for usage. */
|
/* If the procedure is external, check for usage. */
|
if (sym && is_external_proc (sym))
|
if (sym && is_external_proc (sym))
|
resolve_global_procedure (sym, &expr->where,
|
resolve_global_procedure (sym, &expr->where,
|
&expr->value.function.actual, 0);
|
&expr->value.function.actual, 0);
|
|
|
if (sym && sym->ts.type == BT_CHARACTER
|
if (sym && sym->ts.type == BT_CHARACTER
|
&& sym->ts.u.cl
|
&& sym->ts.u.cl
|
&& sym->ts.u.cl->length == NULL
|
&& sym->ts.u.cl->length == NULL
|
&& !sym->attr.dummy
|
&& !sym->attr.dummy
|
&& expr->value.function.esym == NULL
|
&& expr->value.function.esym == NULL
|
&& !sym->attr.contained)
|
&& !sym->attr.contained)
|
{
|
{
|
/* Internal procedures are taken care of in resolve_contained_fntype. */
|
/* Internal procedures are taken care of in resolve_contained_fntype. */
|
gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
|
gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
|
"be used at %L since it is not a dummy argument",
|
"be used at %L since it is not a dummy argument",
|
sym->name, &expr->where);
|
sym->name, &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* See if function is already resolved. */
|
/* See if function is already resolved. */
|
|
|
if (expr->value.function.name != NULL)
|
if (expr->value.function.name != NULL)
|
{
|
{
|
if (expr->ts.type == BT_UNKNOWN)
|
if (expr->ts.type == BT_UNKNOWN)
|
expr->ts = sym->ts;
|
expr->ts = sym->ts;
|
t = SUCCESS;
|
t = SUCCESS;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Apply the rules of section 14.1.2. */
|
/* Apply the rules of section 14.1.2. */
|
|
|
switch (procedure_kind (sym))
|
switch (procedure_kind (sym))
|
{
|
{
|
case PTYPE_GENERIC:
|
case PTYPE_GENERIC:
|
t = resolve_generic_f (expr);
|
t = resolve_generic_f (expr);
|
break;
|
break;
|
|
|
case PTYPE_SPECIFIC:
|
case PTYPE_SPECIFIC:
|
t = resolve_specific_f (expr);
|
t = resolve_specific_f (expr);
|
break;
|
break;
|
|
|
case PTYPE_UNKNOWN:
|
case PTYPE_UNKNOWN:
|
t = resolve_unknown_f (expr);
|
t = resolve_unknown_f (expr);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("resolve_function(): bad function type");
|
gfc_internal_error ("resolve_function(): bad function type");
|
}
|
}
|
}
|
}
|
|
|
/* If the expression is still a function (it might have simplified),
|
/* If the expression is still a function (it might have simplified),
|
then we check to see if we are calling an elemental function. */
|
then we check to see if we are calling an elemental function. */
|
|
|
if (expr->expr_type != EXPR_FUNCTION)
|
if (expr->expr_type != EXPR_FUNCTION)
|
return t;
|
return t;
|
|
|
temp = need_full_assumed_size;
|
temp = need_full_assumed_size;
|
need_full_assumed_size = 0;
|
need_full_assumed_size = 0;
|
|
|
if (resolve_elemental_actual (expr, NULL) == FAILURE)
|
if (resolve_elemental_actual (expr, NULL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (omp_workshare_flag
|
if (omp_workshare_flag
|
&& expr->value.function.esym
|
&& expr->value.function.esym
|
&& ! gfc_elemental (expr->value.function.esym))
|
&& ! gfc_elemental (expr->value.function.esym))
|
{
|
{
|
gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
|
gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
|
"in WORKSHARE construct", expr->value.function.esym->name,
|
"in WORKSHARE construct", expr->value.function.esym->name,
|
&expr->where);
|
&expr->where);
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
|
|
#define GENERIC_ID expr->value.function.isym->id
|
#define GENERIC_ID expr->value.function.isym->id
|
else if (expr->value.function.actual != NULL
|
else if (expr->value.function.actual != NULL
|
&& expr->value.function.isym != NULL
|
&& expr->value.function.isym != NULL
|
&& GENERIC_ID != GFC_ISYM_LBOUND
|
&& GENERIC_ID != GFC_ISYM_LBOUND
|
&& GENERIC_ID != GFC_ISYM_LEN
|
&& GENERIC_ID != GFC_ISYM_LEN
|
&& GENERIC_ID != GFC_ISYM_LOC
|
&& GENERIC_ID != GFC_ISYM_LOC
|
&& GENERIC_ID != GFC_ISYM_PRESENT)
|
&& GENERIC_ID != GFC_ISYM_PRESENT)
|
{
|
{
|
/* Array intrinsics must also have the last upper bound of an
|
/* Array intrinsics must also have the last upper bound of an
|
assumed size array argument. UBOUND and SIZE have to be
|
assumed size array argument. UBOUND and SIZE have to be
|
excluded from the check if the second argument is anything
|
excluded from the check if the second argument is anything
|
than a constant. */
|
than a constant. */
|
|
|
for (arg = expr->value.function.actual; arg; arg = arg->next)
|
for (arg = expr->value.function.actual; arg; arg = arg->next)
|
{
|
{
|
if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
|
if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
|
&& arg->next != NULL && arg->next->expr)
|
&& arg->next != NULL && arg->next->expr)
|
{
|
{
|
if (arg->next->expr->expr_type != EXPR_CONSTANT)
|
if (arg->next->expr->expr_type != EXPR_CONSTANT)
|
break;
|
break;
|
|
|
if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
|
if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
|
break;
|
break;
|
|
|
if ((int)mpz_get_si (arg->next->expr->value.integer)
|
if ((int)mpz_get_si (arg->next->expr->value.integer)
|
< arg->expr->rank)
|
< arg->expr->rank)
|
break;
|
break;
|
}
|
}
|
|
|
if (arg->expr != NULL
|
if (arg->expr != NULL
|
&& arg->expr->rank > 0
|
&& arg->expr->rank > 0
|
&& resolve_assumed_size_actual (arg->expr))
|
&& resolve_assumed_size_actual (arg->expr))
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
#undef GENERIC_ID
|
#undef GENERIC_ID
|
|
|
need_full_assumed_size = temp;
|
need_full_assumed_size = temp;
|
name = NULL;
|
name = NULL;
|
|
|
if (!pure_function (expr, &name) && name)
|
if (!pure_function (expr, &name) && name)
|
{
|
{
|
if (forall_flag)
|
if (forall_flag)
|
{
|
{
|
gfc_error ("reference to non-PURE function '%s' at %L inside a "
|
gfc_error ("reference to non-PURE function '%s' at %L inside a "
|
"FORALL %s", name, &expr->where,
|
"FORALL %s", name, &expr->where,
|
forall_flag == 2 ? "mask" : "block");
|
forall_flag == 2 ? "mask" : "block");
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
else if (gfc_pure (NULL))
|
else if (gfc_pure (NULL))
|
{
|
{
|
gfc_error ("Function reference to '%s' at %L is to a non-PURE "
|
gfc_error ("Function reference to '%s' at %L is to a non-PURE "
|
"procedure within a PURE procedure", name, &expr->where);
|
"procedure within a PURE procedure", name, &expr->where);
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Functions without the RECURSIVE attribution are not allowed to
|
/* Functions without the RECURSIVE attribution are not allowed to
|
* call themselves. */
|
* call themselves. */
|
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
|
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
|
{
|
{
|
gfc_symbol *esym;
|
gfc_symbol *esym;
|
esym = expr->value.function.esym;
|
esym = expr->value.function.esym;
|
|
|
if (is_illegal_recursion (esym, gfc_current_ns))
|
if (is_illegal_recursion (esym, gfc_current_ns))
|
{
|
{
|
if (esym->attr.entry && esym->ns->entries)
|
if (esym->attr.entry && esym->ns->entries)
|
gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
|
gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
|
" function '%s' is not RECURSIVE",
|
" function '%s' is not RECURSIVE",
|
esym->name, &expr->where, esym->ns->entries->sym->name);
|
esym->name, &expr->where, esym->ns->entries->sym->name);
|
else
|
else
|
gfc_error ("Function '%s' at %L cannot be called recursively, as it"
|
gfc_error ("Function '%s' at %L cannot be called recursively, as it"
|
" is not RECURSIVE", esym->name, &expr->where);
|
" is not RECURSIVE", esym->name, &expr->where);
|
|
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Character lengths of use associated functions may contains references to
|
/* Character lengths of use associated functions may contains references to
|
symbols not referenced from the current program unit otherwise. Make sure
|
symbols not referenced from the current program unit otherwise. Make sure
|
those symbols are marked as referenced. */
|
those symbols are marked as referenced. */
|
|
|
if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
|
if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
|
&& expr->value.function.esym->attr.use_assoc)
|
&& expr->value.function.esym->attr.use_assoc)
|
{
|
{
|
gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
|
gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
|
}
|
}
|
|
|
if (t == SUCCESS
|
if (t == SUCCESS
|
&& !((expr->value.function.esym
|
&& !((expr->value.function.esym
|
&& expr->value.function.esym->attr.elemental)
|
&& expr->value.function.esym->attr.elemental)
|
||
|
||
|
(expr->value.function.isym
|
(expr->value.function.isym
|
&& expr->value.function.isym->elemental)))
|
&& expr->value.function.isym->elemental)))
|
find_noncopying_intrinsics (expr->value.function.esym,
|
find_noncopying_intrinsics (expr->value.function.esym,
|
expr->value.function.actual);
|
expr->value.function.actual);
|
|
|
/* Make sure that the expression has a typespec that works. */
|
/* Make sure that the expression has a typespec that works. */
|
if (expr->ts.type == BT_UNKNOWN)
|
if (expr->ts.type == BT_UNKNOWN)
|
{
|
{
|
if (expr->symtree->n.sym->result
|
if (expr->symtree->n.sym->result
|
&& expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
|
&& expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
|
&& !expr->symtree->n.sym->result->attr.proc_pointer)
|
&& !expr->symtree->n.sym->result->attr.proc_pointer)
|
expr->ts = expr->symtree->n.sym->result->ts;
|
expr->ts = expr->symtree->n.sym->result->ts;
|
}
|
}
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
/************* Subroutine resolution *************/
|
/************* Subroutine resolution *************/
|
|
|
static void
|
static void
|
pure_subroutine (gfc_code *c, gfc_symbol *sym)
|
pure_subroutine (gfc_code *c, gfc_symbol *sym)
|
{
|
{
|
if (gfc_pure (sym))
|
if (gfc_pure (sym))
|
return;
|
return;
|
|
|
if (forall_flag)
|
if (forall_flag)
|
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
|
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
|
sym->name, &c->loc);
|
sym->name, &c->loc);
|
else if (gfc_pure (NULL))
|
else if (gfc_pure (NULL))
|
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
|
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
|
&c->loc);
|
&c->loc);
|
}
|
}
|
|
|
|
|
static match
|
static match
|
resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
|
resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
|
{
|
{
|
gfc_symbol *s;
|
gfc_symbol *s;
|
|
|
if (sym->attr.generic)
|
if (sym->attr.generic)
|
{
|
{
|
s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
|
s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
|
if (s != NULL)
|
if (s != NULL)
|
{
|
{
|
c->resolved_sym = s;
|
c->resolved_sym = s;
|
pure_subroutine (c, s);
|
pure_subroutine (c, s);
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
/* TODO: Need to search for elemental references in generic interface. */
|
/* TODO: Need to search for elemental references in generic interface. */
|
}
|
}
|
|
|
if (sym->attr.intrinsic)
|
if (sym->attr.intrinsic)
|
return gfc_intrinsic_sub_interface (c, 0);
|
return gfc_intrinsic_sub_interface (c, 0);
|
|
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
resolve_generic_s (gfc_code *c)
|
resolve_generic_s (gfc_code *c)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
match m;
|
match m;
|
|
|
sym = c->symtree->n.sym;
|
sym = c->symtree->n.sym;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
m = resolve_generic_s0 (c, sym);
|
m = resolve_generic_s0 (c, sym);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
return SUCCESS;
|
return SUCCESS;
|
else if (m == MATCH_ERROR)
|
else if (m == MATCH_ERROR)
|
return FAILURE;
|
return FAILURE;
|
|
|
generic:
|
generic:
|
if (sym->ns->parent == NULL)
|
if (sym->ns->parent == NULL)
|
break;
|
break;
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
break;
|
break;
|
if (!generic_sym (sym))
|
if (!generic_sym (sym))
|
goto generic;
|
goto generic;
|
}
|
}
|
|
|
/* Last ditch attempt. See if the reference is to an intrinsic
|
/* Last ditch attempt. See if the reference is to an intrinsic
|
that possesses a matching interface. 14.1.2.4 */
|
that possesses a matching interface. 14.1.2.4 */
|
sym = c->symtree->n.sym;
|
sym = c->symtree->n.sym;
|
|
|
if (!gfc_is_intrinsic (sym, 1, c->loc))
|
if (!gfc_is_intrinsic (sym, 1, c->loc))
|
{
|
{
|
gfc_error ("There is no specific subroutine for the generic '%s' at %L",
|
gfc_error ("There is no specific subroutine for the generic '%s' at %L",
|
sym->name, &c->loc);
|
sym->name, &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
m = gfc_intrinsic_sub_interface (c, 0);
|
m = gfc_intrinsic_sub_interface (c, 0);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
return SUCCESS;
|
return SUCCESS;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
|
gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
|
"intrinsic subroutine interface", sym->name, &c->loc);
|
"intrinsic subroutine interface", sym->name, &c->loc);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Set the name and binding label of the subroutine symbol in the call
|
/* Set the name and binding label of the subroutine symbol in the call
|
expression represented by 'c' to include the type and kind of the
|
expression represented by 'c' to include the type and kind of the
|
second parameter. This function is for resolving the appropriate
|
second parameter. This function is for resolving the appropriate
|
version of c_f_pointer() and c_f_procpointer(). For example, a
|
version of c_f_pointer() and c_f_procpointer(). For example, a
|
call to c_f_pointer() for a default integer pointer could have a
|
call to c_f_pointer() for a default integer pointer could have a
|
name of c_f_pointer_i4. If no second arg exists, which is an error
|
name of c_f_pointer_i4. If no second arg exists, which is an error
|
for these two functions, it defaults to the generic symbol's name
|
for these two functions, it defaults to the generic symbol's name
|
and binding label. */
|
and binding label. */
|
|
|
static void
|
static void
|
set_name_and_label (gfc_code *c, gfc_symbol *sym,
|
set_name_and_label (gfc_code *c, gfc_symbol *sym,
|
char *name, char *binding_label)
|
char *name, char *binding_label)
|
{
|
{
|
gfc_expr *arg = NULL;
|
gfc_expr *arg = NULL;
|
char type;
|
char type;
|
int kind;
|
int kind;
|
|
|
/* The second arg of c_f_pointer and c_f_procpointer determines
|
/* The second arg of c_f_pointer and c_f_procpointer determines
|
the type and kind for the procedure name. */
|
the type and kind for the procedure name. */
|
arg = c->ext.actual->next->expr;
|
arg = c->ext.actual->next->expr;
|
|
|
if (arg != NULL)
|
if (arg != NULL)
|
{
|
{
|
/* Set up the name to have the given symbol's name,
|
/* Set up the name to have the given symbol's name,
|
plus the type and kind. */
|
plus the type and kind. */
|
/* a derived type is marked with the type letter 'u' */
|
/* a derived type is marked with the type letter 'u' */
|
if (arg->ts.type == BT_DERIVED)
|
if (arg->ts.type == BT_DERIVED)
|
{
|
{
|
type = 'd';
|
type = 'd';
|
kind = 0; /* set the kind as 0 for now */
|
kind = 0; /* set the kind as 0 for now */
|
}
|
}
|
else
|
else
|
{
|
{
|
type = gfc_type_letter (arg->ts.type);
|
type = gfc_type_letter (arg->ts.type);
|
kind = arg->ts.kind;
|
kind = arg->ts.kind;
|
}
|
}
|
|
|
if (arg->ts.type == BT_CHARACTER)
|
if (arg->ts.type == BT_CHARACTER)
|
/* Kind info for character strings not needed. */
|
/* Kind info for character strings not needed. */
|
kind = 0;
|
kind = 0;
|
|
|
sprintf (name, "%s_%c%d", sym->name, type, kind);
|
sprintf (name, "%s_%c%d", sym->name, type, kind);
|
/* Set up the binding label as the given symbol's label plus
|
/* Set up the binding label as the given symbol's label plus
|
the type and kind. */
|
the type and kind. */
|
sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
|
sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* If the second arg is missing, set the name and label as
|
/* If the second arg is missing, set the name and label as
|
was, cause it should at least be found, and the missing
|
was, cause it should at least be found, and the missing
|
arg error will be caught by compare_parameters(). */
|
arg error will be caught by compare_parameters(). */
|
sprintf (name, "%s", sym->name);
|
sprintf (name, "%s", sym->name);
|
sprintf (binding_label, "%s", sym->binding_label);
|
sprintf (binding_label, "%s", sym->binding_label);
|
}
|
}
|
|
|
return;
|
return;
|
}
|
}
|
|
|
|
|
/* Resolve a generic version of the iso_c_binding procedure given
|
/* Resolve a generic version of the iso_c_binding procedure given
|
(sym) to the specific one based on the type and kind of the
|
(sym) to the specific one based on the type and kind of the
|
argument(s). Currently, this function resolves c_f_pointer() and
|
argument(s). Currently, this function resolves c_f_pointer() and
|
c_f_procpointer based on the type and kind of the second argument
|
c_f_procpointer based on the type and kind of the second argument
|
(FPTR). Other iso_c_binding procedures aren't specially handled.
|
(FPTR). Other iso_c_binding procedures aren't specially handled.
|
Upon successfully exiting, c->resolved_sym will hold the resolved
|
Upon successfully exiting, c->resolved_sym will hold the resolved
|
symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
|
symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
|
otherwise. */
|
otherwise. */
|
|
|
match
|
match
|
gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
|
gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
|
{
|
{
|
gfc_symbol *new_sym;
|
gfc_symbol *new_sym;
|
/* this is fine, since we know the names won't use the max */
|
/* this is fine, since we know the names won't use the max */
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
|
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
|
/* default to success; will override if find error */
|
/* default to success; will override if find error */
|
match m = MATCH_YES;
|
match m = MATCH_YES;
|
|
|
/* Make sure the actual arguments are in the necessary order (based on the
|
/* Make sure the actual arguments are in the necessary order (based on the
|
formal args) before resolving. */
|
formal args) before resolving. */
|
gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
|
gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
|
|
|
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
|
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
|
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
|
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
|
{
|
{
|
set_name_and_label (c, sym, name, binding_label);
|
set_name_and_label (c, sym, name, binding_label);
|
|
|
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
|
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
|
{
|
{
|
if (c->ext.actual != NULL && c->ext.actual->next != NULL)
|
if (c->ext.actual != NULL && c->ext.actual->next != NULL)
|
{
|
{
|
/* Make sure we got a third arg if the second arg has non-zero
|
/* Make sure we got a third arg if the second arg has non-zero
|
rank. We must also check that the type and rank are
|
rank. We must also check that the type and rank are
|
correct since we short-circuit this check in
|
correct since we short-circuit this check in
|
gfc_procedure_use() (called above to sort actual args). */
|
gfc_procedure_use() (called above to sort actual args). */
|
if (c->ext.actual->next->expr->rank != 0)
|
if (c->ext.actual->next->expr->rank != 0)
|
{
|
{
|
if(c->ext.actual->next->next == NULL
|
if(c->ext.actual->next->next == NULL
|
|| c->ext.actual->next->next->expr == NULL)
|
|| c->ext.actual->next->next->expr == NULL)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
gfc_error ("Missing SHAPE parameter for call to %s "
|
gfc_error ("Missing SHAPE parameter for call to %s "
|
"at %L", sym->name, &(c->loc));
|
"at %L", sym->name, &(c->loc));
|
}
|
}
|
else if (c->ext.actual->next->next->expr->ts.type
|
else if (c->ext.actual->next->next->expr->ts.type
|
!= BT_INTEGER
|
!= BT_INTEGER
|
|| c->ext.actual->next->next->expr->rank != 1)
|
|| c->ext.actual->next->next->expr->rank != 1)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
gfc_error ("SHAPE parameter for call to %s at %L must "
|
gfc_error ("SHAPE parameter for call to %s at %L must "
|
"be a rank 1 INTEGER array", sym->name,
|
"be a rank 1 INTEGER array", sym->name,
|
&(c->loc));
|
&(c->loc));
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (m != MATCH_ERROR)
|
if (m != MATCH_ERROR)
|
{
|
{
|
/* the 1 means to add the optional arg to formal list */
|
/* the 1 means to add the optional arg to formal list */
|
new_sym = get_iso_c_sym (sym, name, binding_label, 1);
|
new_sym = get_iso_c_sym (sym, name, binding_label, 1);
|
|
|
/* for error reporting, say it's declared where the original was */
|
/* for error reporting, say it's declared where the original was */
|
new_sym->declared_at = sym->declared_at;
|
new_sym->declared_at = sym->declared_at;
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
/* no differences for c_loc or c_funloc */
|
/* no differences for c_loc or c_funloc */
|
new_sym = sym;
|
new_sym = sym;
|
}
|
}
|
|
|
/* set the resolved symbol */
|
/* set the resolved symbol */
|
if (m != MATCH_ERROR)
|
if (m != MATCH_ERROR)
|
c->resolved_sym = new_sym;
|
c->resolved_sym = new_sym;
|
else
|
else
|
c->resolved_sym = sym;
|
c->resolved_sym = sym;
|
|
|
return m;
|
return m;
|
}
|
}
|
|
|
|
|
/* Resolve a subroutine call known to be specific. */
|
/* Resolve a subroutine call known to be specific. */
|
|
|
static match
|
static match
|
resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
|
resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
|
{
|
{
|
match m;
|
match m;
|
|
|
if(sym->attr.is_iso_c)
|
if(sym->attr.is_iso_c)
|
{
|
{
|
m = gfc_iso_c_sub_interface (c,sym);
|
m = gfc_iso_c_sub_interface (c,sym);
|
return m;
|
return m;
|
}
|
}
|
|
|
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
|
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
|
{
|
{
|
if (sym->attr.dummy)
|
if (sym->attr.dummy)
|
{
|
{
|
sym->attr.proc = PROC_DUMMY;
|
sym->attr.proc = PROC_DUMMY;
|
goto found;
|
goto found;
|
}
|
}
|
|
|
sym->attr.proc = PROC_EXTERNAL;
|
sym->attr.proc = PROC_EXTERNAL;
|
goto found;
|
goto found;
|
}
|
}
|
|
|
if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
|
if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
|
goto found;
|
goto found;
|
|
|
if (sym->attr.intrinsic)
|
if (sym->attr.intrinsic)
|
{
|
{
|
m = gfc_intrinsic_sub_interface (c, 1);
|
m = gfc_intrinsic_sub_interface (c, 1);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
return MATCH_YES;
|
return MATCH_YES;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
|
gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
|
"with an intrinsic", sym->name, &c->loc);
|
"with an intrinsic", sym->name, &c->loc);
|
|
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
found:
|
found:
|
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
|
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
|
|
|
c->resolved_sym = sym;
|
c->resolved_sym = sym;
|
pure_subroutine (c, sym);
|
pure_subroutine (c, sym);
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
resolve_specific_s (gfc_code *c)
|
resolve_specific_s (gfc_code *c)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
match m;
|
match m;
|
|
|
sym = c->symtree->n.sym;
|
sym = c->symtree->n.sym;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
m = resolve_specific_s0 (c, sym);
|
m = resolve_specific_s0 (c, sym);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
return SUCCESS;
|
return SUCCESS;
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (sym->ns->parent == NULL)
|
if (sym->ns->parent == NULL)
|
break;
|
break;
|
|
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
|
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
break;
|
break;
|
}
|
}
|
|
|
sym = c->symtree->n.sym;
|
sym = c->symtree->n.sym;
|
gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
|
gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
|
sym->name, &c->loc);
|
sym->name, &c->loc);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Resolve a subroutine call not known to be generic nor specific. */
|
/* Resolve a subroutine call not known to be generic nor specific. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_unknown_s (gfc_code *c)
|
resolve_unknown_s (gfc_code *c)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
|
|
sym = c->symtree->n.sym;
|
sym = c->symtree->n.sym;
|
|
|
if (sym->attr.dummy)
|
if (sym->attr.dummy)
|
{
|
{
|
sym->attr.proc = PROC_DUMMY;
|
sym->attr.proc = PROC_DUMMY;
|
goto found;
|
goto found;
|
}
|
}
|
|
|
/* See if we have an intrinsic function reference. */
|
/* See if we have an intrinsic function reference. */
|
|
|
if (gfc_is_intrinsic (sym, 1, c->loc))
|
if (gfc_is_intrinsic (sym, 1, c->loc))
|
{
|
{
|
if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
|
if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
|
return SUCCESS;
|
return SUCCESS;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* The reference is to an external name. */
|
/* The reference is to an external name. */
|
|
|
found:
|
found:
|
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
|
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
|
|
|
c->resolved_sym = sym;
|
c->resolved_sym = sym;
|
|
|
pure_subroutine (c, sym);
|
pure_subroutine (c, sym);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a subroutine call. Although it was tempting to use the same code
|
/* Resolve a subroutine call. Although it was tempting to use the same code
|
for functions, subroutines and functions are stored differently and this
|
for functions, subroutines and functions are stored differently and this
|
makes things awkward. */
|
makes things awkward. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_call (gfc_code *c)
|
resolve_call (gfc_code *c)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
procedure_type ptype = PROC_INTRINSIC;
|
procedure_type ptype = PROC_INTRINSIC;
|
gfc_symbol *csym, *sym;
|
gfc_symbol *csym, *sym;
|
bool no_formal_args;
|
bool no_formal_args;
|
|
|
csym = c->symtree ? c->symtree->n.sym : NULL;
|
csym = c->symtree ? c->symtree->n.sym : NULL;
|
|
|
if (csym && csym->ts.type != BT_UNKNOWN)
|
if (csym && csym->ts.type != BT_UNKNOWN)
|
{
|
{
|
gfc_error ("'%s' at %L has a type, which is not consistent with "
|
gfc_error ("'%s' at %L has a type, which is not consistent with "
|
"the CALL at %L", csym->name, &csym->declared_at, &c->loc);
|
"the CALL at %L", csym->name, &csym->declared_at, &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
|
if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
|
{
|
{
|
gfc_symtree *st;
|
gfc_symtree *st;
|
gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
|
gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
|
sym = st ? st->n.sym : NULL;
|
sym = st ? st->n.sym : NULL;
|
if (sym && csym != sym
|
if (sym && csym != sym
|
&& sym->ns == gfc_current_ns
|
&& sym->ns == gfc_current_ns
|
&& sym->attr.flavor == FL_PROCEDURE
|
&& sym->attr.flavor == FL_PROCEDURE
|
&& sym->attr.contained)
|
&& sym->attr.contained)
|
{
|
{
|
sym->refs++;
|
sym->refs++;
|
if (csym->attr.generic)
|
if (csym->attr.generic)
|
c->symtree->n.sym = sym;
|
c->symtree->n.sym = sym;
|
else
|
else
|
c->symtree = st;
|
c->symtree = st;
|
csym = c->symtree->n.sym;
|
csym = c->symtree->n.sym;
|
}
|
}
|
}
|
}
|
|
|
/* If this ia a deferred TBP with an abstract interface
|
/* If this ia a deferred TBP with an abstract interface
|
(which may of course be referenced), c->expr1 will be set. */
|
(which may of course be referenced), c->expr1 will be set. */
|
if (csym && csym->attr.abstract && !c->expr1)
|
if (csym && csym->attr.abstract && !c->expr1)
|
{
|
{
|
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
|
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
|
csym->name, &c->loc);
|
csym->name, &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Subroutines without the RECURSIVE attribution are not allowed to
|
/* Subroutines without the RECURSIVE attribution are not allowed to
|
* call themselves. */
|
* call themselves. */
|
if (csym && is_illegal_recursion (csym, gfc_current_ns))
|
if (csym && is_illegal_recursion (csym, gfc_current_ns))
|
{
|
{
|
if (csym->attr.entry && csym->ns->entries)
|
if (csym->attr.entry && csym->ns->entries)
|
gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
|
gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
|
" subroutine '%s' is not RECURSIVE",
|
" subroutine '%s' is not RECURSIVE",
|
csym->name, &c->loc, csym->ns->entries->sym->name);
|
csym->name, &c->loc, csym->ns->entries->sym->name);
|
else
|
else
|
gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
|
gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
|
" is not RECURSIVE", csym->name, &c->loc);
|
" is not RECURSIVE", csym->name, &c->loc);
|
|
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
|
|
/* Switch off assumed size checking and do this again for certain kinds
|
/* Switch off assumed size checking and do this again for certain kinds
|
of procedure, once the procedure itself is resolved. */
|
of procedure, once the procedure itself is resolved. */
|
need_full_assumed_size++;
|
need_full_assumed_size++;
|
|
|
if (csym)
|
if (csym)
|
ptype = csym->attr.proc;
|
ptype = csym->attr.proc;
|
|
|
no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
|
no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
|
if (resolve_actual_arglist (c->ext.actual, ptype,
|
if (resolve_actual_arglist (c->ext.actual, ptype,
|
no_formal_args) == FAILURE)
|
no_formal_args) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Resume assumed_size checking. */
|
/* Resume assumed_size checking. */
|
need_full_assumed_size--;
|
need_full_assumed_size--;
|
|
|
/* If external, check for usage. */
|
/* If external, check for usage. */
|
if (csym && is_external_proc (csym))
|
if (csym && is_external_proc (csym))
|
resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
|
resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
if (c->resolved_sym == NULL)
|
if (c->resolved_sym == NULL)
|
{
|
{
|
c->resolved_isym = NULL;
|
c->resolved_isym = NULL;
|
switch (procedure_kind (csym))
|
switch (procedure_kind (csym))
|
{
|
{
|
case PTYPE_GENERIC:
|
case PTYPE_GENERIC:
|
t = resolve_generic_s (c);
|
t = resolve_generic_s (c);
|
break;
|
break;
|
|
|
case PTYPE_SPECIFIC:
|
case PTYPE_SPECIFIC:
|
t = resolve_specific_s (c);
|
t = resolve_specific_s (c);
|
break;
|
break;
|
|
|
case PTYPE_UNKNOWN:
|
case PTYPE_UNKNOWN:
|
t = resolve_unknown_s (c);
|
t = resolve_unknown_s (c);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("resolve_subroutine(): bad function type");
|
gfc_internal_error ("resolve_subroutine(): bad function type");
|
}
|
}
|
}
|
}
|
|
|
/* Some checks of elemental subroutine actual arguments. */
|
/* Some checks of elemental subroutine actual arguments. */
|
if (resolve_elemental_actual (NULL, c) == FAILURE)
|
if (resolve_elemental_actual (NULL, c) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
|
if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
|
find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
|
find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
/* Compare the shapes of two arrays that have non-NULL shapes. If both
|
/* Compare the shapes of two arrays that have non-NULL shapes. If both
|
op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
|
op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
|
match. If both op1->shape and op2->shape are non-NULL return FAILURE
|
match. If both op1->shape and op2->shape are non-NULL return FAILURE
|
if their shapes do not match. If either op1->shape or op2->shape is
|
if their shapes do not match. If either op1->shape or op2->shape is
|
NULL, return SUCCESS. */
|
NULL, return SUCCESS. */
|
|
|
static gfc_try
|
static gfc_try
|
compare_shapes (gfc_expr *op1, gfc_expr *op2)
|
compare_shapes (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
int i;
|
int i;
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
|
|
if (op1->shape != NULL && op2->shape != NULL)
|
if (op1->shape != NULL && op2->shape != NULL)
|
{
|
{
|
for (i = 0; i < op1->rank; i++)
|
for (i = 0; i < op1->rank; i++)
|
{
|
{
|
if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
|
if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
|
{
|
{
|
gfc_error ("Shapes for operands at %L and %L are not conformable",
|
gfc_error ("Shapes for operands at %L and %L are not conformable",
|
&op1->where, &op2->where);
|
&op1->where, &op2->where);
|
t = FAILURE;
|
t = FAILURE;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
/* Resolve an operator expression node. This can involve replacing the
|
/* Resolve an operator expression node. This can involve replacing the
|
operation with a user defined function call. */
|
operation with a user defined function call. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_operator (gfc_expr *e)
|
resolve_operator (gfc_expr *e)
|
{
|
{
|
gfc_expr *op1, *op2;
|
gfc_expr *op1, *op2;
|
char msg[200];
|
char msg[200];
|
bool dual_locus_error;
|
bool dual_locus_error;
|
gfc_try t;
|
gfc_try t;
|
|
|
/* Resolve all subnodes-- give them types. */
|
/* Resolve all subnodes-- give them types. */
|
|
|
switch (e->value.op.op)
|
switch (e->value.op.op)
|
{
|
{
|
default:
|
default:
|
if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
|
if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Fall through... */
|
/* Fall through... */
|
|
|
case INTRINSIC_NOT:
|
case INTRINSIC_NOT:
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UMINUS:
|
case INTRINSIC_UMINUS:
|
case INTRINSIC_PARENTHESES:
|
case INTRINSIC_PARENTHESES:
|
if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
|
if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
break;
|
break;
|
}
|
}
|
|
|
/* Typecheck the new node. */
|
/* Typecheck the new node. */
|
|
|
op1 = e->value.op.op1;
|
op1 = e->value.op.op1;
|
op2 = e->value.op.op2;
|
op2 = e->value.op.op2;
|
dual_locus_error = false;
|
dual_locus_error = false;
|
|
|
if ((op1 && op1->expr_type == EXPR_NULL)
|
if ((op1 && op1->expr_type == EXPR_NULL)
|
|| (op2 && op2->expr_type == EXPR_NULL))
|
|| (op2 && op2->expr_type == EXPR_NULL))
|
{
|
{
|
sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
|
sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
|
goto bad_op;
|
goto bad_op;
|
}
|
}
|
|
|
switch (e->value.op.op)
|
switch (e->value.op.op)
|
{
|
{
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UMINUS:
|
case INTRINSIC_UMINUS:
|
if (op1->ts.type == BT_INTEGER
|
if (op1->ts.type == BT_INTEGER
|
|| op1->ts.type == BT_REAL
|
|| op1->ts.type == BT_REAL
|
|| op1->ts.type == BT_COMPLEX)
|
|| op1->ts.type == BT_COMPLEX)
|
{
|
{
|
e->ts = op1->ts;
|
e->ts = op1->ts;
|
break;
|
break;
|
}
|
}
|
|
|
sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
|
sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
|
gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
|
gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
|
goto bad_op;
|
goto bad_op;
|
|
|
case INTRINSIC_PLUS:
|
case INTRINSIC_PLUS:
|
case INTRINSIC_MINUS:
|
case INTRINSIC_MINUS:
|
case INTRINSIC_TIMES:
|
case INTRINSIC_TIMES:
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_POWER:
|
case INTRINSIC_POWER:
|
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
|
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
|
{
|
{
|
gfc_type_convert_binary (e, 1);
|
gfc_type_convert_binary (e, 1);
|
break;
|
break;
|
}
|
}
|
|
|
sprintf (msg,
|
sprintf (msg,
|
_("Operands of binary numeric operator '%s' at %%L are %s/%s"),
|
_("Operands of binary numeric operator '%s' at %%L are %s/%s"),
|
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
|
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
|
gfc_typename (&op2->ts));
|
gfc_typename (&op2->ts));
|
goto bad_op;
|
goto bad_op;
|
|
|
case INTRINSIC_CONCAT:
|
case INTRINSIC_CONCAT:
|
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
|
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
|
&& op1->ts.kind == op2->ts.kind)
|
&& op1->ts.kind == op2->ts.kind)
|
{
|
{
|
e->ts.type = BT_CHARACTER;
|
e->ts.type = BT_CHARACTER;
|
e->ts.kind = op1->ts.kind;
|
e->ts.kind = op1->ts.kind;
|
break;
|
break;
|
}
|
}
|
|
|
sprintf (msg,
|
sprintf (msg,
|
_("Operands of string concatenation operator at %%L are %s/%s"),
|
_("Operands of string concatenation operator at %%L are %s/%s"),
|
gfc_typename (&op1->ts), gfc_typename (&op2->ts));
|
gfc_typename (&op1->ts), gfc_typename (&op2->ts));
|
goto bad_op;
|
goto bad_op;
|
|
|
case INTRINSIC_AND:
|
case INTRINSIC_AND:
|
case INTRINSIC_OR:
|
case INTRINSIC_OR:
|
case INTRINSIC_EQV:
|
case INTRINSIC_EQV:
|
case INTRINSIC_NEQV:
|
case INTRINSIC_NEQV:
|
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
|
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
|
{
|
{
|
e->ts.type = BT_LOGICAL;
|
e->ts.type = BT_LOGICAL;
|
e->ts.kind = gfc_kind_max (op1, op2);
|
e->ts.kind = gfc_kind_max (op1, op2);
|
if (op1->ts.kind < e->ts.kind)
|
if (op1->ts.kind < e->ts.kind)
|
gfc_convert_type (op1, &e->ts, 2);
|
gfc_convert_type (op1, &e->ts, 2);
|
else if (op2->ts.kind < e->ts.kind)
|
else if (op2->ts.kind < e->ts.kind)
|
gfc_convert_type (op2, &e->ts, 2);
|
gfc_convert_type (op2, &e->ts, 2);
|
break;
|
break;
|
}
|
}
|
|
|
sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
|
sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
|
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
|
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
|
gfc_typename (&op2->ts));
|
gfc_typename (&op2->ts));
|
|
|
goto bad_op;
|
goto bad_op;
|
|
|
case INTRINSIC_NOT:
|
case INTRINSIC_NOT:
|
if (op1->ts.type == BT_LOGICAL)
|
if (op1->ts.type == BT_LOGICAL)
|
{
|
{
|
e->ts.type = BT_LOGICAL;
|
e->ts.type = BT_LOGICAL;
|
e->ts.kind = op1->ts.kind;
|
e->ts.kind = op1->ts.kind;
|
break;
|
break;
|
}
|
}
|
|
|
sprintf (msg, _("Operand of .not. operator at %%L is %s"),
|
sprintf (msg, _("Operand of .not. operator at %%L is %s"),
|
gfc_typename (&op1->ts));
|
gfc_typename (&op1->ts));
|
goto bad_op;
|
goto bad_op;
|
|
|
case INTRINSIC_GT:
|
case INTRINSIC_GT:
|
case INTRINSIC_GT_OS:
|
case INTRINSIC_GT_OS:
|
case INTRINSIC_GE:
|
case INTRINSIC_GE:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE_OS:
|
case INTRINSIC_LE_OS:
|
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
|
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
|
{
|
{
|
strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
|
strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
|
goto bad_op;
|
goto bad_op;
|
}
|
}
|
|
|
/* Fall through... */
|
/* Fall through... */
|
|
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE_OS:
|
case INTRINSIC_NE_OS:
|
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
|
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
|
&& op1->ts.kind == op2->ts.kind)
|
&& op1->ts.kind == op2->ts.kind)
|
{
|
{
|
e->ts.type = BT_LOGICAL;
|
e->ts.type = BT_LOGICAL;
|
e->ts.kind = gfc_default_logical_kind;
|
e->ts.kind = gfc_default_logical_kind;
|
break;
|
break;
|
}
|
}
|
|
|
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
|
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
|
{
|
{
|
gfc_type_convert_binary (e, 1);
|
gfc_type_convert_binary (e, 1);
|
|
|
e->ts.type = BT_LOGICAL;
|
e->ts.type = BT_LOGICAL;
|
e->ts.kind = gfc_default_logical_kind;
|
e->ts.kind = gfc_default_logical_kind;
|
break;
|
break;
|
}
|
}
|
|
|
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
|
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
|
sprintf (msg,
|
sprintf (msg,
|
_("Logicals at %%L must be compared with %s instead of %s"),
|
_("Logicals at %%L must be compared with %s instead of %s"),
|
(e->value.op.op == INTRINSIC_EQ
|
(e->value.op.op == INTRINSIC_EQ
|
|| e->value.op.op == INTRINSIC_EQ_OS)
|
|| e->value.op.op == INTRINSIC_EQ_OS)
|
? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
|
? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
|
else
|
else
|
sprintf (msg,
|
sprintf (msg,
|
_("Operands of comparison operator '%s' at %%L are %s/%s"),
|
_("Operands of comparison operator '%s' at %%L are %s/%s"),
|
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
|
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
|
gfc_typename (&op2->ts));
|
gfc_typename (&op2->ts));
|
|
|
goto bad_op;
|
goto bad_op;
|
|
|
case INTRINSIC_USER:
|
case INTRINSIC_USER:
|
if (e->value.op.uop->op == NULL)
|
if (e->value.op.uop->op == NULL)
|
sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
|
sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
|
else if (op2 == NULL)
|
else if (op2 == NULL)
|
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
|
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
|
e->value.op.uop->name, gfc_typename (&op1->ts));
|
e->value.op.uop->name, gfc_typename (&op1->ts));
|
else
|
else
|
sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
|
sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
|
e->value.op.uop->name, gfc_typename (&op1->ts),
|
e->value.op.uop->name, gfc_typename (&op1->ts),
|
gfc_typename (&op2->ts));
|
gfc_typename (&op2->ts));
|
|
|
goto bad_op;
|
goto bad_op;
|
|
|
case INTRINSIC_PARENTHESES:
|
case INTRINSIC_PARENTHESES:
|
e->ts = op1->ts;
|
e->ts = op1->ts;
|
if (e->ts.type == BT_CHARACTER)
|
if (e->ts.type == BT_CHARACTER)
|
e->ts.u.cl = op1->ts.u.cl;
|
e->ts.u.cl = op1->ts.u.cl;
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("resolve_operator(): Bad intrinsic");
|
gfc_internal_error ("resolve_operator(): Bad intrinsic");
|
}
|
}
|
|
|
/* Deal with arrayness of an operand through an operator. */
|
/* Deal with arrayness of an operand through an operator. */
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
|
|
switch (e->value.op.op)
|
switch (e->value.op.op)
|
{
|
{
|
case INTRINSIC_PLUS:
|
case INTRINSIC_PLUS:
|
case INTRINSIC_MINUS:
|
case INTRINSIC_MINUS:
|
case INTRINSIC_TIMES:
|
case INTRINSIC_TIMES:
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_POWER:
|
case INTRINSIC_POWER:
|
case INTRINSIC_CONCAT:
|
case INTRINSIC_CONCAT:
|
case INTRINSIC_AND:
|
case INTRINSIC_AND:
|
case INTRINSIC_OR:
|
case INTRINSIC_OR:
|
case INTRINSIC_EQV:
|
case INTRINSIC_EQV:
|
case INTRINSIC_NEQV:
|
case INTRINSIC_NEQV:
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE_OS:
|
case INTRINSIC_NE_OS:
|
case INTRINSIC_GT:
|
case INTRINSIC_GT:
|
case INTRINSIC_GT_OS:
|
case INTRINSIC_GT_OS:
|
case INTRINSIC_GE:
|
case INTRINSIC_GE:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE_OS:
|
case INTRINSIC_LE_OS:
|
|
|
if (op1->rank == 0 && op2->rank == 0)
|
if (op1->rank == 0 && op2->rank == 0)
|
e->rank = 0;
|
e->rank = 0;
|
|
|
if (op1->rank == 0 && op2->rank != 0)
|
if (op1->rank == 0 && op2->rank != 0)
|
{
|
{
|
e->rank = op2->rank;
|
e->rank = op2->rank;
|
|
|
if (e->shape == NULL)
|
if (e->shape == NULL)
|
e->shape = gfc_copy_shape (op2->shape, op2->rank);
|
e->shape = gfc_copy_shape (op2->shape, op2->rank);
|
}
|
}
|
|
|
if (op1->rank != 0 && op2->rank == 0)
|
if (op1->rank != 0 && op2->rank == 0)
|
{
|
{
|
e->rank = op1->rank;
|
e->rank = op1->rank;
|
|
|
if (e->shape == NULL)
|
if (e->shape == NULL)
|
e->shape = gfc_copy_shape (op1->shape, op1->rank);
|
e->shape = gfc_copy_shape (op1->shape, op1->rank);
|
}
|
}
|
|
|
if (op1->rank != 0 && op2->rank != 0)
|
if (op1->rank != 0 && op2->rank != 0)
|
{
|
{
|
if (op1->rank == op2->rank)
|
if (op1->rank == op2->rank)
|
{
|
{
|
e->rank = op1->rank;
|
e->rank = op1->rank;
|
if (e->shape == NULL)
|
if (e->shape == NULL)
|
{
|
{
|
t = compare_shapes(op1, op2);
|
t = compare_shapes(op1, op2);
|
if (t == FAILURE)
|
if (t == FAILURE)
|
e->shape = NULL;
|
e->shape = NULL;
|
else
|
else
|
e->shape = gfc_copy_shape (op1->shape, op1->rank);
|
e->shape = gfc_copy_shape (op1->shape, op1->rank);
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Allow higher level expressions to work. */
|
/* Allow higher level expressions to work. */
|
e->rank = 0;
|
e->rank = 0;
|
|
|
/* Try user-defined operators, and otherwise throw an error. */
|
/* Try user-defined operators, and otherwise throw an error. */
|
dual_locus_error = true;
|
dual_locus_error = true;
|
sprintf (msg,
|
sprintf (msg,
|
_("Inconsistent ranks for operator at %%L and %%L"));
|
_("Inconsistent ranks for operator at %%L and %%L"));
|
goto bad_op;
|
goto bad_op;
|
}
|
}
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case INTRINSIC_PARENTHESES:
|
case INTRINSIC_PARENTHESES:
|
case INTRINSIC_NOT:
|
case INTRINSIC_NOT:
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UMINUS:
|
case INTRINSIC_UMINUS:
|
/* Simply copy arrayness attribute */
|
/* Simply copy arrayness attribute */
|
e->rank = op1->rank;
|
e->rank = op1->rank;
|
|
|
if (e->shape == NULL)
|
if (e->shape == NULL)
|
e->shape = gfc_copy_shape (op1->shape, op1->rank);
|
e->shape = gfc_copy_shape (op1->shape, op1->rank);
|
|
|
break;
|
break;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
|
|
/* Attempt to simplify the expression. */
|
/* Attempt to simplify the expression. */
|
if (t == SUCCESS)
|
if (t == SUCCESS)
|
{
|
{
|
t = gfc_simplify_expr (e, 0);
|
t = gfc_simplify_expr (e, 0);
|
/* Some calls do not succeed in simplification and return FAILURE
|
/* Some calls do not succeed in simplification and return FAILURE
|
even though there is no error; e.g. variable references to
|
even though there is no error; e.g. variable references to
|
PARAMETER arrays. */
|
PARAMETER arrays. */
|
if (!gfc_is_constant_expr (e))
|
if (!gfc_is_constant_expr (e))
|
t = SUCCESS;
|
t = SUCCESS;
|
}
|
}
|
return t;
|
return t;
|
|
|
bad_op:
|
bad_op:
|
|
|
{
|
{
|
bool real_error;
|
bool real_error;
|
if (gfc_extend_expr (e, &real_error) == SUCCESS)
|
if (gfc_extend_expr (e, &real_error) == SUCCESS)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (real_error)
|
if (real_error)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (dual_locus_error)
|
if (dual_locus_error)
|
gfc_error (msg, &op1->where, &op2->where);
|
gfc_error (msg, &op1->where, &op2->where);
|
else
|
else
|
gfc_error (msg, &e->where);
|
gfc_error (msg, &e->where);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/************** Array resolution subroutines **************/
|
/************** Array resolution subroutines **************/
|
|
|
typedef enum
|
typedef enum
|
{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
|
{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
|
comparison;
|
comparison;
|
|
|
/* Compare two integer expressions. */
|
/* Compare two integer expressions. */
|
|
|
static comparison
|
static comparison
|
compare_bound (gfc_expr *a, gfc_expr *b)
|
compare_bound (gfc_expr *a, gfc_expr *b)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (a == NULL || a->expr_type != EXPR_CONSTANT
|
if (a == NULL || a->expr_type != EXPR_CONSTANT
|
|| b == NULL || b->expr_type != EXPR_CONSTANT)
|
|| b == NULL || b->expr_type != EXPR_CONSTANT)
|
return CMP_UNKNOWN;
|
return CMP_UNKNOWN;
|
|
|
/* If either of the types isn't INTEGER, we must have
|
/* If either of the types isn't INTEGER, we must have
|
raised an error earlier. */
|
raised an error earlier. */
|
|
|
if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
|
if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
|
return CMP_UNKNOWN;
|
return CMP_UNKNOWN;
|
|
|
i = mpz_cmp (a->value.integer, b->value.integer);
|
i = mpz_cmp (a->value.integer, b->value.integer);
|
|
|
if (i < 0)
|
if (i < 0)
|
return CMP_LT;
|
return CMP_LT;
|
if (i > 0)
|
if (i > 0)
|
return CMP_GT;
|
return CMP_GT;
|
return CMP_EQ;
|
return CMP_EQ;
|
}
|
}
|
|
|
|
|
/* Compare an integer expression with an integer. */
|
/* Compare an integer expression with an integer. */
|
|
|
static comparison
|
static comparison
|
compare_bound_int (gfc_expr *a, int b)
|
compare_bound_int (gfc_expr *a, int b)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (a == NULL || a->expr_type != EXPR_CONSTANT)
|
if (a == NULL || a->expr_type != EXPR_CONSTANT)
|
return CMP_UNKNOWN;
|
return CMP_UNKNOWN;
|
|
|
if (a->ts.type != BT_INTEGER)
|
if (a->ts.type != BT_INTEGER)
|
gfc_internal_error ("compare_bound_int(): Bad expression");
|
gfc_internal_error ("compare_bound_int(): Bad expression");
|
|
|
i = mpz_cmp_si (a->value.integer, b);
|
i = mpz_cmp_si (a->value.integer, b);
|
|
|
if (i < 0)
|
if (i < 0)
|
return CMP_LT;
|
return CMP_LT;
|
if (i > 0)
|
if (i > 0)
|
return CMP_GT;
|
return CMP_GT;
|
return CMP_EQ;
|
return CMP_EQ;
|
}
|
}
|
|
|
|
|
/* Compare an integer expression with a mpz_t. */
|
/* Compare an integer expression with a mpz_t. */
|
|
|
static comparison
|
static comparison
|
compare_bound_mpz_t (gfc_expr *a, mpz_t b)
|
compare_bound_mpz_t (gfc_expr *a, mpz_t b)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (a == NULL || a->expr_type != EXPR_CONSTANT)
|
if (a == NULL || a->expr_type != EXPR_CONSTANT)
|
return CMP_UNKNOWN;
|
return CMP_UNKNOWN;
|
|
|
if (a->ts.type != BT_INTEGER)
|
if (a->ts.type != BT_INTEGER)
|
gfc_internal_error ("compare_bound_int(): Bad expression");
|
gfc_internal_error ("compare_bound_int(): Bad expression");
|
|
|
i = mpz_cmp (a->value.integer, b);
|
i = mpz_cmp (a->value.integer, b);
|
|
|
if (i < 0)
|
if (i < 0)
|
return CMP_LT;
|
return CMP_LT;
|
if (i > 0)
|
if (i > 0)
|
return CMP_GT;
|
return CMP_GT;
|
return CMP_EQ;
|
return CMP_EQ;
|
}
|
}
|
|
|
|
|
/* Compute the last value of a sequence given by a triplet.
|
/* Compute the last value of a sequence given by a triplet.
|
Return 0 if it wasn't able to compute the last value, or if the
|
Return 0 if it wasn't able to compute the last value, or if the
|
sequence if empty, and 1 otherwise. */
|
sequence if empty, and 1 otherwise. */
|
|
|
static int
|
static int
|
compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
|
compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
|
gfc_expr *stride, mpz_t last)
|
gfc_expr *stride, mpz_t last)
|
{
|
{
|
mpz_t rem;
|
mpz_t rem;
|
|
|
if (start == NULL || start->expr_type != EXPR_CONSTANT
|
if (start == NULL || start->expr_type != EXPR_CONSTANT
|
|| end == NULL || end->expr_type != EXPR_CONSTANT
|
|| end == NULL || end->expr_type != EXPR_CONSTANT
|
|| (stride != NULL && stride->expr_type != EXPR_CONSTANT))
|
|| (stride != NULL && stride->expr_type != EXPR_CONSTANT))
|
return 0;
|
return 0;
|
|
|
if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
|
if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
|
|| (stride != NULL && stride->ts.type != BT_INTEGER))
|
|| (stride != NULL && stride->ts.type != BT_INTEGER))
|
return 0;
|
return 0;
|
|
|
if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
|
if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
|
{
|
{
|
if (compare_bound (start, end) == CMP_GT)
|
if (compare_bound (start, end) == CMP_GT)
|
return 0;
|
return 0;
|
mpz_set (last, end->value.integer);
|
mpz_set (last, end->value.integer);
|
return 1;
|
return 1;
|
}
|
}
|
|
|
if (compare_bound_int (stride, 0) == CMP_GT)
|
if (compare_bound_int (stride, 0) == CMP_GT)
|
{
|
{
|
/* Stride is positive */
|
/* Stride is positive */
|
if (mpz_cmp (start->value.integer, end->value.integer) > 0)
|
if (mpz_cmp (start->value.integer, end->value.integer) > 0)
|
return 0;
|
return 0;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Stride is negative */
|
/* Stride is negative */
|
if (mpz_cmp (start->value.integer, end->value.integer) < 0)
|
if (mpz_cmp (start->value.integer, end->value.integer) < 0)
|
return 0;
|
return 0;
|
}
|
}
|
|
|
mpz_init (rem);
|
mpz_init (rem);
|
mpz_sub (rem, end->value.integer, start->value.integer);
|
mpz_sub (rem, end->value.integer, start->value.integer);
|
mpz_tdiv_r (rem, rem, stride->value.integer);
|
mpz_tdiv_r (rem, rem, stride->value.integer);
|
mpz_sub (last, end->value.integer, rem);
|
mpz_sub (last, end->value.integer, rem);
|
mpz_clear (rem);
|
mpz_clear (rem);
|
|
|
return 1;
|
return 1;
|
}
|
}
|
|
|
|
|
/* Compare a single dimension of an array reference to the array
|
/* Compare a single dimension of an array reference to the array
|
specification. */
|
specification. */
|
|
|
static gfc_try
|
static gfc_try
|
check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
|
check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
|
{
|
{
|
mpz_t last_value;
|
mpz_t last_value;
|
|
|
/* Given start, end and stride values, calculate the minimum and
|
/* Given start, end and stride values, calculate the minimum and
|
maximum referenced indexes. */
|
maximum referenced indexes. */
|
|
|
switch (ar->dimen_type[i])
|
switch (ar->dimen_type[i])
|
{
|
{
|
case DIMEN_VECTOR:
|
case DIMEN_VECTOR:
|
break;
|
break;
|
|
|
case DIMEN_ELEMENT:
|
case DIMEN_ELEMENT:
|
if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
|
if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
|
{
|
{
|
gfc_warning ("Array reference at %L is out of bounds "
|
gfc_warning ("Array reference at %L is out of bounds "
|
"(%ld < %ld) in dimension %d", &ar->c_where[i],
|
"(%ld < %ld) in dimension %d", &ar->c_where[i],
|
mpz_get_si (ar->start[i]->value.integer),
|
mpz_get_si (ar->start[i]->value.integer),
|
mpz_get_si (as->lower[i]->value.integer), i+1);
|
mpz_get_si (as->lower[i]->value.integer), i+1);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
|
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
|
{
|
{
|
gfc_warning ("Array reference at %L is out of bounds "
|
gfc_warning ("Array reference at %L is out of bounds "
|
"(%ld > %ld) in dimension %d", &ar->c_where[i],
|
"(%ld > %ld) in dimension %d", &ar->c_where[i],
|
mpz_get_si (ar->start[i]->value.integer),
|
mpz_get_si (ar->start[i]->value.integer),
|
mpz_get_si (as->upper[i]->value.integer), i+1);
|
mpz_get_si (as->upper[i]->value.integer), i+1);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case DIMEN_RANGE:
|
case DIMEN_RANGE:
|
{
|
{
|
#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
|
#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
|
#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
|
#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
|
|
|
comparison comp_start_end = compare_bound (AR_START, AR_END);
|
comparison comp_start_end = compare_bound (AR_START, AR_END);
|
|
|
/* Check for zero stride, which is not allowed. */
|
/* Check for zero stride, which is not allowed. */
|
if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
|
if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
|
{
|
{
|
gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
|
gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* if start == len || (stride > 0 && start < len)
|
/* if start == len || (stride > 0 && start < len)
|
|| (stride < 0 && start > len),
|
|| (stride < 0 && start > len),
|
then the array section contains at least one element. In this
|
then the array section contains at least one element. In this
|
case, there is an out-of-bounds access if
|
case, there is an out-of-bounds access if
|
(start < lower || start > upper). */
|
(start < lower || start > upper). */
|
if (compare_bound (AR_START, AR_END) == CMP_EQ
|
if (compare_bound (AR_START, AR_END) == CMP_EQ
|
|| ((compare_bound_int (ar->stride[i], 0) == CMP_GT
|
|| ((compare_bound_int (ar->stride[i], 0) == CMP_GT
|
|| ar->stride[i] == NULL) && comp_start_end == CMP_LT)
|
|| ar->stride[i] == NULL) && comp_start_end == CMP_LT)
|
|| (compare_bound_int (ar->stride[i], 0) == CMP_LT
|
|| (compare_bound_int (ar->stride[i], 0) == CMP_LT
|
&& comp_start_end == CMP_GT))
|
&& comp_start_end == CMP_GT))
|
{
|
{
|
if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
|
if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
|
{
|
{
|
gfc_warning ("Lower array reference at %L is out of bounds "
|
gfc_warning ("Lower array reference at %L is out of bounds "
|
"(%ld < %ld) in dimension %d", &ar->c_where[i],
|
"(%ld < %ld) in dimension %d", &ar->c_where[i],
|
mpz_get_si (AR_START->value.integer),
|
mpz_get_si (AR_START->value.integer),
|
mpz_get_si (as->lower[i]->value.integer), i+1);
|
mpz_get_si (as->lower[i]->value.integer), i+1);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
|
if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
|
{
|
{
|
gfc_warning ("Lower array reference at %L is out of bounds "
|
gfc_warning ("Lower array reference at %L is out of bounds "
|
"(%ld > %ld) in dimension %d", &ar->c_where[i],
|
"(%ld > %ld) in dimension %d", &ar->c_where[i],
|
mpz_get_si (AR_START->value.integer),
|
mpz_get_si (AR_START->value.integer),
|
mpz_get_si (as->upper[i]->value.integer), i+1);
|
mpz_get_si (as->upper[i]->value.integer), i+1);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
}
|
}
|
|
|
/* If we can compute the highest index of the array section,
|
/* If we can compute the highest index of the array section,
|
then it also has to be between lower and upper. */
|
then it also has to be between lower and upper. */
|
mpz_init (last_value);
|
mpz_init (last_value);
|
if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
|
if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
|
last_value))
|
last_value))
|
{
|
{
|
if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
|
if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
|
{
|
{
|
gfc_warning ("Upper array reference at %L is out of bounds "
|
gfc_warning ("Upper array reference at %L is out of bounds "
|
"(%ld < %ld) in dimension %d", &ar->c_where[i],
|
"(%ld < %ld) in dimension %d", &ar->c_where[i],
|
mpz_get_si (last_value),
|
mpz_get_si (last_value),
|
mpz_get_si (as->lower[i]->value.integer), i+1);
|
mpz_get_si (as->lower[i]->value.integer), i+1);
|
mpz_clear (last_value);
|
mpz_clear (last_value);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
|
if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
|
{
|
{
|
gfc_warning ("Upper array reference at %L is out of bounds "
|
gfc_warning ("Upper array reference at %L is out of bounds "
|
"(%ld > %ld) in dimension %d", &ar->c_where[i],
|
"(%ld > %ld) in dimension %d", &ar->c_where[i],
|
mpz_get_si (last_value),
|
mpz_get_si (last_value),
|
mpz_get_si (as->upper[i]->value.integer), i+1);
|
mpz_get_si (as->upper[i]->value.integer), i+1);
|
mpz_clear (last_value);
|
mpz_clear (last_value);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
}
|
}
|
mpz_clear (last_value);
|
mpz_clear (last_value);
|
|
|
#undef AR_START
|
#undef AR_START
|
#undef AR_END
|
#undef AR_END
|
}
|
}
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("check_dimension(): Bad array reference");
|
gfc_internal_error ("check_dimension(): Bad array reference");
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Compare an array reference with an array specification. */
|
/* Compare an array reference with an array specification. */
|
|
|
static gfc_try
|
static gfc_try
|
compare_spec_to_ref (gfc_array_ref *ar)
|
compare_spec_to_ref (gfc_array_ref *ar)
|
{
|
{
|
gfc_array_spec *as;
|
gfc_array_spec *as;
|
int i;
|
int i;
|
|
|
as = ar->as;
|
as = ar->as;
|
i = as->rank - 1;
|
i = as->rank - 1;
|
/* TODO: Full array sections are only allowed as actual parameters. */
|
/* TODO: Full array sections are only allowed as actual parameters. */
|
if (as->type == AS_ASSUMED_SIZE
|
if (as->type == AS_ASSUMED_SIZE
|
&& (/*ar->type == AR_FULL
|
&& (/*ar->type == AR_FULL
|
||*/ (ar->type == AR_SECTION
|
||*/ (ar->type == AR_SECTION
|
&& ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
|
&& ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
|
{
|
{
|
gfc_error ("Rightmost upper bound of assumed size array section "
|
gfc_error ("Rightmost upper bound of assumed size array section "
|
"not specified at %L", &ar->where);
|
"not specified at %L", &ar->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (ar->type == AR_FULL)
|
if (ar->type == AR_FULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (as->rank != ar->dimen)
|
if (as->rank != ar->dimen)
|
{
|
{
|
gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
|
gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
|
&ar->where, ar->dimen, as->rank);
|
&ar->where, ar->dimen, as->rank);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
for (i = 0; i < as->rank; i++)
|
for (i = 0; i < as->rank; i++)
|
if (check_dimension (i, ar, as) == FAILURE)
|
if (check_dimension (i, ar, as) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve one part of an array index. */
|
/* Resolve one part of an array index. */
|
|
|
gfc_try
|
gfc_try
|
gfc_resolve_index (gfc_expr *index, int check_scalar)
|
gfc_resolve_index (gfc_expr *index, int check_scalar)
|
{
|
{
|
gfc_typespec ts;
|
gfc_typespec ts;
|
|
|
if (index == NULL)
|
if (index == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (gfc_resolve_expr (index) == FAILURE)
|
if (gfc_resolve_expr (index) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (check_scalar && index->rank != 0)
|
if (check_scalar && index->rank != 0)
|
{
|
{
|
gfc_error ("Array index at %L must be scalar", &index->where);
|
gfc_error ("Array index at %L must be scalar", &index->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
|
if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
|
{
|
{
|
gfc_error ("Array index at %L must be of INTEGER type, found %s",
|
gfc_error ("Array index at %L must be of INTEGER type, found %s",
|
&index->where, gfc_basic_typename (index->ts.type));
|
&index->where, gfc_basic_typename (index->ts.type));
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (index->ts.type == BT_REAL)
|
if (index->ts.type == BT_REAL)
|
if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
|
if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
|
&index->where) == FAILURE)
|
&index->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (index->ts.kind != gfc_index_integer_kind
|
if (index->ts.kind != gfc_index_integer_kind
|
|| index->ts.type != BT_INTEGER)
|
|| index->ts.type != BT_INTEGER)
|
{
|
{
|
gfc_clear_ts (&ts);
|
gfc_clear_ts (&ts);
|
ts.type = BT_INTEGER;
|
ts.type = BT_INTEGER;
|
ts.kind = gfc_index_integer_kind;
|
ts.kind = gfc_index_integer_kind;
|
|
|
gfc_convert_type_warn (index, &ts, 2, 0);
|
gfc_convert_type_warn (index, &ts, 2, 0);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* Resolve a dim argument to an intrinsic function. */
|
/* Resolve a dim argument to an intrinsic function. */
|
|
|
gfc_try
|
gfc_try
|
gfc_resolve_dim_arg (gfc_expr *dim)
|
gfc_resolve_dim_arg (gfc_expr *dim)
|
{
|
{
|
if (dim == NULL)
|
if (dim == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (gfc_resolve_expr (dim) == FAILURE)
|
if (gfc_resolve_expr (dim) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim->rank != 0)
|
if (dim->rank != 0)
|
{
|
{
|
gfc_error ("Argument dim at %L must be scalar", &dim->where);
|
gfc_error ("Argument dim at %L must be scalar", &dim->where);
|
return FAILURE;
|
return FAILURE;
|
|
|
}
|
}
|
|
|
if (dim->ts.type != BT_INTEGER)
|
if (dim->ts.type != BT_INTEGER)
|
{
|
{
|
gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
|
gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (dim->ts.kind != gfc_index_integer_kind)
|
if (dim->ts.kind != gfc_index_integer_kind)
|
{
|
{
|
gfc_typespec ts;
|
gfc_typespec ts;
|
|
|
gfc_clear_ts (&ts);
|
gfc_clear_ts (&ts);
|
ts.type = BT_INTEGER;
|
ts.type = BT_INTEGER;
|
ts.kind = gfc_index_integer_kind;
|
ts.kind = gfc_index_integer_kind;
|
|
|
gfc_convert_type_warn (dim, &ts, 2, 0);
|
gfc_convert_type_warn (dim, &ts, 2, 0);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* Given an expression that contains array references, update those array
|
/* Given an expression that contains array references, update those array
|
references to point to the right array specifications. While this is
|
references to point to the right array specifications. While this is
|
filled in during matching, this information is difficult to save and load
|
filled in during matching, this information is difficult to save and load
|
in a module, so we take care of it here.
|
in a module, so we take care of it here.
|
|
|
The idea here is that the original array reference comes from the
|
The idea here is that the original array reference comes from the
|
base symbol. We traverse the list of reference structures, setting
|
base symbol. We traverse the list of reference structures, setting
|
the stored reference to references. Component references can
|
the stored reference to references. Component references can
|
provide an additional array specification. */
|
provide an additional array specification. */
|
|
|
static void
|
static void
|
find_array_spec (gfc_expr *e)
|
find_array_spec (gfc_expr *e)
|
{
|
{
|
gfc_array_spec *as;
|
gfc_array_spec *as;
|
gfc_component *c;
|
gfc_component *c;
|
gfc_symbol *derived;
|
gfc_symbol *derived;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
|
|
if (e->symtree->n.sym->ts.type == BT_CLASS)
|
if (e->symtree->n.sym->ts.type == BT_CLASS)
|
as = e->symtree->n.sym->ts.u.derived->components->as;
|
as = e->symtree->n.sym->ts.u.derived->components->as;
|
else
|
else
|
as = e->symtree->n.sym->as;
|
as = e->symtree->n.sym->as;
|
derived = NULL;
|
derived = NULL;
|
|
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
switch (ref->type)
|
switch (ref->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
if (as == NULL)
|
if (as == NULL)
|
gfc_internal_error ("find_array_spec(): Missing spec");
|
gfc_internal_error ("find_array_spec(): Missing spec");
|
|
|
ref->u.ar.as = as;
|
ref->u.ar.as = as;
|
as = NULL;
|
as = NULL;
|
break;
|
break;
|
|
|
case REF_COMPONENT:
|
case REF_COMPONENT:
|
if (derived == NULL)
|
if (derived == NULL)
|
derived = e->symtree->n.sym->ts.u.derived;
|
derived = e->symtree->n.sym->ts.u.derived;
|
|
|
if (derived->attr.is_class)
|
if (derived->attr.is_class)
|
derived = derived->components->ts.u.derived;
|
derived = derived->components->ts.u.derived;
|
|
|
c = derived->components;
|
c = derived->components;
|
|
|
for (; c; c = c->next)
|
for (; c; c = c->next)
|
if (c == ref->u.c.component)
|
if (c == ref->u.c.component)
|
{
|
{
|
/* Track the sequence of component references. */
|
/* Track the sequence of component references. */
|
if (c->ts.type == BT_DERIVED)
|
if (c->ts.type == BT_DERIVED)
|
derived = c->ts.u.derived;
|
derived = c->ts.u.derived;
|
break;
|
break;
|
}
|
}
|
|
|
if (c == NULL)
|
if (c == NULL)
|
gfc_internal_error ("find_array_spec(): Component not found");
|
gfc_internal_error ("find_array_spec(): Component not found");
|
|
|
if (c->attr.dimension)
|
if (c->attr.dimension)
|
{
|
{
|
if (as != NULL)
|
if (as != NULL)
|
gfc_internal_error ("find_array_spec(): unused as(1)");
|
gfc_internal_error ("find_array_spec(): unused as(1)");
|
as = c->as;
|
as = c->as;
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
break;
|
break;
|
}
|
}
|
|
|
if (as != NULL)
|
if (as != NULL)
|
gfc_internal_error ("find_array_spec(): unused as(2)");
|
gfc_internal_error ("find_array_spec(): unused as(2)");
|
}
|
}
|
|
|
|
|
/* Resolve an array reference. */
|
/* Resolve an array reference. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_array_ref (gfc_array_ref *ar)
|
resolve_array_ref (gfc_array_ref *ar)
|
{
|
{
|
int i, check_scalar;
|
int i, check_scalar;
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
|
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
|
|
|
if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
|
if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
|
if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
|
if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
e = ar->start[i];
|
e = ar->start[i];
|
|
|
if (ar->dimen_type[i] == DIMEN_UNKNOWN)
|
if (ar->dimen_type[i] == DIMEN_UNKNOWN)
|
switch (e->rank)
|
switch (e->rank)
|
{
|
{
|
case 0:
|
case 0:
|
ar->dimen_type[i] = DIMEN_ELEMENT;
|
ar->dimen_type[i] = DIMEN_ELEMENT;
|
break;
|
break;
|
|
|
case 1:
|
case 1:
|
ar->dimen_type[i] = DIMEN_VECTOR;
|
ar->dimen_type[i] = DIMEN_VECTOR;
|
if (e->expr_type == EXPR_VARIABLE
|
if (e->expr_type == EXPR_VARIABLE
|
&& e->symtree->n.sym->ts.type == BT_DERIVED)
|
&& e->symtree->n.sym->ts.type == BT_DERIVED)
|
ar->start[i] = gfc_get_parentheses (e);
|
ar->start[i] = gfc_get_parentheses (e);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_error ("Array index at %L is an array of rank %d",
|
gfc_error ("Array index at %L is an array of rank %d",
|
&ar->c_where[i], e->rank);
|
&ar->c_where[i], e->rank);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* If the reference type is unknown, figure out what kind it is. */
|
/* If the reference type is unknown, figure out what kind it is. */
|
|
|
if (ar->type == AR_UNKNOWN)
|
if (ar->type == AR_UNKNOWN)
|
{
|
{
|
ar->type = AR_ELEMENT;
|
ar->type = AR_ELEMENT;
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
if (ar->dimen_type[i] == DIMEN_RANGE
|
if (ar->dimen_type[i] == DIMEN_RANGE
|
|| ar->dimen_type[i] == DIMEN_VECTOR)
|
|| ar->dimen_type[i] == DIMEN_VECTOR)
|
{
|
{
|
ar->type = AR_SECTION;
|
ar->type = AR_SECTION;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
|
if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
resolve_substring (gfc_ref *ref)
|
resolve_substring (gfc_ref *ref)
|
{
|
{
|
int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
|
int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
|
|
|
if (ref->u.ss.start != NULL)
|
if (ref->u.ss.start != NULL)
|
{
|
{
|
if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
|
if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (ref->u.ss.start->ts.type != BT_INTEGER)
|
if (ref->u.ss.start->ts.type != BT_INTEGER)
|
{
|
{
|
gfc_error ("Substring start index at %L must be of type INTEGER",
|
gfc_error ("Substring start index at %L must be of type INTEGER",
|
&ref->u.ss.start->where);
|
&ref->u.ss.start->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (ref->u.ss.start->rank != 0)
|
if (ref->u.ss.start->rank != 0)
|
{
|
{
|
gfc_error ("Substring start index at %L must be scalar",
|
gfc_error ("Substring start index at %L must be scalar",
|
&ref->u.ss.start->where);
|
&ref->u.ss.start->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
|
if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
|
&& (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
|
&& (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
|
|| compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
|
|| compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
|
{
|
{
|
gfc_error ("Substring start index at %L is less than one",
|
gfc_error ("Substring start index at %L is less than one",
|
&ref->u.ss.start->where);
|
&ref->u.ss.start->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
if (ref->u.ss.end != NULL)
|
if (ref->u.ss.end != NULL)
|
{
|
{
|
if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
|
if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (ref->u.ss.end->ts.type != BT_INTEGER)
|
if (ref->u.ss.end->ts.type != BT_INTEGER)
|
{
|
{
|
gfc_error ("Substring end index at %L must be of type INTEGER",
|
gfc_error ("Substring end index at %L must be of type INTEGER",
|
&ref->u.ss.end->where);
|
&ref->u.ss.end->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (ref->u.ss.end->rank != 0)
|
if (ref->u.ss.end->rank != 0)
|
{
|
{
|
gfc_error ("Substring end index at %L must be scalar",
|
gfc_error ("Substring end index at %L must be scalar",
|
&ref->u.ss.end->where);
|
&ref->u.ss.end->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (ref->u.ss.length != NULL
|
if (ref->u.ss.length != NULL
|
&& compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
|
&& compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
|
&& (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
|
&& (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
|
|| compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
|
|| compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
|
{
|
{
|
gfc_error ("Substring end index at %L exceeds the string length",
|
gfc_error ("Substring end index at %L exceeds the string length",
|
&ref->u.ss.start->where);
|
&ref->u.ss.start->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (compare_bound_mpz_t (ref->u.ss.end,
|
if (compare_bound_mpz_t (ref->u.ss.end,
|
gfc_integer_kinds[k].huge) == CMP_GT
|
gfc_integer_kinds[k].huge) == CMP_GT
|
&& (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
|
&& (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
|
|| compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
|
|| compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
|
{
|
{
|
gfc_error ("Substring end index at %L is too large",
|
gfc_error ("Substring end index at %L is too large",
|
&ref->u.ss.end->where);
|
&ref->u.ss.end->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* This function supplies missing substring charlens. */
|
/* This function supplies missing substring charlens. */
|
|
|
void
|
void
|
gfc_resolve_substring_charlen (gfc_expr *e)
|
gfc_resolve_substring_charlen (gfc_expr *e)
|
{
|
{
|
gfc_ref *char_ref;
|
gfc_ref *char_ref;
|
gfc_expr *start, *end;
|
gfc_expr *start, *end;
|
|
|
for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
|
for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
|
if (char_ref->type == REF_SUBSTRING)
|
if (char_ref->type == REF_SUBSTRING)
|
break;
|
break;
|
|
|
if (!char_ref)
|
if (!char_ref)
|
return;
|
return;
|
|
|
gcc_assert (char_ref->next == NULL);
|
gcc_assert (char_ref->next == NULL);
|
|
|
if (e->ts.u.cl)
|
if (e->ts.u.cl)
|
{
|
{
|
if (e->ts.u.cl->length)
|
if (e->ts.u.cl->length)
|
gfc_free_expr (e->ts.u.cl->length);
|
gfc_free_expr (e->ts.u.cl->length);
|
else if (e->expr_type == EXPR_VARIABLE
|
else if (e->expr_type == EXPR_VARIABLE
|
&& e->symtree->n.sym->attr.dummy)
|
&& e->symtree->n.sym->attr.dummy)
|
return;
|
return;
|
}
|
}
|
|
|
e->ts.type = BT_CHARACTER;
|
e->ts.type = BT_CHARACTER;
|
e->ts.kind = gfc_default_character_kind;
|
e->ts.kind = gfc_default_character_kind;
|
|
|
if (!e->ts.u.cl)
|
if (!e->ts.u.cl)
|
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
|
|
if (char_ref->u.ss.start)
|
if (char_ref->u.ss.start)
|
start = gfc_copy_expr (char_ref->u.ss.start);
|
start = gfc_copy_expr (char_ref->u.ss.start);
|
else
|
else
|
start = gfc_int_expr (1);
|
start = gfc_int_expr (1);
|
|
|
if (char_ref->u.ss.end)
|
if (char_ref->u.ss.end)
|
end = gfc_copy_expr (char_ref->u.ss.end);
|
end = gfc_copy_expr (char_ref->u.ss.end);
|
else if (e->expr_type == EXPR_VARIABLE)
|
else if (e->expr_type == EXPR_VARIABLE)
|
end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
|
end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
|
else
|
else
|
end = NULL;
|
end = NULL;
|
|
|
if (!start || !end)
|
if (!start || !end)
|
return;
|
return;
|
|
|
/* Length = (end - start +1). */
|
/* Length = (end - start +1). */
|
e->ts.u.cl->length = gfc_subtract (end, start);
|
e->ts.u.cl->length = gfc_subtract (end, start);
|
e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1));
|
e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1));
|
|
|
e->ts.u.cl->length->ts.type = BT_INTEGER;
|
e->ts.u.cl->length->ts.type = BT_INTEGER;
|
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
|
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
|
|
|
/* Make sure that the length is simplified. */
|
/* Make sure that the length is simplified. */
|
gfc_simplify_expr (e->ts.u.cl->length, 1);
|
gfc_simplify_expr (e->ts.u.cl->length, 1);
|
gfc_resolve_expr (e->ts.u.cl->length);
|
gfc_resolve_expr (e->ts.u.cl->length);
|
}
|
}
|
|
|
|
|
/* Resolve subtype references. */
|
/* Resolve subtype references. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_ref (gfc_expr *expr)
|
resolve_ref (gfc_expr *expr)
|
{
|
{
|
int current_part_dimension, n_components, seen_part_dimension;
|
int current_part_dimension, n_components, seen_part_dimension;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
|
|
for (ref = expr->ref; ref; ref = ref->next)
|
for (ref = expr->ref; ref; ref = ref->next)
|
if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
|
if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
|
{
|
{
|
find_array_spec (expr);
|
find_array_spec (expr);
|
break;
|
break;
|
}
|
}
|
|
|
for (ref = expr->ref; ref; ref = ref->next)
|
for (ref = expr->ref; ref; ref = ref->next)
|
switch (ref->type)
|
switch (ref->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
if (resolve_array_ref (&ref->u.ar) == FAILURE)
|
if (resolve_array_ref (&ref->u.ar) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
break;
|
break;
|
|
|
case REF_COMPONENT:
|
case REF_COMPONENT:
|
break;
|
break;
|
|
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
resolve_substring (ref);
|
resolve_substring (ref);
|
break;
|
break;
|
}
|
}
|
|
|
/* Check constraints on part references. */
|
/* Check constraints on part references. */
|
|
|
current_part_dimension = 0;
|
current_part_dimension = 0;
|
seen_part_dimension = 0;
|
seen_part_dimension = 0;
|
n_components = 0;
|
n_components = 0;
|
|
|
for (ref = expr->ref; ref; ref = ref->next)
|
for (ref = expr->ref; ref; ref = ref->next)
|
{
|
{
|
switch (ref->type)
|
switch (ref->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
switch (ref->u.ar.type)
|
switch (ref->u.ar.type)
|
{
|
{
|
case AR_FULL:
|
case AR_FULL:
|
case AR_SECTION:
|
case AR_SECTION:
|
current_part_dimension = 1;
|
current_part_dimension = 1;
|
break;
|
break;
|
|
|
case AR_ELEMENT:
|
case AR_ELEMENT:
|
current_part_dimension = 0;
|
current_part_dimension = 0;
|
break;
|
break;
|
|
|
case AR_UNKNOWN:
|
case AR_UNKNOWN:
|
gfc_internal_error ("resolve_ref(): Bad array reference");
|
gfc_internal_error ("resolve_ref(): Bad array reference");
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case REF_COMPONENT:
|
case REF_COMPONENT:
|
if (current_part_dimension || seen_part_dimension)
|
if (current_part_dimension || seen_part_dimension)
|
{
|
{
|
/* F03:C614. */
|
/* F03:C614. */
|
if (ref->u.c.component->attr.pointer
|
if (ref->u.c.component->attr.pointer
|
|| ref->u.c.component->attr.proc_pointer)
|
|| ref->u.c.component->attr.proc_pointer)
|
{
|
{
|
gfc_error ("Component to the right of a part reference "
|
gfc_error ("Component to the right of a part reference "
|
"with nonzero rank must not have the POINTER "
|
"with nonzero rank must not have the POINTER "
|
"attribute at %L", &expr->where);
|
"attribute at %L", &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (ref->u.c.component->attr.allocatable)
|
else if (ref->u.c.component->attr.allocatable)
|
{
|
{
|
gfc_error ("Component to the right of a part reference "
|
gfc_error ("Component to the right of a part reference "
|
"with nonzero rank must not have the ALLOCATABLE "
|
"with nonzero rank must not have the ALLOCATABLE "
|
"attribute at %L", &expr->where);
|
"attribute at %L", &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
n_components++;
|
n_components++;
|
break;
|
break;
|
|
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
break;
|
break;
|
}
|
}
|
|
|
if (((ref->type == REF_COMPONENT && n_components > 1)
|
if (((ref->type == REF_COMPONENT && n_components > 1)
|
|| ref->next == NULL)
|
|| ref->next == NULL)
|
&& current_part_dimension
|
&& current_part_dimension
|
&& seen_part_dimension)
|
&& seen_part_dimension)
|
{
|
{
|
gfc_error ("Two or more part references with nonzero rank must "
|
gfc_error ("Two or more part references with nonzero rank must "
|
"not be specified at %L", &expr->where);
|
"not be specified at %L", &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (ref->type == REF_COMPONENT)
|
if (ref->type == REF_COMPONENT)
|
{
|
{
|
if (current_part_dimension)
|
if (current_part_dimension)
|
seen_part_dimension = 1;
|
seen_part_dimension = 1;
|
|
|
/* reset to make sure */
|
/* reset to make sure */
|
current_part_dimension = 0;
|
current_part_dimension = 0;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Given an expression, determine its shape. This is easier than it sounds.
|
/* Given an expression, determine its shape. This is easier than it sounds.
|
Leaves the shape array NULL if it is not possible to determine the shape. */
|
Leaves the shape array NULL if it is not possible to determine the shape. */
|
|
|
static void
|
static void
|
expression_shape (gfc_expr *e)
|
expression_shape (gfc_expr *e)
|
{
|
{
|
mpz_t array[GFC_MAX_DIMENSIONS];
|
mpz_t array[GFC_MAX_DIMENSIONS];
|
int i;
|
int i;
|
|
|
if (e->rank == 0 || e->shape != NULL)
|
if (e->rank == 0 || e->shape != NULL)
|
return;
|
return;
|
|
|
for (i = 0; i < e->rank; i++)
|
for (i = 0; i < e->rank; i++)
|
if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
|
if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
|
goto fail;
|
goto fail;
|
|
|
e->shape = gfc_get_shape (e->rank);
|
e->shape = gfc_get_shape (e->rank);
|
|
|
memcpy (e->shape, array, e->rank * sizeof (mpz_t));
|
memcpy (e->shape, array, e->rank * sizeof (mpz_t));
|
|
|
return;
|
return;
|
|
|
fail:
|
fail:
|
for (i--; i >= 0; i--)
|
for (i--; i >= 0; i--)
|
mpz_clear (array[i]);
|
mpz_clear (array[i]);
|
}
|
}
|
|
|
|
|
/* Given a variable expression node, compute the rank of the expression by
|
/* Given a variable expression node, compute the rank of the expression by
|
examining the base symbol and any reference structures it may have. */
|
examining the base symbol and any reference structures it may have. */
|
|
|
static void
|
static void
|
expression_rank (gfc_expr *e)
|
expression_rank (gfc_expr *e)
|
{
|
{
|
gfc_ref *ref;
|
gfc_ref *ref;
|
int i, rank;
|
int i, rank;
|
|
|
/* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
|
/* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
|
could lead to serious confusion... */
|
could lead to serious confusion... */
|
gcc_assert (e->expr_type != EXPR_COMPCALL);
|
gcc_assert (e->expr_type != EXPR_COMPCALL);
|
|
|
if (e->ref == NULL)
|
if (e->ref == NULL)
|
{
|
{
|
if (e->expr_type == EXPR_ARRAY)
|
if (e->expr_type == EXPR_ARRAY)
|
goto done;
|
goto done;
|
/* Constructors can have a rank different from one via RESHAPE(). */
|
/* Constructors can have a rank different from one via RESHAPE(). */
|
|
|
if (e->symtree == NULL)
|
if (e->symtree == NULL)
|
{
|
{
|
e->rank = 0;
|
e->rank = 0;
|
goto done;
|
goto done;
|
}
|
}
|
|
|
e->rank = (e->symtree->n.sym->as == NULL)
|
e->rank = (e->symtree->n.sym->as == NULL)
|
? 0 : e->symtree->n.sym->as->rank;
|
? 0 : e->symtree->n.sym->as->rank;
|
goto done;
|
goto done;
|
}
|
}
|
|
|
rank = 0;
|
rank = 0;
|
|
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
{
|
{
|
if (ref->type != REF_ARRAY)
|
if (ref->type != REF_ARRAY)
|
continue;
|
continue;
|
|
|
if (ref->u.ar.type == AR_FULL)
|
if (ref->u.ar.type == AR_FULL)
|
{
|
{
|
rank = ref->u.ar.as->rank;
|
rank = ref->u.ar.as->rank;
|
break;
|
break;
|
}
|
}
|
|
|
if (ref->u.ar.type == AR_SECTION)
|
if (ref->u.ar.type == AR_SECTION)
|
{
|
{
|
/* Figure out the rank of the section. */
|
/* Figure out the rank of the section. */
|
if (rank != 0)
|
if (rank != 0)
|
gfc_internal_error ("expression_rank(): Two array specs");
|
gfc_internal_error ("expression_rank(): Two array specs");
|
|
|
for (i = 0; i < ref->u.ar.dimen; i++)
|
for (i = 0; i < ref->u.ar.dimen; i++)
|
if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
|
if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
|
|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
|
|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
|
rank++;
|
rank++;
|
|
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
e->rank = rank;
|
e->rank = rank;
|
|
|
done:
|
done:
|
expression_shape (e);
|
expression_shape (e);
|
}
|
}
|
|
|
|
|
/* Resolve a variable expression. */
|
/* Resolve a variable expression. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_variable (gfc_expr *e)
|
resolve_variable (gfc_expr *e)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_try t;
|
gfc_try t;
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
|
|
if (e->symtree == NULL)
|
if (e->symtree == NULL)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (e->ref && resolve_ref (e) == FAILURE)
|
if (e->ref && resolve_ref (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
if (sym->attr.flavor == FL_PROCEDURE
|
if (sym->attr.flavor == FL_PROCEDURE
|
&& (!sym->attr.function
|
&& (!sym->attr.function
|
|| (sym->attr.function && sym->result
|
|| (sym->attr.function && sym->result
|
&& sym->result->attr.proc_pointer
|
&& sym->result->attr.proc_pointer
|
&& !sym->result->attr.function)))
|
&& !sym->result->attr.function)))
|
{
|
{
|
e->ts.type = BT_PROCEDURE;
|
e->ts.type = BT_PROCEDURE;
|
goto resolve_procedure;
|
goto resolve_procedure;
|
}
|
}
|
|
|
if (sym->ts.type != BT_UNKNOWN)
|
if (sym->ts.type != BT_UNKNOWN)
|
gfc_variable_attr (e, &e->ts);
|
gfc_variable_attr (e, &e->ts);
|
else
|
else
|
{
|
{
|
/* Must be a simple variable reference. */
|
/* Must be a simple variable reference. */
|
if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
|
if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
e->ts = sym->ts;
|
e->ts = sym->ts;
|
}
|
}
|
|
|
if (check_assumed_size_reference (sym, e))
|
if (check_assumed_size_reference (sym, e))
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Deal with forward references to entries during resolve_code, to
|
/* Deal with forward references to entries during resolve_code, to
|
satisfy, at least partially, 12.5.2.5. */
|
satisfy, at least partially, 12.5.2.5. */
|
if (gfc_current_ns->entries
|
if (gfc_current_ns->entries
|
&& current_entry_id == sym->entry_id
|
&& current_entry_id == sym->entry_id
|
&& cs_base
|
&& cs_base
|
&& cs_base->current
|
&& cs_base->current
|
&& cs_base->current->op != EXEC_ENTRY)
|
&& cs_base->current->op != EXEC_ENTRY)
|
{
|
{
|
gfc_entry_list *entry;
|
gfc_entry_list *entry;
|
gfc_formal_arglist *formal;
|
gfc_formal_arglist *formal;
|
int n;
|
int n;
|
bool seen;
|
bool seen;
|
|
|
/* If the symbol is a dummy... */
|
/* If the symbol is a dummy... */
|
if (sym->attr.dummy && sym->ns == gfc_current_ns)
|
if (sym->attr.dummy && sym->ns == gfc_current_ns)
|
{
|
{
|
entry = gfc_current_ns->entries;
|
entry = gfc_current_ns->entries;
|
seen = false;
|
seen = false;
|
|
|
/* ...test if the symbol is a parameter of previous entries. */
|
/* ...test if the symbol is a parameter of previous entries. */
|
for (; entry && entry->id <= current_entry_id; entry = entry->next)
|
for (; entry && entry->id <= current_entry_id; entry = entry->next)
|
for (formal = entry->sym->formal; formal; formal = formal->next)
|
for (formal = entry->sym->formal; formal; formal = formal->next)
|
{
|
{
|
if (formal->sym && sym->name == formal->sym->name)
|
if (formal->sym && sym->name == formal->sym->name)
|
seen = true;
|
seen = true;
|
}
|
}
|
|
|
/* If it has not been seen as a dummy, this is an error. */
|
/* If it has not been seen as a dummy, this is an error. */
|
if (!seen)
|
if (!seen)
|
{
|
{
|
if (specification_expr)
|
if (specification_expr)
|
gfc_error ("Variable '%s', used in a specification expression"
|
gfc_error ("Variable '%s', used in a specification expression"
|
", is referenced at %L before the ENTRY statement "
|
", is referenced at %L before the ENTRY statement "
|
"in which it is a parameter",
|
"in which it is a parameter",
|
sym->name, &cs_base->current->loc);
|
sym->name, &cs_base->current->loc);
|
else
|
else
|
gfc_error ("Variable '%s' is used at %L before the ENTRY "
|
gfc_error ("Variable '%s' is used at %L before the ENTRY "
|
"statement in which it is a parameter",
|
"statement in which it is a parameter",
|
sym->name, &cs_base->current->loc);
|
sym->name, &cs_base->current->loc);
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Now do the same check on the specification expressions. */
|
/* Now do the same check on the specification expressions. */
|
specification_expr = 1;
|
specification_expr = 1;
|
if (sym->ts.type == BT_CHARACTER
|
if (sym->ts.type == BT_CHARACTER
|
&& gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
|
&& gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
|
|
if (sym->as)
|
if (sym->as)
|
for (n = 0; n < sym->as->rank; n++)
|
for (n = 0; n < sym->as->rank; n++)
|
{
|
{
|
specification_expr = 1;
|
specification_expr = 1;
|
if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
|
if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
specification_expr = 1;
|
specification_expr = 1;
|
if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
|
if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
specification_expr = 0;
|
specification_expr = 0;
|
|
|
if (t == SUCCESS)
|
if (t == SUCCESS)
|
/* Update the symbol's entry level. */
|
/* Update the symbol's entry level. */
|
sym->entry_id = current_entry_id + 1;
|
sym->entry_id = current_entry_id + 1;
|
}
|
}
|
|
|
/* If a symbol has been host_associated mark it. This is used latter,
|
/* If a symbol has been host_associated mark it. This is used latter,
|
to identify if aliasing is possible via host association. */
|
to identify if aliasing is possible via host association. */
|
if (sym->attr.flavor == FL_VARIABLE
|
if (sym->attr.flavor == FL_VARIABLE
|
&& gfc_current_ns->parent
|
&& gfc_current_ns->parent
|
&& (gfc_current_ns->parent == sym->ns
|
&& (gfc_current_ns->parent == sym->ns
|
|| (gfc_current_ns->parent->parent
|
|| (gfc_current_ns->parent->parent
|
&& gfc_current_ns->parent->parent == sym->ns)))
|
&& gfc_current_ns->parent->parent == sym->ns)))
|
sym->attr.host_assoc = 1;
|
sym->attr.host_assoc = 1;
|
|
|
resolve_procedure:
|
resolve_procedure:
|
if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
|
if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
/* Checks to see that the correct symbol has been host associated.
|
/* Checks to see that the correct symbol has been host associated.
|
The only situation where this arises is that in which a twice
|
The only situation where this arises is that in which a twice
|
contained function is parsed after the host association is made.
|
contained function is parsed after the host association is made.
|
Therefore, on detecting this, change the symbol in the expression
|
Therefore, on detecting this, change the symbol in the expression
|
and convert the array reference into an actual arglist if the old
|
and convert the array reference into an actual arglist if the old
|
symbol is a variable. */
|
symbol is a variable. */
|
static bool
|
static bool
|
check_host_association (gfc_expr *e)
|
check_host_association (gfc_expr *e)
|
{
|
{
|
gfc_symbol *sym, *old_sym;
|
gfc_symbol *sym, *old_sym;
|
gfc_symtree *st;
|
gfc_symtree *st;
|
int n;
|
int n;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
gfc_actual_arglist *arg, *tail = NULL;
|
gfc_actual_arglist *arg, *tail = NULL;
|
bool retval = e->expr_type == EXPR_FUNCTION;
|
bool retval = e->expr_type == EXPR_FUNCTION;
|
|
|
/* If the expression is the result of substitution in
|
/* If the expression is the result of substitution in
|
interface.c(gfc_extend_expr) because there is no way in
|
interface.c(gfc_extend_expr) because there is no way in
|
which the host association can be wrong. */
|
which the host association can be wrong. */
|
if (e->symtree == NULL
|
if (e->symtree == NULL
|
|| e->symtree->n.sym == NULL
|
|| e->symtree->n.sym == NULL
|
|| e->user_operator)
|
|| e->user_operator)
|
return retval;
|
return retval;
|
|
|
old_sym = e->symtree->n.sym;
|
old_sym = e->symtree->n.sym;
|
|
|
if (gfc_current_ns->parent
|
if (gfc_current_ns->parent
|
&& old_sym->ns != gfc_current_ns)
|
&& old_sym->ns != gfc_current_ns)
|
{
|
{
|
/* Use the 'USE' name so that renamed module symbols are
|
/* Use the 'USE' name so that renamed module symbols are
|
correctly handled. */
|
correctly handled. */
|
gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
|
gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
|
|
|
if (sym && old_sym != sym
|
if (sym && old_sym != sym
|
&& sym->ts.type == old_sym->ts.type
|
&& sym->ts.type == old_sym->ts.type
|
&& sym->attr.flavor == FL_PROCEDURE
|
&& sym->attr.flavor == FL_PROCEDURE
|
&& sym->attr.contained)
|
&& sym->attr.contained)
|
{
|
{
|
/* Clear the shape, since it might not be valid. */
|
/* Clear the shape, since it might not be valid. */
|
if (e->shape != NULL)
|
if (e->shape != NULL)
|
{
|
{
|
for (n = 0; n < e->rank; n++)
|
for (n = 0; n < e->rank; n++)
|
mpz_clear (e->shape[n]);
|
mpz_clear (e->shape[n]);
|
|
|
gfc_free (e->shape);
|
gfc_free (e->shape);
|
}
|
}
|
|
|
/* Give the expression the right symtree! */
|
/* Give the expression the right symtree! */
|
gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
|
gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
|
gcc_assert (st != NULL);
|
gcc_assert (st != NULL);
|
|
|
if (old_sym->attr.flavor == FL_PROCEDURE
|
if (old_sym->attr.flavor == FL_PROCEDURE
|
|| e->expr_type == EXPR_FUNCTION)
|
|| e->expr_type == EXPR_FUNCTION)
|
{
|
{
|
/* Original was function so point to the new symbol, since
|
/* Original was function so point to the new symbol, since
|
the actual argument list is already attached to the
|
the actual argument list is already attached to the
|
expression. */
|
expression. */
|
e->value.function.esym = NULL;
|
e->value.function.esym = NULL;
|
e->symtree = st;
|
e->symtree = st;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Original was variable so convert array references into
|
/* Original was variable so convert array references into
|
an actual arglist. This does not need any checking now
|
an actual arglist. This does not need any checking now
|
since gfc_resolve_function will take care of it. */
|
since gfc_resolve_function will take care of it. */
|
e->value.function.actual = NULL;
|
e->value.function.actual = NULL;
|
e->expr_type = EXPR_FUNCTION;
|
e->expr_type = EXPR_FUNCTION;
|
e->symtree = st;
|
e->symtree = st;
|
|
|
/* Ambiguity will not arise if the array reference is not
|
/* Ambiguity will not arise if the array reference is not
|
the last reference. */
|
the last reference. */
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
if (ref->type == REF_ARRAY && ref->next == NULL)
|
if (ref->type == REF_ARRAY && ref->next == NULL)
|
break;
|
break;
|
|
|
gcc_assert (ref->type == REF_ARRAY);
|
gcc_assert (ref->type == REF_ARRAY);
|
|
|
/* Grab the start expressions from the array ref and
|
/* Grab the start expressions from the array ref and
|
copy them into actual arguments. */
|
copy them into actual arguments. */
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
{
|
{
|
arg = gfc_get_actual_arglist ();
|
arg = gfc_get_actual_arglist ();
|
arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
|
arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
|
if (e->value.function.actual == NULL)
|
if (e->value.function.actual == NULL)
|
tail = e->value.function.actual = arg;
|
tail = e->value.function.actual = arg;
|
else
|
else
|
{
|
{
|
tail->next = arg;
|
tail->next = arg;
|
tail = arg;
|
tail = arg;
|
}
|
}
|
}
|
}
|
|
|
/* Dump the reference list and set the rank. */
|
/* Dump the reference list and set the rank. */
|
gfc_free_ref_list (e->ref);
|
gfc_free_ref_list (e->ref);
|
e->ref = NULL;
|
e->ref = NULL;
|
e->rank = sym->as ? sym->as->rank : 0;
|
e->rank = sym->as ? sym->as->rank : 0;
|
}
|
}
|
|
|
gfc_resolve_expr (e);
|
gfc_resolve_expr (e);
|
sym->refs++;
|
sym->refs++;
|
}
|
}
|
}
|
}
|
/* This might have changed! */
|
/* This might have changed! */
|
return e->expr_type == EXPR_FUNCTION;
|
return e->expr_type == EXPR_FUNCTION;
|
}
|
}
|
|
|
|
|
static void
|
static void
|
gfc_resolve_character_operator (gfc_expr *e)
|
gfc_resolve_character_operator (gfc_expr *e)
|
{
|
{
|
gfc_expr *op1 = e->value.op.op1;
|
gfc_expr *op1 = e->value.op.op1;
|
gfc_expr *op2 = e->value.op.op2;
|
gfc_expr *op2 = e->value.op.op2;
|
gfc_expr *e1 = NULL;
|
gfc_expr *e1 = NULL;
|
gfc_expr *e2 = NULL;
|
gfc_expr *e2 = NULL;
|
|
|
gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
|
gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
|
|
|
if (op1->ts.u.cl && op1->ts.u.cl->length)
|
if (op1->ts.u.cl && op1->ts.u.cl->length)
|
e1 = gfc_copy_expr (op1->ts.u.cl->length);
|
e1 = gfc_copy_expr (op1->ts.u.cl->length);
|
else if (op1->expr_type == EXPR_CONSTANT)
|
else if (op1->expr_type == EXPR_CONSTANT)
|
e1 = gfc_int_expr (op1->value.character.length);
|
e1 = gfc_int_expr (op1->value.character.length);
|
|
|
if (op2->ts.u.cl && op2->ts.u.cl->length)
|
if (op2->ts.u.cl && op2->ts.u.cl->length)
|
e2 = gfc_copy_expr (op2->ts.u.cl->length);
|
e2 = gfc_copy_expr (op2->ts.u.cl->length);
|
else if (op2->expr_type == EXPR_CONSTANT)
|
else if (op2->expr_type == EXPR_CONSTANT)
|
e2 = gfc_int_expr (op2->value.character.length);
|
e2 = gfc_int_expr (op2->value.character.length);
|
|
|
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
|
|
if (!e1 || !e2)
|
if (!e1 || !e2)
|
return;
|
return;
|
|
|
e->ts.u.cl->length = gfc_add (e1, e2);
|
e->ts.u.cl->length = gfc_add (e1, e2);
|
e->ts.u.cl->length->ts.type = BT_INTEGER;
|
e->ts.u.cl->length->ts.type = BT_INTEGER;
|
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
|
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
|
gfc_simplify_expr (e->ts.u.cl->length, 0);
|
gfc_simplify_expr (e->ts.u.cl->length, 0);
|
gfc_resolve_expr (e->ts.u.cl->length);
|
gfc_resolve_expr (e->ts.u.cl->length);
|
|
|
return;
|
return;
|
}
|
}
|
|
|
|
|
/* Ensure that an character expression has a charlen and, if possible, a
|
/* Ensure that an character expression has a charlen and, if possible, a
|
length expression. */
|
length expression. */
|
|
|
static void
|
static void
|
fixup_charlen (gfc_expr *e)
|
fixup_charlen (gfc_expr *e)
|
{
|
{
|
/* The cases fall through so that changes in expression type and the need
|
/* The cases fall through so that changes in expression type and the need
|
for multiple fixes are picked up. In all circumstances, a charlen should
|
for multiple fixes are picked up. In all circumstances, a charlen should
|
be available for the middle end to hang a backend_decl on. */
|
be available for the middle end to hang a backend_decl on. */
|
switch (e->expr_type)
|
switch (e->expr_type)
|
{
|
{
|
case EXPR_OP:
|
case EXPR_OP:
|
gfc_resolve_character_operator (e);
|
gfc_resolve_character_operator (e);
|
|
|
case EXPR_ARRAY:
|
case EXPR_ARRAY:
|
if (e->expr_type == EXPR_ARRAY)
|
if (e->expr_type == EXPR_ARRAY)
|
gfc_resolve_character_array_constructor (e);
|
gfc_resolve_character_array_constructor (e);
|
|
|
case EXPR_SUBSTRING:
|
case EXPR_SUBSTRING:
|
if (!e->ts.u.cl && e->ref)
|
if (!e->ts.u.cl && e->ref)
|
gfc_resolve_substring_charlen (e);
|
gfc_resolve_substring_charlen (e);
|
|
|
default:
|
default:
|
if (!e->ts.u.cl)
|
if (!e->ts.u.cl)
|
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
|
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Update an actual argument to include the passed-object for type-bound
|
/* Update an actual argument to include the passed-object for type-bound
|
procedures at the right position. */
|
procedures at the right position. */
|
|
|
static gfc_actual_arglist*
|
static gfc_actual_arglist*
|
update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
|
update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
|
const char *name)
|
const char *name)
|
{
|
{
|
gcc_assert (argpos > 0);
|
gcc_assert (argpos > 0);
|
|
|
if (argpos == 1)
|
if (argpos == 1)
|
{
|
{
|
gfc_actual_arglist* result;
|
gfc_actual_arglist* result;
|
|
|
result = gfc_get_actual_arglist ();
|
result = gfc_get_actual_arglist ();
|
result->expr = po;
|
result->expr = po;
|
result->next = lst;
|
result->next = lst;
|
if (name)
|
if (name)
|
result->name = name;
|
result->name = name;
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
if (lst)
|
if (lst)
|
lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
|
lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
|
else
|
else
|
lst = update_arglist_pass (NULL, po, argpos - 1, name);
|
lst = update_arglist_pass (NULL, po, argpos - 1, name);
|
return lst;
|
return lst;
|
}
|
}
|
|
|
|
|
/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
|
/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
|
|
|
static gfc_expr*
|
static gfc_expr*
|
extract_compcall_passed_object (gfc_expr* e)
|
extract_compcall_passed_object (gfc_expr* e)
|
{
|
{
|
gfc_expr* po;
|
gfc_expr* po;
|
|
|
gcc_assert (e->expr_type == EXPR_COMPCALL);
|
gcc_assert (e->expr_type == EXPR_COMPCALL);
|
|
|
if (e->value.compcall.base_object)
|
if (e->value.compcall.base_object)
|
po = gfc_copy_expr (e->value.compcall.base_object);
|
po = gfc_copy_expr (e->value.compcall.base_object);
|
else
|
else
|
{
|
{
|
po = gfc_get_expr ();
|
po = gfc_get_expr ();
|
po->expr_type = EXPR_VARIABLE;
|
po->expr_type = EXPR_VARIABLE;
|
po->symtree = e->symtree;
|
po->symtree = e->symtree;
|
po->ref = gfc_copy_ref (e->ref);
|
po->ref = gfc_copy_ref (e->ref);
|
po->where = e->where;
|
po->where = e->where;
|
}
|
}
|
|
|
if (gfc_resolve_expr (po) == FAILURE)
|
if (gfc_resolve_expr (po) == FAILURE)
|
return NULL;
|
return NULL;
|
|
|
return po;
|
return po;
|
}
|
}
|
|
|
|
|
/* Update the arglist of an EXPR_COMPCALL expression to include the
|
/* Update the arglist of an EXPR_COMPCALL expression to include the
|
passed-object. */
|
passed-object. */
|
|
|
static gfc_try
|
static gfc_try
|
update_compcall_arglist (gfc_expr* e)
|
update_compcall_arglist (gfc_expr* e)
|
{
|
{
|
gfc_expr* po;
|
gfc_expr* po;
|
gfc_typebound_proc* tbp;
|
gfc_typebound_proc* tbp;
|
|
|
tbp = e->value.compcall.tbp;
|
tbp = e->value.compcall.tbp;
|
|
|
if (tbp->error)
|
if (tbp->error)
|
return FAILURE;
|
return FAILURE;
|
|
|
po = extract_compcall_passed_object (e);
|
po = extract_compcall_passed_object (e);
|
if (!po)
|
if (!po)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (tbp->nopass || e->value.compcall.ignore_pass)
|
if (tbp->nopass || e->value.compcall.ignore_pass)
|
{
|
{
|
gfc_free_expr (po);
|
gfc_free_expr (po);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
gcc_assert (tbp->pass_arg_num > 0);
|
gcc_assert (tbp->pass_arg_num > 0);
|
e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
|
e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
|
tbp->pass_arg_num,
|
tbp->pass_arg_num,
|
tbp->pass_arg);
|
tbp->pass_arg);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Extract the passed object from a PPC call (a copy of it). */
|
/* Extract the passed object from a PPC call (a copy of it). */
|
|
|
static gfc_expr*
|
static gfc_expr*
|
extract_ppc_passed_object (gfc_expr *e)
|
extract_ppc_passed_object (gfc_expr *e)
|
{
|
{
|
gfc_expr *po;
|
gfc_expr *po;
|
gfc_ref **ref;
|
gfc_ref **ref;
|
|
|
po = gfc_get_expr ();
|
po = gfc_get_expr ();
|
po->expr_type = EXPR_VARIABLE;
|
po->expr_type = EXPR_VARIABLE;
|
po->symtree = e->symtree;
|
po->symtree = e->symtree;
|
po->ref = gfc_copy_ref (e->ref);
|
po->ref = gfc_copy_ref (e->ref);
|
po->where = e->where;
|
po->where = e->where;
|
|
|
/* Remove PPC reference. */
|
/* Remove PPC reference. */
|
ref = &po->ref;
|
ref = &po->ref;
|
while ((*ref)->next)
|
while ((*ref)->next)
|
ref = &(*ref)->next;
|
ref = &(*ref)->next;
|
gfc_free_ref_list (*ref);
|
gfc_free_ref_list (*ref);
|
*ref = NULL;
|
*ref = NULL;
|
|
|
if (gfc_resolve_expr (po) == FAILURE)
|
if (gfc_resolve_expr (po) == FAILURE)
|
return NULL;
|
return NULL;
|
|
|
return po;
|
return po;
|
}
|
}
|
|
|
|
|
/* Update the actual arglist of a procedure pointer component to include the
|
/* Update the actual arglist of a procedure pointer component to include the
|
passed-object. */
|
passed-object. */
|
|
|
static gfc_try
|
static gfc_try
|
update_ppc_arglist (gfc_expr* e)
|
update_ppc_arglist (gfc_expr* e)
|
{
|
{
|
gfc_expr* po;
|
gfc_expr* po;
|
gfc_component *ppc;
|
gfc_component *ppc;
|
gfc_typebound_proc* tb;
|
gfc_typebound_proc* tb;
|
|
|
if (!gfc_is_proc_ptr_comp (e, &ppc))
|
if (!gfc_is_proc_ptr_comp (e, &ppc))
|
return FAILURE;
|
return FAILURE;
|
|
|
tb = ppc->tb;
|
tb = ppc->tb;
|
|
|
if (tb->error)
|
if (tb->error)
|
return FAILURE;
|
return FAILURE;
|
else if (tb->nopass)
|
else if (tb->nopass)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
po = extract_ppc_passed_object (e);
|
po = extract_ppc_passed_object (e);
|
if (!po)
|
if (!po)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (po->rank > 0)
|
if (po->rank > 0)
|
{
|
{
|
gfc_error ("Passed-object at %L must be scalar", &e->where);
|
gfc_error ("Passed-object at %L must be scalar", &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
gcc_assert (tb->pass_arg_num > 0);
|
gcc_assert (tb->pass_arg_num > 0);
|
e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
|
e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
|
tb->pass_arg_num,
|
tb->pass_arg_num,
|
tb->pass_arg);
|
tb->pass_arg);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check that the object a TBP is called on is valid, i.e. it must not be
|
/* Check that the object a TBP is called on is valid, i.e. it must not be
|
of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
|
of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
|
|
|
static gfc_try
|
static gfc_try
|
check_typebound_baseobject (gfc_expr* e)
|
check_typebound_baseobject (gfc_expr* e)
|
{
|
{
|
gfc_expr* base;
|
gfc_expr* base;
|
|
|
base = extract_compcall_passed_object (e);
|
base = extract_compcall_passed_object (e);
|
if (!base)
|
if (!base)
|
return FAILURE;
|
return FAILURE;
|
|
|
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
|
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
|
|
|
if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
|
if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
|
{
|
{
|
gfc_error ("Base object for type-bound procedure call at %L is of"
|
gfc_error ("Base object for type-bound procedure call at %L is of"
|
" ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
|
" ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* If the procedure called is NOPASS, the base object must be scalar. */
|
/* If the procedure called is NOPASS, the base object must be scalar. */
|
if (e->value.compcall.tbp->nopass && base->rank > 0)
|
if (e->value.compcall.tbp->nopass && base->rank > 0)
|
{
|
{
|
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
|
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
|
" be scalar", &e->where);
|
" be scalar", &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
|
/* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
|
if (base->rank > 0)
|
if (base->rank > 0)
|
{
|
{
|
gfc_error ("Non-scalar base object at %L currently not implemented",
|
gfc_error ("Non-scalar base object at %L currently not implemented",
|
&e->where);
|
&e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a call to a type-bound procedure, either function or subroutine,
|
/* Resolve a call to a type-bound procedure, either function or subroutine,
|
statically from the data in an EXPR_COMPCALL expression. The adapted
|
statically from the data in an EXPR_COMPCALL expression. The adapted
|
arglist and the target-procedure symtree are returned. */
|
arglist and the target-procedure symtree are returned. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
|
resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
|
gfc_actual_arglist** actual)
|
gfc_actual_arglist** actual)
|
{
|
{
|
gcc_assert (e->expr_type == EXPR_COMPCALL);
|
gcc_assert (e->expr_type == EXPR_COMPCALL);
|
gcc_assert (!e->value.compcall.tbp->is_generic);
|
gcc_assert (!e->value.compcall.tbp->is_generic);
|
|
|
/* Update the actual arglist for PASS. */
|
/* Update the actual arglist for PASS. */
|
if (update_compcall_arglist (e) == FAILURE)
|
if (update_compcall_arglist (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
*actual = e->value.compcall.actual;
|
*actual = e->value.compcall.actual;
|
*target = e->value.compcall.tbp->u.specific;
|
*target = e->value.compcall.tbp->u.specific;
|
|
|
gfc_free_ref_list (e->ref);
|
gfc_free_ref_list (e->ref);
|
e->ref = NULL;
|
e->ref = NULL;
|
e->value.compcall.actual = NULL;
|
e->value.compcall.actual = NULL;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
|
/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
|
which of the specific bindings (if any) matches the arglist and transform
|
which of the specific bindings (if any) matches the arglist and transform
|
the expression into a call of that binding. */
|
the expression into a call of that binding. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typebound_generic_call (gfc_expr* e)
|
resolve_typebound_generic_call (gfc_expr* e)
|
{
|
{
|
gfc_typebound_proc* genproc;
|
gfc_typebound_proc* genproc;
|
const char* genname;
|
const char* genname;
|
|
|
gcc_assert (e->expr_type == EXPR_COMPCALL);
|
gcc_assert (e->expr_type == EXPR_COMPCALL);
|
genname = e->value.compcall.name;
|
genname = e->value.compcall.name;
|
genproc = e->value.compcall.tbp;
|
genproc = e->value.compcall.tbp;
|
|
|
if (!genproc->is_generic)
|
if (!genproc->is_generic)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* Try the bindings on this type and in the inheritance hierarchy. */
|
/* Try the bindings on this type and in the inheritance hierarchy. */
|
for (; genproc; genproc = genproc->overridden)
|
for (; genproc; genproc = genproc->overridden)
|
{
|
{
|
gfc_tbp_generic* g;
|
gfc_tbp_generic* g;
|
|
|
gcc_assert (genproc->is_generic);
|
gcc_assert (genproc->is_generic);
|
for (g = genproc->u.generic; g; g = g->next)
|
for (g = genproc->u.generic; g; g = g->next)
|
{
|
{
|
gfc_symbol* target;
|
gfc_symbol* target;
|
gfc_actual_arglist* args;
|
gfc_actual_arglist* args;
|
bool matches;
|
bool matches;
|
|
|
gcc_assert (g->specific);
|
gcc_assert (g->specific);
|
|
|
if (g->specific->error)
|
if (g->specific->error)
|
continue;
|
continue;
|
|
|
target = g->specific->u.specific->n.sym;
|
target = g->specific->u.specific->n.sym;
|
|
|
/* Get the right arglist by handling PASS/NOPASS. */
|
/* Get the right arglist by handling PASS/NOPASS. */
|
args = gfc_copy_actual_arglist (e->value.compcall.actual);
|
args = gfc_copy_actual_arglist (e->value.compcall.actual);
|
if (!g->specific->nopass)
|
if (!g->specific->nopass)
|
{
|
{
|
gfc_expr* po;
|
gfc_expr* po;
|
po = extract_compcall_passed_object (e);
|
po = extract_compcall_passed_object (e);
|
if (!po)
|
if (!po)
|
return FAILURE;
|
return FAILURE;
|
|
|
gcc_assert (g->specific->pass_arg_num > 0);
|
gcc_assert (g->specific->pass_arg_num > 0);
|
gcc_assert (!g->specific->error);
|
gcc_assert (!g->specific->error);
|
args = update_arglist_pass (args, po, g->specific->pass_arg_num,
|
args = update_arglist_pass (args, po, g->specific->pass_arg_num,
|
g->specific->pass_arg);
|
g->specific->pass_arg);
|
}
|
}
|
resolve_actual_arglist (args, target->attr.proc,
|
resolve_actual_arglist (args, target->attr.proc,
|
is_external_proc (target) && !target->formal);
|
is_external_proc (target) && !target->formal);
|
|
|
/* Check if this arglist matches the formal. */
|
/* Check if this arglist matches the formal. */
|
matches = gfc_arglist_matches_symbol (&args, target);
|
matches = gfc_arglist_matches_symbol (&args, target);
|
|
|
/* Clean up and break out of the loop if we've found it. */
|
/* Clean up and break out of the loop if we've found it. */
|
gfc_free_actual_arglist (args);
|
gfc_free_actual_arglist (args);
|
if (matches)
|
if (matches)
|
{
|
{
|
e->value.compcall.tbp = g->specific;
|
e->value.compcall.tbp = g->specific;
|
goto success;
|
goto success;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* Nothing matching found! */
|
/* Nothing matching found! */
|
gfc_error ("Found no matching specific binding for the call to the GENERIC"
|
gfc_error ("Found no matching specific binding for the call to the GENERIC"
|
" '%s' at %L", genname, &e->where);
|
" '%s' at %L", genname, &e->where);
|
return FAILURE;
|
return FAILURE;
|
|
|
success:
|
success:
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a call to a type-bound subroutine. */
|
/* Resolve a call to a type-bound subroutine. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typebound_call (gfc_code* c)
|
resolve_typebound_call (gfc_code* c)
|
{
|
{
|
gfc_actual_arglist* newactual;
|
gfc_actual_arglist* newactual;
|
gfc_symtree* target;
|
gfc_symtree* target;
|
|
|
/* Check that's really a SUBROUTINE. */
|
/* Check that's really a SUBROUTINE. */
|
if (!c->expr1->value.compcall.tbp->subroutine)
|
if (!c->expr1->value.compcall.tbp->subroutine)
|
{
|
{
|
gfc_error ("'%s' at %L should be a SUBROUTINE",
|
gfc_error ("'%s' at %L should be a SUBROUTINE",
|
c->expr1->value.compcall.name, &c->loc);
|
c->expr1->value.compcall.name, &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (check_typebound_baseobject (c->expr1) == FAILURE)
|
if (check_typebound_baseobject (c->expr1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (resolve_typebound_generic_call (c->expr1) == FAILURE)
|
if (resolve_typebound_generic_call (c->expr1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Transform into an ordinary EXEC_CALL for now. */
|
/* Transform into an ordinary EXEC_CALL for now. */
|
|
|
if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
|
if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
c->ext.actual = newactual;
|
c->ext.actual = newactual;
|
c->symtree = target;
|
c->symtree = target;
|
c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
|
c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
|
|
|
gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
|
gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
|
|
|
gfc_free_expr (c->expr1);
|
gfc_free_expr (c->expr1);
|
c->expr1 = gfc_get_expr ();
|
c->expr1 = gfc_get_expr ();
|
c->expr1->expr_type = EXPR_FUNCTION;
|
c->expr1->expr_type = EXPR_FUNCTION;
|
c->expr1->symtree = target;
|
c->expr1->symtree = target;
|
c->expr1->where = c->loc;
|
c->expr1->where = c->loc;
|
|
|
return resolve_call (c);
|
return resolve_call (c);
|
}
|
}
|
|
|
|
|
/* Resolve a component-call expression. This originally was intended
|
/* Resolve a component-call expression. This originally was intended
|
only to see functions. However, it is convenient to use it in
|
only to see functions. However, it is convenient to use it in
|
resolving subroutine class methods, since we do not have to add a
|
resolving subroutine class methods, since we do not have to add a
|
gfc_code each time. */
|
gfc_code each time. */
|
static gfc_try
|
static gfc_try
|
resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
|
resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
|
{
|
{
|
gfc_actual_arglist* newactual;
|
gfc_actual_arglist* newactual;
|
gfc_symtree* target;
|
gfc_symtree* target;
|
|
|
/* Check that's really a FUNCTION. */
|
/* Check that's really a FUNCTION. */
|
if (fcn && !e->value.compcall.tbp->function)
|
if (fcn && !e->value.compcall.tbp->function)
|
{
|
{
|
gfc_error ("'%s' at %L should be a FUNCTION",
|
gfc_error ("'%s' at %L should be a FUNCTION",
|
e->value.compcall.name, &e->where);
|
e->value.compcall.name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (!fcn && !e->value.compcall.tbp->subroutine)
|
else if (!fcn && !e->value.compcall.tbp->subroutine)
|
{
|
{
|
/* To resolve class member calls, we borrow this bit
|
/* To resolve class member calls, we borrow this bit
|
of code to select the specific procedures. */
|
of code to select the specific procedures. */
|
gfc_error ("'%s' at %L should be a SUBROUTINE",
|
gfc_error ("'%s' at %L should be a SUBROUTINE",
|
e->value.compcall.name, &e->where);
|
e->value.compcall.name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* These must not be assign-calls! */
|
/* These must not be assign-calls! */
|
gcc_assert (!e->value.compcall.assign);
|
gcc_assert (!e->value.compcall.assign);
|
|
|
if (check_typebound_baseobject (e) == FAILURE)
|
if (check_typebound_baseobject (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (resolve_typebound_generic_call (e) == FAILURE)
|
if (resolve_typebound_generic_call (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
gcc_assert (!e->value.compcall.tbp->is_generic);
|
gcc_assert (!e->value.compcall.tbp->is_generic);
|
|
|
/* Take the rank from the function's symbol. */
|
/* Take the rank from the function's symbol. */
|
if (e->value.compcall.tbp->u.specific->n.sym->as)
|
if (e->value.compcall.tbp->u.specific->n.sym->as)
|
e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
|
e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
|
|
|
/* For now, we simply transform it into an EXPR_FUNCTION call with the same
|
/* For now, we simply transform it into an EXPR_FUNCTION call with the same
|
arglist to the TBP's binding target. */
|
arglist to the TBP's binding target. */
|
|
|
if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
|
if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
e->value.function.actual = newactual;
|
e->value.function.actual = newactual;
|
e->value.function.name = NULL;
|
e->value.function.name = NULL;
|
e->value.function.esym = target->n.sym;
|
e->value.function.esym = target->n.sym;
|
e->value.function.class_esym = NULL;
|
e->value.function.class_esym = NULL;
|
e->value.function.isym = NULL;
|
e->value.function.isym = NULL;
|
e->symtree = target;
|
e->symtree = target;
|
e->ts = target->n.sym->ts;
|
e->ts = target->n.sym->ts;
|
e->expr_type = EXPR_FUNCTION;
|
e->expr_type = EXPR_FUNCTION;
|
|
|
/* Resolution is not necessary when constructing component calls
|
/* Resolution is not necessary when constructing component calls
|
for class members, since this must only be done for the
|
for class members, since this must only be done for the
|
declared type, which is done afterwards. */
|
declared type, which is done afterwards. */
|
return !class_members ? gfc_resolve_expr (e) : SUCCESS;
|
return !class_members ? gfc_resolve_expr (e) : SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a typebound call for the members in a class. This group of
|
/* Resolve a typebound call for the members in a class. This group of
|
functions implements dynamic dispatch in the provisional version
|
functions implements dynamic dispatch in the provisional version
|
of f03 OOP. As soon as vtables are in place and contain pointers
|
of f03 OOP. As soon as vtables are in place and contain pointers
|
to methods, this will no longer be necessary. */
|
to methods, this will no longer be necessary. */
|
static gfc_expr *list_e;
|
static gfc_expr *list_e;
|
static void check_class_members (gfc_symbol *);
|
static void check_class_members (gfc_symbol *);
|
static gfc_try class_try;
|
static gfc_try class_try;
|
static bool fcn_flag;
|
static bool fcn_flag;
|
|
|
|
|
static void
|
static void
|
check_members (gfc_symbol *derived)
|
check_members (gfc_symbol *derived)
|
{
|
{
|
if (derived->attr.flavor == FL_DERIVED)
|
if (derived->attr.flavor == FL_DERIVED)
|
check_class_members (derived);
|
check_class_members (derived);
|
}
|
}
|
|
|
|
|
static void
|
static void
|
check_class_members (gfc_symbol *derived)
|
check_class_members (gfc_symbol *derived)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
gfc_symtree *tbp;
|
gfc_symtree *tbp;
|
gfc_class_esym_list *etmp;
|
gfc_class_esym_list *etmp;
|
|
|
e = gfc_copy_expr (list_e);
|
e = gfc_copy_expr (list_e);
|
|
|
tbp = gfc_find_typebound_proc (derived, &class_try,
|
tbp = gfc_find_typebound_proc (derived, &class_try,
|
e->value.compcall.name,
|
e->value.compcall.name,
|
false, &e->where);
|
false, &e->where);
|
|
|
if (tbp == NULL)
|
if (tbp == NULL)
|
{
|
{
|
gfc_error ("no typebound available procedure named '%s' at %L",
|
gfc_error ("no typebound available procedure named '%s' at %L",
|
e->value.compcall.name, &e->where);
|
e->value.compcall.name, &e->where);
|
return;
|
return;
|
}
|
}
|
|
|
/* If we have to match a passed class member, force the actual
|
/* If we have to match a passed class member, force the actual
|
expression to have the correct type. */
|
expression to have the correct type. */
|
if (!tbp->n.tb->nopass)
|
if (!tbp->n.tb->nopass)
|
{
|
{
|
if (e->value.compcall.base_object == NULL)
|
if (e->value.compcall.base_object == NULL)
|
e->value.compcall.base_object = extract_compcall_passed_object (e);
|
e->value.compcall.base_object = extract_compcall_passed_object (e);
|
|
|
if (!derived->attr.abstract)
|
if (!derived->attr.abstract)
|
{
|
{
|
e->value.compcall.base_object->ts.type = BT_DERIVED;
|
e->value.compcall.base_object->ts.type = BT_DERIVED;
|
e->value.compcall.base_object->ts.u.derived = derived;
|
e->value.compcall.base_object->ts.u.derived = derived;
|
}
|
}
|
}
|
}
|
|
|
e->value.compcall.tbp = tbp->n.tb;
|
e->value.compcall.tbp = tbp->n.tb;
|
e->value.compcall.name = tbp->name;
|
e->value.compcall.name = tbp->name;
|
|
|
/* Let the original expresssion catch the assertion in
|
/* Let the original expresssion catch the assertion in
|
resolve_compcall, since this flag does not appear to be reset or
|
resolve_compcall, since this flag does not appear to be reset or
|
copied in some systems. */
|
copied in some systems. */
|
e->value.compcall.assign = 0;
|
e->value.compcall.assign = 0;
|
|
|
/* Do the renaming, PASSing, generic => specific and other
|
/* Do the renaming, PASSing, generic => specific and other
|
good things for each class member. */
|
good things for each class member. */
|
class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
|
class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
|
? class_try : FAILURE;
|
? class_try : FAILURE;
|
|
|
/* Now transfer the found symbol to the esym list. */
|
/* Now transfer the found symbol to the esym list. */
|
if (class_try == SUCCESS)
|
if (class_try == SUCCESS)
|
{
|
{
|
etmp = list_e->value.function.class_esym;
|
etmp = list_e->value.function.class_esym;
|
list_e->value.function.class_esym
|
list_e->value.function.class_esym
|
= gfc_get_class_esym_list();
|
= gfc_get_class_esym_list();
|
list_e->value.function.class_esym->next = etmp;
|
list_e->value.function.class_esym->next = etmp;
|
list_e->value.function.class_esym->derived = derived;
|
list_e->value.function.class_esym->derived = derived;
|
list_e->value.function.class_esym->esym
|
list_e->value.function.class_esym->esym
|
= e->value.function.esym;
|
= e->value.function.esym;
|
}
|
}
|
|
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
|
|
/* Burrow down into grandchildren types. */
|
/* Burrow down into grandchildren types. */
|
if (derived->f2k_derived)
|
if (derived->f2k_derived)
|
gfc_traverse_ns (derived->f2k_derived, check_members);
|
gfc_traverse_ns (derived->f2k_derived, check_members);
|
}
|
}
|
|
|
|
|
/* Eliminate esym_lists where all the members point to the
|
/* Eliminate esym_lists where all the members point to the
|
typebound procedure of the declared type; ie. one where
|
typebound procedure of the declared type; ie. one where
|
type selection has no effect.. */
|
type selection has no effect.. */
|
static void
|
static void
|
resolve_class_esym (gfc_expr *e)
|
resolve_class_esym (gfc_expr *e)
|
{
|
{
|
gfc_class_esym_list *p, *q;
|
gfc_class_esym_list *p, *q;
|
bool empty = true;
|
bool empty = true;
|
|
|
gcc_assert (e && e->expr_type == EXPR_FUNCTION);
|
gcc_assert (e && e->expr_type == EXPR_FUNCTION);
|
|
|
p = e->value.function.class_esym;
|
p = e->value.function.class_esym;
|
if (p == NULL)
|
if (p == NULL)
|
return;
|
return;
|
|
|
for (; p; p = p->next)
|
for (; p; p = p->next)
|
empty = empty && (e->value.function.esym == p->esym);
|
empty = empty && (e->value.function.esym == p->esym);
|
|
|
if (empty)
|
if (empty)
|
{
|
{
|
p = e->value.function.class_esym;
|
p = e->value.function.class_esym;
|
for (; p; p = q)
|
for (; p; p = q)
|
{
|
{
|
q = p->next;
|
q = p->next;
|
gfc_free (p);
|
gfc_free (p);
|
}
|
}
|
e->value.function.class_esym = NULL;
|
e->value.function.class_esym = NULL;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Generate an expression for the hash value, given the reference to
|
/* Generate an expression for the hash value, given the reference to
|
the class of the final expression (class_ref), the base of the
|
the class of the final expression (class_ref), the base of the
|
full reference list (new_ref), the declared type and the class
|
full reference list (new_ref), the declared type and the class
|
object (st). */
|
object (st). */
|
static gfc_expr*
|
static gfc_expr*
|
hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
|
hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
|
{
|
{
|
gfc_expr *hash_value;
|
gfc_expr *hash_value;
|
|
|
/* Build an expression for the correct hash_value; ie. that of the last
|
/* Build an expression for the correct hash_value; ie. that of the last
|
CLASS reference. */
|
CLASS reference. */
|
if (class_ref)
|
if (class_ref)
|
{
|
{
|
class_ref->next = NULL;
|
class_ref->next = NULL;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_free_ref_list (new_ref);
|
gfc_free_ref_list (new_ref);
|
new_ref = NULL;
|
new_ref = NULL;
|
}
|
}
|
hash_value = gfc_get_expr ();
|
hash_value = gfc_get_expr ();
|
hash_value->expr_type = EXPR_VARIABLE;
|
hash_value->expr_type = EXPR_VARIABLE;
|
hash_value->symtree = st;
|
hash_value->symtree = st;
|
hash_value->symtree->n.sym->refs++;
|
hash_value->symtree->n.sym->refs++;
|
hash_value->ref = new_ref;
|
hash_value->ref = new_ref;
|
gfc_add_component_ref (hash_value, "$vptr");
|
gfc_add_component_ref (hash_value, "$vptr");
|
gfc_add_component_ref (hash_value, "$hash");
|
gfc_add_component_ref (hash_value, "$hash");
|
|
|
return hash_value;
|
return hash_value;
|
}
|
}
|
|
|
|
|
/* Get the ultimate declared type from an expression. In addition,
|
/* Get the ultimate declared type from an expression. In addition,
|
return the last class/derived type reference and the copy of the
|
return the last class/derived type reference and the copy of the
|
reference list. */
|
reference list. */
|
static gfc_symbol*
|
static gfc_symbol*
|
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
|
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
|
gfc_expr *e)
|
gfc_expr *e)
|
{
|
{
|
gfc_symbol *declared;
|
gfc_symbol *declared;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
|
|
declared = NULL;
|
declared = NULL;
|
*class_ref = NULL;
|
*class_ref = NULL;
|
*new_ref = gfc_copy_ref (e->ref);
|
*new_ref = gfc_copy_ref (e->ref);
|
for (ref = *new_ref; ref; ref = ref->next)
|
for (ref = *new_ref; ref; ref = ref->next)
|
{
|
{
|
if (ref->type != REF_COMPONENT)
|
if (ref->type != REF_COMPONENT)
|
continue;
|
continue;
|
|
|
if (ref->u.c.component->ts.type == BT_CLASS
|
if (ref->u.c.component->ts.type == BT_CLASS
|
|| ref->u.c.component->ts.type == BT_DERIVED)
|
|| ref->u.c.component->ts.type == BT_DERIVED)
|
{
|
{
|
declared = ref->u.c.component->ts.u.derived;
|
declared = ref->u.c.component->ts.u.derived;
|
*class_ref = ref;
|
*class_ref = ref;
|
}
|
}
|
}
|
}
|
|
|
if (declared == NULL)
|
if (declared == NULL)
|
declared = e->symtree->n.sym->ts.u.derived;
|
declared = e->symtree->n.sym->ts.u.derived;
|
|
|
return declared;
|
return declared;
|
}
|
}
|
|
|
|
|
/* Resolve the argument expressions so that any arguments expressions
|
/* Resolve the argument expressions so that any arguments expressions
|
that include class methods are resolved before the current call.
|
that include class methods are resolved before the current call.
|
This is necessary because of the static variables used in CLASS
|
This is necessary because of the static variables used in CLASS
|
method resolution. */
|
method resolution. */
|
static void
|
static void
|
resolve_arg_exprs (gfc_actual_arglist *arg)
|
resolve_arg_exprs (gfc_actual_arglist *arg)
|
{
|
{
|
/* Resolve the actual arglist expressions. */
|
/* Resolve the actual arglist expressions. */
|
for (; arg; arg = arg->next)
|
for (; arg; arg = arg->next)
|
{
|
{
|
if (arg->expr)
|
if (arg->expr)
|
gfc_resolve_expr (arg->expr);
|
gfc_resolve_expr (arg->expr);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve a typebound function, or 'method'. First separate all
|
/* Resolve a typebound function, or 'method'. First separate all
|
the non-CLASS references by calling resolve_compcall directly.
|
the non-CLASS references by calling resolve_compcall directly.
|
Then treat the CLASS references by resolving for each of the class
|
Then treat the CLASS references by resolving for each of the class
|
members in turn. */
|
members in turn. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typebound_function (gfc_expr* e)
|
resolve_typebound_function (gfc_expr* e)
|
{
|
{
|
gfc_symbol *derived, *declared;
|
gfc_symbol *derived, *declared;
|
gfc_ref *new_ref;
|
gfc_ref *new_ref;
|
gfc_ref *class_ref;
|
gfc_ref *class_ref;
|
gfc_symtree *st;
|
gfc_symtree *st;
|
|
|
st = e->symtree;
|
st = e->symtree;
|
if (st == NULL)
|
if (st == NULL)
|
return resolve_compcall (e, true, false);
|
return resolve_compcall (e, true, false);
|
|
|
/* Get the CLASS declared type. */
|
/* Get the CLASS declared type. */
|
declared = get_declared_from_expr (&class_ref, &new_ref, e);
|
declared = get_declared_from_expr (&class_ref, &new_ref, e);
|
|
|
/* Weed out cases of the ultimate component being a derived type. */
|
/* Weed out cases of the ultimate component being a derived type. */
|
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
|
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
|
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
|
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
|
{
|
{
|
gfc_free_ref_list (new_ref);
|
gfc_free_ref_list (new_ref);
|
return resolve_compcall (e, true, false);
|
return resolve_compcall (e, true, false);
|
}
|
}
|
|
|
/* Resolve the argument expressions, */
|
/* Resolve the argument expressions, */
|
resolve_arg_exprs (e->value.function.actual);
|
resolve_arg_exprs (e->value.function.actual);
|
|
|
/* Get the data component, which is of the declared type. */
|
/* Get the data component, which is of the declared type. */
|
derived = declared->components->ts.u.derived;
|
derived = declared->components->ts.u.derived;
|
|
|
/* Resolve the function call for each member of the class. */
|
/* Resolve the function call for each member of the class. */
|
class_try = SUCCESS;
|
class_try = SUCCESS;
|
fcn_flag = true;
|
fcn_flag = true;
|
list_e = gfc_copy_expr (e);
|
list_e = gfc_copy_expr (e);
|
check_class_members (derived);
|
check_class_members (derived);
|
|
|
class_try = (resolve_compcall (e, true, false) == SUCCESS)
|
class_try = (resolve_compcall (e, true, false) == SUCCESS)
|
? class_try : FAILURE;
|
? class_try : FAILURE;
|
|
|
/* Transfer the class list to the original expression. Note that
|
/* Transfer the class list to the original expression. Note that
|
the class_esym list is cleaned up in trans-expr.c, as the calls
|
the class_esym list is cleaned up in trans-expr.c, as the calls
|
are translated. */
|
are translated. */
|
e->value.function.class_esym = list_e->value.function.class_esym;
|
e->value.function.class_esym = list_e->value.function.class_esym;
|
list_e->value.function.class_esym = NULL;
|
list_e->value.function.class_esym = NULL;
|
gfc_free_expr (list_e);
|
gfc_free_expr (list_e);
|
|
|
resolve_class_esym (e);
|
resolve_class_esym (e);
|
|
|
/* More than one typebound procedure so transmit an expression for
|
/* More than one typebound procedure so transmit an expression for
|
the hash_value as the selector. */
|
the hash_value as the selector. */
|
if (e->value.function.class_esym != NULL)
|
if (e->value.function.class_esym != NULL)
|
e->value.function.class_esym->hash_value
|
e->value.function.class_esym->hash_value
|
= hash_value_expr (class_ref, new_ref, st);
|
= hash_value_expr (class_ref, new_ref, st);
|
|
|
return class_try;
|
return class_try;
|
}
|
}
|
|
|
/* Resolve a typebound subroutine, or 'method'. First separate all
|
/* Resolve a typebound subroutine, or 'method'. First separate all
|
the non-CLASS references by calling resolve_typebound_call directly.
|
the non-CLASS references by calling resolve_typebound_call directly.
|
Then treat the CLASS references by resolving for each of the class
|
Then treat the CLASS references by resolving for each of the class
|
members in turn. */
|
members in turn. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typebound_subroutine (gfc_code *code)
|
resolve_typebound_subroutine (gfc_code *code)
|
{
|
{
|
gfc_symbol *derived, *declared;
|
gfc_symbol *derived, *declared;
|
gfc_ref *new_ref;
|
gfc_ref *new_ref;
|
gfc_ref *class_ref;
|
gfc_ref *class_ref;
|
gfc_symtree *st;
|
gfc_symtree *st;
|
|
|
st = code->expr1->symtree;
|
st = code->expr1->symtree;
|
if (st == NULL)
|
if (st == NULL)
|
return resolve_typebound_call (code);
|
return resolve_typebound_call (code);
|
|
|
/* Get the CLASS declared type. */
|
/* Get the CLASS declared type. */
|
declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
|
declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
|
|
|
/* Weed out cases of the ultimate component being a derived type. */
|
/* Weed out cases of the ultimate component being a derived type. */
|
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
|
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
|
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
|
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
|
{
|
{
|
gfc_free_ref_list (new_ref);
|
gfc_free_ref_list (new_ref);
|
return resolve_typebound_call (code);
|
return resolve_typebound_call (code);
|
}
|
}
|
|
|
/* Resolve the argument expressions, */
|
/* Resolve the argument expressions, */
|
resolve_arg_exprs (code->expr1->value.compcall.actual);
|
resolve_arg_exprs (code->expr1->value.compcall.actual);
|
|
|
/* Get the data component, which is of the declared type. */
|
/* Get the data component, which is of the declared type. */
|
derived = declared->components->ts.u.derived;
|
derived = declared->components->ts.u.derived;
|
|
|
class_try = SUCCESS;
|
class_try = SUCCESS;
|
fcn_flag = false;
|
fcn_flag = false;
|
list_e = gfc_copy_expr (code->expr1);
|
list_e = gfc_copy_expr (code->expr1);
|
check_class_members (derived);
|
check_class_members (derived);
|
|
|
class_try = (resolve_typebound_call (code) == SUCCESS)
|
class_try = (resolve_typebound_call (code) == SUCCESS)
|
? class_try : FAILURE;
|
? class_try : FAILURE;
|
|
|
/* Transfer the class list to the original expression. Note that
|
/* Transfer the class list to the original expression. Note that
|
the class_esym list is cleaned up in trans-expr.c, as the calls
|
the class_esym list is cleaned up in trans-expr.c, as the calls
|
are translated. */
|
are translated. */
|
code->expr1->value.function.class_esym
|
code->expr1->value.function.class_esym
|
= list_e->value.function.class_esym;
|
= list_e->value.function.class_esym;
|
list_e->value.function.class_esym = NULL;
|
list_e->value.function.class_esym = NULL;
|
gfc_free_expr (list_e);
|
gfc_free_expr (list_e);
|
|
|
resolve_class_esym (code->expr1);
|
resolve_class_esym (code->expr1);
|
|
|
/* More than one typebound procedure so transmit an expression for
|
/* More than one typebound procedure so transmit an expression for
|
the hash_value as the selector. */
|
the hash_value as the selector. */
|
if (code->expr1->value.function.class_esym != NULL)
|
if (code->expr1->value.function.class_esym != NULL)
|
code->expr1->value.function.class_esym->hash_value
|
code->expr1->value.function.class_esym->hash_value
|
= hash_value_expr (class_ref, new_ref, st);
|
= hash_value_expr (class_ref, new_ref, st);
|
|
|
return class_try;
|
return class_try;
|
}
|
}
|
|
|
|
|
/* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
|
/* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_ppc_call (gfc_code* c)
|
resolve_ppc_call (gfc_code* c)
|
{
|
{
|
gfc_component *comp;
|
gfc_component *comp;
|
bool b;
|
bool b;
|
|
|
b = gfc_is_proc_ptr_comp (c->expr1, &comp);
|
b = gfc_is_proc_ptr_comp (c->expr1, &comp);
|
gcc_assert (b);
|
gcc_assert (b);
|
|
|
c->resolved_sym = c->expr1->symtree->n.sym;
|
c->resolved_sym = c->expr1->symtree->n.sym;
|
c->expr1->expr_type = EXPR_VARIABLE;
|
c->expr1->expr_type = EXPR_VARIABLE;
|
|
|
if (!comp->attr.subroutine)
|
if (!comp->attr.subroutine)
|
gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
|
gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
|
|
|
if (resolve_ref (c->expr1) == FAILURE)
|
if (resolve_ref (c->expr1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (update_ppc_arglist (c->expr1) == FAILURE)
|
if (update_ppc_arglist (c->expr1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
c->ext.actual = c->expr1->value.compcall.actual;
|
c->ext.actual = c->expr1->value.compcall.actual;
|
|
|
if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
|
if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
|
comp->formal == NULL) == FAILURE)
|
comp->formal == NULL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
|
gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a Function Call to a Procedure Pointer Component (Function). */
|
/* Resolve a Function Call to a Procedure Pointer Component (Function). */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_expr_ppc (gfc_expr* e)
|
resolve_expr_ppc (gfc_expr* e)
|
{
|
{
|
gfc_component *comp;
|
gfc_component *comp;
|
bool b;
|
bool b;
|
|
|
b = gfc_is_proc_ptr_comp (e, &comp);
|
b = gfc_is_proc_ptr_comp (e, &comp);
|
gcc_assert (b);
|
gcc_assert (b);
|
|
|
/* Convert to EXPR_FUNCTION. */
|
/* Convert to EXPR_FUNCTION. */
|
e->expr_type = EXPR_FUNCTION;
|
e->expr_type = EXPR_FUNCTION;
|
e->value.function.isym = NULL;
|
e->value.function.isym = NULL;
|
e->value.function.actual = e->value.compcall.actual;
|
e->value.function.actual = e->value.compcall.actual;
|
e->ts = comp->ts;
|
e->ts = comp->ts;
|
if (comp->as != NULL)
|
if (comp->as != NULL)
|
e->rank = comp->as->rank;
|
e->rank = comp->as->rank;
|
|
|
if (!comp->attr.function)
|
if (!comp->attr.function)
|
gfc_add_function (&comp->attr, comp->name, &e->where);
|
gfc_add_function (&comp->attr, comp->name, &e->where);
|
|
|
if (resolve_ref (e) == FAILURE)
|
if (resolve_ref (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
|
if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
|
comp->formal == NULL) == FAILURE)
|
comp->formal == NULL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (update_ppc_arglist (e) == FAILURE)
|
if (update_ppc_arglist (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
|
gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static bool
|
static bool
|
gfc_is_expandable_expr (gfc_expr *e)
|
gfc_is_expandable_expr (gfc_expr *e)
|
{
|
{
|
gfc_constructor *con;
|
gfc_constructor *con;
|
|
|
if (e->expr_type == EXPR_ARRAY)
|
if (e->expr_type == EXPR_ARRAY)
|
{
|
{
|
/* Traverse the constructor looking for variables that are flavor
|
/* Traverse the constructor looking for variables that are flavor
|
parameter. Parameters must be expanded since they are fully used at
|
parameter. Parameters must be expanded since they are fully used at
|
compile time. */
|
compile time. */
|
for (con = e->value.constructor; con; con = con->next)
|
for (con = e->value.constructor; con; con = con->next)
|
{
|
{
|
if (con->expr->expr_type == EXPR_VARIABLE
|
if (con->expr->expr_type == EXPR_VARIABLE
|
&& con->expr->symtree
|
&& con->expr->symtree
|
&& (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
|
&& (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
|
|| con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
|
|| con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
|
return true;
|
return true;
|
if (con->expr->expr_type == EXPR_ARRAY
|
if (con->expr->expr_type == EXPR_ARRAY
|
&& gfc_is_expandable_expr (con->expr))
|
&& gfc_is_expandable_expr (con->expr))
|
return true;
|
return true;
|
}
|
}
|
}
|
}
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
/* Resolve an expression. That is, make sure that types of operands agree
|
/* Resolve an expression. That is, make sure that types of operands agree
|
with their operators, intrinsic operators are converted to function calls
|
with their operators, intrinsic operators are converted to function calls
|
for overloaded types and unresolved function references are resolved. */
|
for overloaded types and unresolved function references are resolved. */
|
|
|
gfc_try
|
gfc_try
|
gfc_resolve_expr (gfc_expr *e)
|
gfc_resolve_expr (gfc_expr *e)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
|
|
if (e == NULL)
|
if (e == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
switch (e->expr_type)
|
switch (e->expr_type)
|
{
|
{
|
case EXPR_OP:
|
case EXPR_OP:
|
t = resolve_operator (e);
|
t = resolve_operator (e);
|
break;
|
break;
|
|
|
case EXPR_FUNCTION:
|
case EXPR_FUNCTION:
|
case EXPR_VARIABLE:
|
case EXPR_VARIABLE:
|
|
|
if (check_host_association (e))
|
if (check_host_association (e))
|
t = resolve_function (e);
|
t = resolve_function (e);
|
else
|
else
|
{
|
{
|
t = resolve_variable (e);
|
t = resolve_variable (e);
|
if (t == SUCCESS)
|
if (t == SUCCESS)
|
expression_rank (e);
|
expression_rank (e);
|
}
|
}
|
|
|
if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
|
if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
|
&& e->ref->type != REF_SUBSTRING)
|
&& e->ref->type != REF_SUBSTRING)
|
gfc_resolve_substring_charlen (e);
|
gfc_resolve_substring_charlen (e);
|
|
|
break;
|
break;
|
|
|
case EXPR_COMPCALL:
|
case EXPR_COMPCALL:
|
t = resolve_typebound_function (e);
|
t = resolve_typebound_function (e);
|
break;
|
break;
|
|
|
case EXPR_SUBSTRING:
|
case EXPR_SUBSTRING:
|
t = resolve_ref (e);
|
t = resolve_ref (e);
|
break;
|
break;
|
|
|
case EXPR_CONSTANT:
|
case EXPR_CONSTANT:
|
case EXPR_NULL:
|
case EXPR_NULL:
|
t = SUCCESS;
|
t = SUCCESS;
|
break;
|
break;
|
|
|
case EXPR_PPC:
|
case EXPR_PPC:
|
t = resolve_expr_ppc (e);
|
t = resolve_expr_ppc (e);
|
break;
|
break;
|
|
|
case EXPR_ARRAY:
|
case EXPR_ARRAY:
|
t = FAILURE;
|
t = FAILURE;
|
if (resolve_ref (e) == FAILURE)
|
if (resolve_ref (e) == FAILURE)
|
break;
|
break;
|
|
|
t = gfc_resolve_array_constructor (e);
|
t = gfc_resolve_array_constructor (e);
|
/* Also try to expand a constructor. */
|
/* Also try to expand a constructor. */
|
if (t == SUCCESS)
|
if (t == SUCCESS)
|
{
|
{
|
expression_rank (e);
|
expression_rank (e);
|
if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
|
if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
|
gfc_expand_constructor (e);
|
gfc_expand_constructor (e);
|
}
|
}
|
|
|
/* This provides the opportunity for the length of constructors with
|
/* This provides the opportunity for the length of constructors with
|
character valued function elements to propagate the string length
|
character valued function elements to propagate the string length
|
to the expression. */
|
to the expression. */
|
if (t == SUCCESS && e->ts.type == BT_CHARACTER)
|
if (t == SUCCESS && e->ts.type == BT_CHARACTER)
|
{
|
{
|
/* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
|
/* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
|
here rather then add a duplicate test for it above. */
|
here rather then add a duplicate test for it above. */
|
gfc_expand_constructor (e);
|
gfc_expand_constructor (e);
|
t = gfc_resolve_character_array_constructor (e);
|
t = gfc_resolve_character_array_constructor (e);
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case EXPR_STRUCTURE:
|
case EXPR_STRUCTURE:
|
t = resolve_ref (e);
|
t = resolve_ref (e);
|
if (t == FAILURE)
|
if (t == FAILURE)
|
break;
|
break;
|
|
|
t = resolve_structure_cons (e);
|
t = resolve_structure_cons (e);
|
if (t == FAILURE)
|
if (t == FAILURE)
|
break;
|
break;
|
|
|
t = gfc_simplify_expr (e, 0);
|
t = gfc_simplify_expr (e, 0);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
|
gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
|
}
|
}
|
|
|
if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
|
if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
|
fixup_charlen (e);
|
fixup_charlen (e);
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
/* Resolve an expression from an iterator. They must be scalar and have
|
/* Resolve an expression from an iterator. They must be scalar and have
|
INTEGER or (optionally) REAL type. */
|
INTEGER or (optionally) REAL type. */
|
|
|
static gfc_try
|
static gfc_try
|
gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
|
gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
|
const char *name_msgid)
|
const char *name_msgid)
|
{
|
{
|
if (gfc_resolve_expr (expr) == FAILURE)
|
if (gfc_resolve_expr (expr) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (expr->rank != 0)
|
if (expr->rank != 0)
|
{
|
{
|
gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
|
gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (expr->ts.type != BT_INTEGER)
|
if (expr->ts.type != BT_INTEGER)
|
{
|
{
|
if (expr->ts.type == BT_REAL)
|
if (expr->ts.type == BT_REAL)
|
{
|
{
|
if (real_ok)
|
if (real_ok)
|
return gfc_notify_std (GFC_STD_F95_DEL,
|
return gfc_notify_std (GFC_STD_F95_DEL,
|
"Deleted feature: %s at %L must be integer",
|
"Deleted feature: %s at %L must be integer",
|
_(name_msgid), &expr->where);
|
_(name_msgid), &expr->where);
|
else
|
else
|
{
|
{
|
gfc_error ("%s at %L must be INTEGER", _(name_msgid),
|
gfc_error ("%s at %L must be INTEGER", _(name_msgid),
|
&expr->where);
|
&expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
|
gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve the expressions in an iterator structure. If REAL_OK is
|
/* Resolve the expressions in an iterator structure. If REAL_OK is
|
false allow only INTEGER type iterators, otherwise allow REAL types. */
|
false allow only INTEGER type iterators, otherwise allow REAL types. */
|
|
|
gfc_try
|
gfc_try
|
gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
|
gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
|
{
|
{
|
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
|
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
|
== FAILURE)
|
== FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
|
if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
|
{
|
{
|
gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
|
gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
|
&iter->var->where);
|
&iter->var->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (gfc_resolve_iterator_expr (iter->start, real_ok,
|
if (gfc_resolve_iterator_expr (iter->start, real_ok,
|
"Start expression in DO loop") == FAILURE)
|
"Start expression in DO loop") == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_resolve_iterator_expr (iter->end, real_ok,
|
if (gfc_resolve_iterator_expr (iter->end, real_ok,
|
"End expression in DO loop") == FAILURE)
|
"End expression in DO loop") == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_resolve_iterator_expr (iter->step, real_ok,
|
if (gfc_resolve_iterator_expr (iter->step, real_ok,
|
"Step expression in DO loop") == FAILURE)
|
"Step expression in DO loop") == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (iter->step->expr_type == EXPR_CONSTANT)
|
if (iter->step->expr_type == EXPR_CONSTANT)
|
{
|
{
|
if ((iter->step->ts.type == BT_INTEGER
|
if ((iter->step->ts.type == BT_INTEGER
|
&& mpz_cmp_ui (iter->step->value.integer, 0) == 0)
|
&& mpz_cmp_ui (iter->step->value.integer, 0) == 0)
|
|| (iter->step->ts.type == BT_REAL
|
|| (iter->step->ts.type == BT_REAL
|
&& mpfr_sgn (iter->step->value.real) == 0))
|
&& mpfr_sgn (iter->step->value.real) == 0))
|
{
|
{
|
gfc_error ("Step expression in DO loop at %L cannot be zero",
|
gfc_error ("Step expression in DO loop at %L cannot be zero",
|
&iter->step->where);
|
&iter->step->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Convert start, end, and step to the same type as var. */
|
/* Convert start, end, and step to the same type as var. */
|
if (iter->start->ts.kind != iter->var->ts.kind
|
if (iter->start->ts.kind != iter->var->ts.kind
|
|| iter->start->ts.type != iter->var->ts.type)
|
|| iter->start->ts.type != iter->var->ts.type)
|
gfc_convert_type (iter->start, &iter->var->ts, 2);
|
gfc_convert_type (iter->start, &iter->var->ts, 2);
|
|
|
if (iter->end->ts.kind != iter->var->ts.kind
|
if (iter->end->ts.kind != iter->var->ts.kind
|
|| iter->end->ts.type != iter->var->ts.type)
|
|| iter->end->ts.type != iter->var->ts.type)
|
gfc_convert_type (iter->end, &iter->var->ts, 2);
|
gfc_convert_type (iter->end, &iter->var->ts, 2);
|
|
|
if (iter->step->ts.kind != iter->var->ts.kind
|
if (iter->step->ts.kind != iter->var->ts.kind
|
|| iter->step->ts.type != iter->var->ts.type)
|
|| iter->step->ts.type != iter->var->ts.type)
|
gfc_convert_type (iter->step, &iter->var->ts, 2);
|
gfc_convert_type (iter->step, &iter->var->ts, 2);
|
|
|
if (iter->start->expr_type == EXPR_CONSTANT
|
if (iter->start->expr_type == EXPR_CONSTANT
|
&& iter->end->expr_type == EXPR_CONSTANT
|
&& iter->end->expr_type == EXPR_CONSTANT
|
&& iter->step->expr_type == EXPR_CONSTANT)
|
&& iter->step->expr_type == EXPR_CONSTANT)
|
{
|
{
|
int sgn, cmp;
|
int sgn, cmp;
|
if (iter->start->ts.type == BT_INTEGER)
|
if (iter->start->ts.type == BT_INTEGER)
|
{
|
{
|
sgn = mpz_cmp_ui (iter->step->value.integer, 0);
|
sgn = mpz_cmp_ui (iter->step->value.integer, 0);
|
cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
|
cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
|
}
|
}
|
else
|
else
|
{
|
{
|
sgn = mpfr_sgn (iter->step->value.real);
|
sgn = mpfr_sgn (iter->step->value.real);
|
cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
|
cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
|
}
|
}
|
if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
|
if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
|
gfc_warning ("DO loop at %L will be executed zero times",
|
gfc_warning ("DO loop at %L will be executed zero times",
|
&iter->step->where);
|
&iter->step->where);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Traversal function for find_forall_index. f == 2 signals that
|
/* Traversal function for find_forall_index. f == 2 signals that
|
that variable itself is not to be checked - only the references. */
|
that variable itself is not to be checked - only the references. */
|
|
|
static bool
|
static bool
|
forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
|
forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
|
{
|
{
|
if (expr->expr_type != EXPR_VARIABLE)
|
if (expr->expr_type != EXPR_VARIABLE)
|
return false;
|
return false;
|
|
|
/* A scalar assignment */
|
/* A scalar assignment */
|
if (!expr->ref || *f == 1)
|
if (!expr->ref || *f == 1)
|
{
|
{
|
if (expr->symtree->n.sym == sym)
|
if (expr->symtree->n.sym == sym)
|
return true;
|
return true;
|
else
|
else
|
return false;
|
return false;
|
}
|
}
|
|
|
if (*f == 2)
|
if (*f == 2)
|
*f = 1;
|
*f = 1;
|
return false;
|
return false;
|
}
|
}
|
|
|
|
|
/* Check whether the FORALL index appears in the expression or not.
|
/* Check whether the FORALL index appears in the expression or not.
|
Returns SUCCESS if SYM is found in EXPR. */
|
Returns SUCCESS if SYM is found in EXPR. */
|
|
|
gfc_try
|
gfc_try
|
find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
|
find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
|
{
|
{
|
if (gfc_traverse_expr (expr, sym, forall_index, f))
|
if (gfc_traverse_expr (expr, sym, forall_index, f))
|
return SUCCESS;
|
return SUCCESS;
|
else
|
else
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
|
/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
|
to be a scalar INTEGER variable. The subscripts and stride are scalar
|
to be a scalar INTEGER variable. The subscripts and stride are scalar
|
INTEGERs, and if stride is a constant it must be nonzero.
|
INTEGERs, and if stride is a constant it must be nonzero.
|
Furthermore "A subscript or stride in a forall-triplet-spec shall
|
Furthermore "A subscript or stride in a forall-triplet-spec shall
|
not contain a reference to any index-name in the
|
not contain a reference to any index-name in the
|
forall-triplet-spec-list in which it appears." (7.5.4.1) */
|
forall-triplet-spec-list in which it appears." (7.5.4.1) */
|
|
|
static void
|
static void
|
resolve_forall_iterators (gfc_forall_iterator *it)
|
resolve_forall_iterators (gfc_forall_iterator *it)
|
{
|
{
|
gfc_forall_iterator *iter, *iter2;
|
gfc_forall_iterator *iter, *iter2;
|
|
|
for (iter = it; iter; iter = iter->next)
|
for (iter = it; iter; iter = iter->next)
|
{
|
{
|
if (gfc_resolve_expr (iter->var) == SUCCESS
|
if (gfc_resolve_expr (iter->var) == SUCCESS
|
&& (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
|
&& (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
|
gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
|
gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
|
&iter->var->where);
|
&iter->var->where);
|
|
|
if (gfc_resolve_expr (iter->start) == SUCCESS
|
if (gfc_resolve_expr (iter->start) == SUCCESS
|
&& (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
|
&& (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
|
gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
|
gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
|
&iter->start->where);
|
&iter->start->where);
|
if (iter->var->ts.kind != iter->start->ts.kind)
|
if (iter->var->ts.kind != iter->start->ts.kind)
|
gfc_convert_type (iter->start, &iter->var->ts, 2);
|
gfc_convert_type (iter->start, &iter->var->ts, 2);
|
|
|
if (gfc_resolve_expr (iter->end) == SUCCESS
|
if (gfc_resolve_expr (iter->end) == SUCCESS
|
&& (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
|
&& (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
|
gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
|
gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
|
&iter->end->where);
|
&iter->end->where);
|
if (iter->var->ts.kind != iter->end->ts.kind)
|
if (iter->var->ts.kind != iter->end->ts.kind)
|
gfc_convert_type (iter->end, &iter->var->ts, 2);
|
gfc_convert_type (iter->end, &iter->var->ts, 2);
|
|
|
if (gfc_resolve_expr (iter->stride) == SUCCESS)
|
if (gfc_resolve_expr (iter->stride) == SUCCESS)
|
{
|
{
|
if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
|
if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
|
gfc_error ("FORALL stride expression at %L must be a scalar %s",
|
gfc_error ("FORALL stride expression at %L must be a scalar %s",
|
&iter->stride->where, "INTEGER");
|
&iter->stride->where, "INTEGER");
|
|
|
if (iter->stride->expr_type == EXPR_CONSTANT
|
if (iter->stride->expr_type == EXPR_CONSTANT
|
&& mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
|
&& mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
|
gfc_error ("FORALL stride expression at %L cannot be zero",
|
gfc_error ("FORALL stride expression at %L cannot be zero",
|
&iter->stride->where);
|
&iter->stride->where);
|
}
|
}
|
if (iter->var->ts.kind != iter->stride->ts.kind)
|
if (iter->var->ts.kind != iter->stride->ts.kind)
|
gfc_convert_type (iter->stride, &iter->var->ts, 2);
|
gfc_convert_type (iter->stride, &iter->var->ts, 2);
|
}
|
}
|
|
|
for (iter = it; iter; iter = iter->next)
|
for (iter = it; iter; iter = iter->next)
|
for (iter2 = iter; iter2; iter2 = iter2->next)
|
for (iter2 = iter; iter2; iter2 = iter2->next)
|
{
|
{
|
if (find_forall_index (iter2->start,
|
if (find_forall_index (iter2->start,
|
iter->var->symtree->n.sym, 0) == SUCCESS
|
iter->var->symtree->n.sym, 0) == SUCCESS
|
|| find_forall_index (iter2->end,
|
|| find_forall_index (iter2->end,
|
iter->var->symtree->n.sym, 0) == SUCCESS
|
iter->var->symtree->n.sym, 0) == SUCCESS
|
|| find_forall_index (iter2->stride,
|
|| find_forall_index (iter2->stride,
|
iter->var->symtree->n.sym, 0) == SUCCESS)
|
iter->var->symtree->n.sym, 0) == SUCCESS)
|
gfc_error ("FORALL index '%s' may not appear in triplet "
|
gfc_error ("FORALL index '%s' may not appear in triplet "
|
"specification at %L", iter->var->symtree->name,
|
"specification at %L", iter->var->symtree->name,
|
&iter2->start->where);
|
&iter2->start->where);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Given a pointer to a symbol that is a derived type, see if it's
|
/* Given a pointer to a symbol that is a derived type, see if it's
|
inaccessible, i.e. if it's defined in another module and the components are
|
inaccessible, i.e. if it's defined in another module and the components are
|
PRIVATE. The search is recursive if necessary. Returns zero if no
|
PRIVATE. The search is recursive if necessary. Returns zero if no
|
inaccessible components are found, nonzero otherwise. */
|
inaccessible components are found, nonzero otherwise. */
|
|
|
static int
|
static int
|
derived_inaccessible (gfc_symbol *sym)
|
derived_inaccessible (gfc_symbol *sym)
|
{
|
{
|
gfc_component *c;
|
gfc_component *c;
|
|
|
if (sym->attr.use_assoc && sym->attr.private_comp)
|
if (sym->attr.use_assoc && sym->attr.private_comp)
|
return 1;
|
return 1;
|
|
|
for (c = sym->components; c; c = c->next)
|
for (c = sym->components; c; c = c->next)
|
{
|
{
|
if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
|
if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
|
return 1;
|
return 1;
|
}
|
}
|
|
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/* Resolve the argument of a deallocate expression. The expression must be
|
/* Resolve the argument of a deallocate expression. The expression must be
|
a pointer or a full array. */
|
a pointer or a full array. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_deallocate_expr (gfc_expr *e)
|
resolve_deallocate_expr (gfc_expr *e)
|
{
|
{
|
symbol_attribute attr;
|
symbol_attribute attr;
|
int allocatable, pointer, check_intent_in;
|
int allocatable, pointer, check_intent_in;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_component *c;
|
gfc_component *c;
|
|
|
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
|
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
|
check_intent_in = 1;
|
check_intent_in = 1;
|
|
|
if (gfc_resolve_expr (e) == FAILURE)
|
if (gfc_resolve_expr (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (e->expr_type != EXPR_VARIABLE)
|
if (e->expr_type != EXPR_VARIABLE)
|
goto bad;
|
goto bad;
|
|
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
|
|
if (sym->ts.type == BT_CLASS)
|
if (sym->ts.type == BT_CLASS)
|
{
|
{
|
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
pointer = sym->ts.u.derived->components->attr.pointer;
|
pointer = sym->ts.u.derived->components->attr.pointer;
|
}
|
}
|
else
|
else
|
{
|
{
|
allocatable = sym->attr.allocatable;
|
allocatable = sym->attr.allocatable;
|
pointer = sym->attr.pointer;
|
pointer = sym->attr.pointer;
|
}
|
}
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
{
|
{
|
if (pointer)
|
if (pointer)
|
check_intent_in = 0;
|
check_intent_in = 0;
|
|
|
switch (ref->type)
|
switch (ref->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
if (ref->u.ar.type != AR_FULL)
|
if (ref->u.ar.type != AR_FULL)
|
allocatable = 0;
|
allocatable = 0;
|
break;
|
break;
|
|
|
case REF_COMPONENT:
|
case REF_COMPONENT:
|
c = ref->u.c.component;
|
c = ref->u.c.component;
|
if (c->ts.type == BT_CLASS)
|
if (c->ts.type == BT_CLASS)
|
{
|
{
|
allocatable = c->ts.u.derived->components->attr.allocatable;
|
allocatable = c->ts.u.derived->components->attr.allocatable;
|
pointer = c->ts.u.derived->components->attr.pointer;
|
pointer = c->ts.u.derived->components->attr.pointer;
|
}
|
}
|
else
|
else
|
{
|
{
|
allocatable = c->attr.allocatable;
|
allocatable = c->attr.allocatable;
|
pointer = c->attr.pointer;
|
pointer = c->attr.pointer;
|
}
|
}
|
break;
|
break;
|
|
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
allocatable = 0;
|
allocatable = 0;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
attr = gfc_expr_attr (e);
|
attr = gfc_expr_attr (e);
|
|
|
if (allocatable == 0 && attr.pointer == 0)
|
if (allocatable == 0 && attr.pointer == 0)
|
{
|
{
|
bad:
|
bad:
|
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
|
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
|
&e->where);
|
&e->where);
|
}
|
}
|
|
|
if (check_intent_in && sym->attr.intent == INTENT_IN)
|
if (check_intent_in && sym->attr.intent == INTENT_IN)
|
{
|
{
|
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
|
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
|
sym->name, &e->where);
|
sym->name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (e->ts.type == BT_CLASS)
|
if (e->ts.type == BT_CLASS)
|
{
|
{
|
/* Only deallocate the DATA component. */
|
/* Only deallocate the DATA component. */
|
gfc_add_component_ref (e, "$data");
|
gfc_add_component_ref (e, "$data");
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Returns true if the expression e contains a reference to the symbol sym. */
|
/* Returns true if the expression e contains a reference to the symbol sym. */
|
static bool
|
static bool
|
sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
|
sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
|
{
|
{
|
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
|
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
|
return true;
|
return true;
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
bool
|
bool
|
gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
|
gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
|
{
|
{
|
return gfc_traverse_expr (e, sym, sym_in_expr, 0);
|
return gfc_traverse_expr (e, sym, sym_in_expr, 0);
|
}
|
}
|
|
|
|
|
/* Given the expression node e for an allocatable/pointer of derived type to be
|
/* Given the expression node e for an allocatable/pointer of derived type to be
|
allocated, get the expression node to be initialized afterwards (needed for
|
allocated, get the expression node to be initialized afterwards (needed for
|
derived types with default initializers, and derived types with allocatable
|
derived types with default initializers, and derived types with allocatable
|
components that need nullification.) */
|
components that need nullification.) */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_expr_to_initialize (gfc_expr *e)
|
gfc_expr_to_initialize (gfc_expr *e)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
int i;
|
int i;
|
|
|
result = gfc_copy_expr (e);
|
result = gfc_copy_expr (e);
|
|
|
/* Change the last array reference from AR_ELEMENT to AR_FULL. */
|
/* Change the last array reference from AR_ELEMENT to AR_FULL. */
|
for (ref = result->ref; ref; ref = ref->next)
|
for (ref = result->ref; ref; ref = ref->next)
|
if (ref->type == REF_ARRAY && ref->next == NULL)
|
if (ref->type == REF_ARRAY && ref->next == NULL)
|
{
|
{
|
ref->u.ar.type = AR_FULL;
|
ref->u.ar.type = AR_FULL;
|
|
|
for (i = 0; i < ref->u.ar.dimen; i++)
|
for (i = 0; i < ref->u.ar.dimen; i++)
|
ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
|
ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
|
|
|
result->rank = ref->u.ar.dimen;
|
result->rank = ref->u.ar.dimen;
|
break;
|
break;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Used in resolve_allocate_expr to check that a allocation-object and
|
/* Used in resolve_allocate_expr to check that a allocation-object and
|
a source-expr are conformable. This does not catch all possible
|
a source-expr are conformable. This does not catch all possible
|
cases; in particular a runtime checking is needed. */
|
cases; in particular a runtime checking is needed. */
|
|
|
static gfc_try
|
static gfc_try
|
conformable_arrays (gfc_expr *e1, gfc_expr *e2)
|
conformable_arrays (gfc_expr *e1, gfc_expr *e2)
|
{
|
{
|
/* First compare rank. */
|
/* First compare rank. */
|
if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
|
if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
|
{
|
{
|
gfc_error ("Source-expr at %L must be scalar or have the "
|
gfc_error ("Source-expr at %L must be scalar or have the "
|
"same rank as the allocate-object at %L",
|
"same rank as the allocate-object at %L",
|
&e1->where, &e2->where);
|
&e1->where, &e2->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (e1->shape)
|
if (e1->shape)
|
{
|
{
|
int i;
|
int i;
|
mpz_t s;
|
mpz_t s;
|
|
|
mpz_init (s);
|
mpz_init (s);
|
|
|
for (i = 0; i < e1->rank; i++)
|
for (i = 0; i < e1->rank; i++)
|
{
|
{
|
if (e2->ref->u.ar.end[i])
|
if (e2->ref->u.ar.end[i])
|
{
|
{
|
mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
|
mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
|
mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
|
mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
|
mpz_add_ui (s, s, 1);
|
mpz_add_ui (s, s, 1);
|
}
|
}
|
else
|
else
|
{
|
{
|
mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
|
mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
|
}
|
}
|
|
|
if (mpz_cmp (e1->shape[i], s) != 0)
|
if (mpz_cmp (e1->shape[i], s) != 0)
|
{
|
{
|
gfc_error ("Source-expr at %L and allocate-object at %L must "
|
gfc_error ("Source-expr at %L and allocate-object at %L must "
|
"have the same shape", &e1->where, &e2->where);
|
"have the same shape", &e1->where, &e2->where);
|
mpz_clear (s);
|
mpz_clear (s);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
mpz_clear (s);
|
mpz_clear (s);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve the expression in an ALLOCATE statement, doing the additional
|
/* Resolve the expression in an ALLOCATE statement, doing the additional
|
checks to see whether the expression is OK or not. The expression must
|
checks to see whether the expression is OK or not. The expression must
|
have a trailing array reference that gives the size of the array. */
|
have a trailing array reference that gives the size of the array. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
{
|
{
|
int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
|
int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
|
symbol_attribute attr;
|
symbol_attribute attr;
|
gfc_ref *ref, *ref2;
|
gfc_ref *ref, *ref2;
|
gfc_array_ref *ar;
|
gfc_array_ref *ar;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_alloc *a;
|
gfc_alloc *a;
|
gfc_component *c;
|
gfc_component *c;
|
gfc_expr *init_e;
|
gfc_expr *init_e;
|
|
|
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
|
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
|
check_intent_in = 1;
|
check_intent_in = 1;
|
|
|
if (gfc_resolve_expr (e) == FAILURE)
|
if (gfc_resolve_expr (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Make sure the expression is allocatable or a pointer. If it is
|
/* Make sure the expression is allocatable or a pointer. If it is
|
pointer, the next-to-last reference must be a pointer. */
|
pointer, the next-to-last reference must be a pointer. */
|
|
|
ref2 = NULL;
|
ref2 = NULL;
|
if (e->symtree)
|
if (e->symtree)
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
|
|
/* Check whether ultimate component is abstract and CLASS. */
|
/* Check whether ultimate component is abstract and CLASS. */
|
is_abstract = 0;
|
is_abstract = 0;
|
|
|
if (e->expr_type != EXPR_VARIABLE)
|
if (e->expr_type != EXPR_VARIABLE)
|
{
|
{
|
allocatable = 0;
|
allocatable = 0;
|
attr = gfc_expr_attr (e);
|
attr = gfc_expr_attr (e);
|
pointer = attr.pointer;
|
pointer = attr.pointer;
|
dimension = attr.dimension;
|
dimension = attr.dimension;
|
}
|
}
|
else
|
else
|
{
|
{
|
if (sym->ts.type == BT_CLASS)
|
if (sym->ts.type == BT_CLASS)
|
{
|
{
|
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
pointer = sym->ts.u.derived->components->attr.pointer;
|
pointer = sym->ts.u.derived->components->attr.pointer;
|
dimension = sym->ts.u.derived->components->attr.dimension;
|
dimension = sym->ts.u.derived->components->attr.dimension;
|
is_abstract = sym->ts.u.derived->components->attr.abstract;
|
is_abstract = sym->ts.u.derived->components->attr.abstract;
|
}
|
}
|
else
|
else
|
{
|
{
|
allocatable = sym->attr.allocatable;
|
allocatable = sym->attr.allocatable;
|
pointer = sym->attr.pointer;
|
pointer = sym->attr.pointer;
|
dimension = sym->attr.dimension;
|
dimension = sym->attr.dimension;
|
}
|
}
|
|
|
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
|
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
|
{
|
{
|
if (pointer)
|
if (pointer)
|
check_intent_in = 0;
|
check_intent_in = 0;
|
|
|
switch (ref->type)
|
switch (ref->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
if (ref->next != NULL)
|
if (ref->next != NULL)
|
pointer = 0;
|
pointer = 0;
|
break;
|
break;
|
|
|
case REF_COMPONENT:
|
case REF_COMPONENT:
|
c = ref->u.c.component;
|
c = ref->u.c.component;
|
if (c->ts.type == BT_CLASS)
|
if (c->ts.type == BT_CLASS)
|
{
|
{
|
allocatable = c->ts.u.derived->components->attr.allocatable;
|
allocatable = c->ts.u.derived->components->attr.allocatable;
|
pointer = c->ts.u.derived->components->attr.pointer;
|
pointer = c->ts.u.derived->components->attr.pointer;
|
dimension = c->ts.u.derived->components->attr.dimension;
|
dimension = c->ts.u.derived->components->attr.dimension;
|
is_abstract = c->ts.u.derived->components->attr.abstract;
|
is_abstract = c->ts.u.derived->components->attr.abstract;
|
}
|
}
|
else
|
else
|
{
|
{
|
allocatable = c->attr.allocatable;
|
allocatable = c->attr.allocatable;
|
pointer = c->attr.pointer;
|
pointer = c->attr.pointer;
|
dimension = c->attr.dimension;
|
dimension = c->attr.dimension;
|
is_abstract = c->attr.abstract;
|
is_abstract = c->attr.abstract;
|
}
|
}
|
break;
|
break;
|
|
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
allocatable = 0;
|
allocatable = 0;
|
pointer = 0;
|
pointer = 0;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (allocatable == 0 && pointer == 0)
|
if (allocatable == 0 && pointer == 0)
|
{
|
{
|
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
|
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
|
&e->where);
|
&e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Some checks for the SOURCE tag. */
|
/* Some checks for the SOURCE tag. */
|
if (code->expr3)
|
if (code->expr3)
|
{
|
{
|
/* Check F03:C631. */
|
/* Check F03:C631. */
|
if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
|
if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
|
{
|
{
|
gfc_error ("Type of entity at %L is type incompatible with "
|
gfc_error ("Type of entity at %L is type incompatible with "
|
"source-expr at %L", &e->where, &code->expr3->where);
|
"source-expr at %L", &e->where, &code->expr3->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Check F03:C632 and restriction following Note 6.18. */
|
/* Check F03:C632 and restriction following Note 6.18. */
|
if (code->expr3->rank > 0
|
if (code->expr3->rank > 0
|
&& conformable_arrays (code->expr3, e) == FAILURE)
|
&& conformable_arrays (code->expr3, e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Check F03:C633. */
|
/* Check F03:C633. */
|
if (code->expr3->ts.kind != e->ts.kind)
|
if (code->expr3->ts.kind != e->ts.kind)
|
{
|
{
|
gfc_error ("The allocate-object at %L and the source-expr at %L "
|
gfc_error ("The allocate-object at %L and the source-expr at %L "
|
"shall have the same kind type parameter",
|
"shall have the same kind type parameter",
|
&e->where, &code->expr3->where);
|
&e->where, &code->expr3->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
|
else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
|
{
|
{
|
gcc_assert (e->ts.type == BT_CLASS);
|
gcc_assert (e->ts.type == BT_CLASS);
|
gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
|
gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
|
"type-spec or SOURCE=", sym->name, &e->where);
|
"type-spec or SOURCE=", sym->name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (check_intent_in && sym->attr.intent == INTENT_IN)
|
if (check_intent_in && sym->attr.intent == INTENT_IN)
|
{
|
{
|
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
|
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
|
sym->name, &e->where);
|
sym->name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!code->expr3)
|
if (!code->expr3)
|
{
|
{
|
/* Add default initializer for those derived types that need them. */
|
/* Add default initializer for those derived types that need them. */
|
if (e->ts.type == BT_DERIVED
|
if (e->ts.type == BT_DERIVED
|
&& (init_e = gfc_default_initializer (&e->ts)))
|
&& (init_e = gfc_default_initializer (&e->ts)))
|
{
|
{
|
gfc_code *init_st = gfc_get_code ();
|
gfc_code *init_st = gfc_get_code ();
|
init_st->loc = code->loc;
|
init_st->loc = code->loc;
|
init_st->op = EXEC_INIT_ASSIGN;
|
init_st->op = EXEC_INIT_ASSIGN;
|
init_st->expr1 = gfc_expr_to_initialize (e);
|
init_st->expr1 = gfc_expr_to_initialize (e);
|
init_st->expr2 = init_e;
|
init_st->expr2 = init_e;
|
init_st->next = code->next;
|
init_st->next = code->next;
|
code->next = init_st;
|
code->next = init_st;
|
}
|
}
|
else if (e->ts.type == BT_CLASS
|
else if (e->ts.type == BT_CLASS
|
&& ((code->ext.alloc.ts.type == BT_UNKNOWN
|
&& ((code->ext.alloc.ts.type == BT_UNKNOWN
|
&& (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts)))
|
&& (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts)))
|
|| (code->ext.alloc.ts.type == BT_DERIVED
|
|| (code->ext.alloc.ts.type == BT_DERIVED
|
&& (init_e = gfc_default_initializer (&code->ext.alloc.ts)))))
|
&& (init_e = gfc_default_initializer (&code->ext.alloc.ts)))))
|
{
|
{
|
gfc_code *init_st = gfc_get_code ();
|
gfc_code *init_st = gfc_get_code ();
|
init_st->loc = code->loc;
|
init_st->loc = code->loc;
|
init_st->op = EXEC_INIT_ASSIGN;
|
init_st->op = EXEC_INIT_ASSIGN;
|
init_st->expr1 = gfc_expr_to_initialize (e);
|
init_st->expr1 = gfc_expr_to_initialize (e);
|
init_st->expr2 = init_e;
|
init_st->expr2 = init_e;
|
init_st->next = code->next;
|
init_st->next = code->next;
|
code->next = init_st;
|
code->next = init_st;
|
}
|
}
|
}
|
}
|
|
|
if (pointer || dimension == 0)
|
if (pointer || dimension == 0)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* Make sure the next-to-last reference node is an array specification. */
|
/* Make sure the next-to-last reference node is an array specification. */
|
|
|
if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
|
if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
|
{
|
{
|
gfc_error ("Array specification required in ALLOCATE statement "
|
gfc_error ("Array specification required in ALLOCATE statement "
|
"at %L", &e->where);
|
"at %L", &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Make sure that the array section reference makes sense in the
|
/* Make sure that the array section reference makes sense in the
|
context of an ALLOCATE specification. */
|
context of an ALLOCATE specification. */
|
|
|
ar = &ref2->u.ar;
|
ar = &ref2->u.ar;
|
|
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
if (ref2->u.ar.type == AR_ELEMENT)
|
if (ref2->u.ar.type == AR_ELEMENT)
|
goto check_symbols;
|
goto check_symbols;
|
|
|
switch (ar->dimen_type[i])
|
switch (ar->dimen_type[i])
|
{
|
{
|
case DIMEN_ELEMENT:
|
case DIMEN_ELEMENT:
|
break;
|
break;
|
|
|
case DIMEN_RANGE:
|
case DIMEN_RANGE:
|
if (ar->start[i] != NULL
|
if (ar->start[i] != NULL
|
&& ar->end[i] != NULL
|
&& ar->end[i] != NULL
|
&& ar->stride[i] == NULL)
|
&& ar->stride[i] == NULL)
|
break;
|
break;
|
|
|
/* Fall Through... */
|
/* Fall Through... */
|
|
|
case DIMEN_UNKNOWN:
|
case DIMEN_UNKNOWN:
|
case DIMEN_VECTOR:
|
case DIMEN_VECTOR:
|
gfc_error ("Bad array specification in ALLOCATE statement at %L",
|
gfc_error ("Bad array specification in ALLOCATE statement at %L",
|
&e->where);
|
&e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
check_symbols:
|
check_symbols:
|
|
|
for (a = code->ext.alloc.list; a; a = a->next)
|
for (a = code->ext.alloc.list; a; a = a->next)
|
{
|
{
|
sym = a->expr->symtree->n.sym;
|
sym = a->expr->symtree->n.sym;
|
|
|
/* TODO - check derived type components. */
|
/* TODO - check derived type components. */
|
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
|
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
|
continue;
|
continue;
|
|
|
if ((ar->start[i] != NULL
|
if ((ar->start[i] != NULL
|
&& gfc_find_sym_in_expr (sym, ar->start[i]))
|
&& gfc_find_sym_in_expr (sym, ar->start[i]))
|
|| (ar->end[i] != NULL
|
|| (ar->end[i] != NULL
|
&& gfc_find_sym_in_expr (sym, ar->end[i])))
|
&& gfc_find_sym_in_expr (sym, ar->end[i])))
|
{
|
{
|
gfc_error ("'%s' must not appear in the array specification at "
|
gfc_error ("'%s' must not appear in the array specification at "
|
"%L in the same ALLOCATE statement where it is "
|
"%L in the same ALLOCATE statement where it is "
|
"itself allocated", sym->name, &ar->where);
|
"itself allocated", sym->name, &ar->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
static void
|
static void
|
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
|
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
|
{
|
{
|
gfc_expr *stat, *errmsg, *pe, *qe;
|
gfc_expr *stat, *errmsg, *pe, *qe;
|
gfc_alloc *a, *p, *q;
|
gfc_alloc *a, *p, *q;
|
|
|
stat = code->expr1 ? code->expr1 : NULL;
|
stat = code->expr1 ? code->expr1 : NULL;
|
|
|
errmsg = code->expr2 ? code->expr2 : NULL;
|
errmsg = code->expr2 ? code->expr2 : NULL;
|
|
|
/* Check the stat variable. */
|
/* Check the stat variable. */
|
if (stat)
|
if (stat)
|
{
|
{
|
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
|
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
|
gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
|
gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
|
stat->symtree->n.sym->name, &stat->where);
|
stat->symtree->n.sym->name, &stat->where);
|
|
|
if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
|
if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
|
gfc_error ("Illegal stat-variable at %L for a PURE procedure",
|
gfc_error ("Illegal stat-variable at %L for a PURE procedure",
|
&stat->where);
|
&stat->where);
|
|
|
if ((stat->ts.type != BT_INTEGER
|
if ((stat->ts.type != BT_INTEGER
|
&& !(stat->ref && (stat->ref->type == REF_ARRAY
|
&& !(stat->ref && (stat->ref->type == REF_ARRAY
|
|| stat->ref->type == REF_COMPONENT)))
|
|| stat->ref->type == REF_COMPONENT)))
|
|| stat->rank > 0)
|
|| stat->rank > 0)
|
gfc_error ("Stat-variable at %L must be a scalar INTEGER "
|
gfc_error ("Stat-variable at %L must be a scalar INTEGER "
|
"variable", &stat->where);
|
"variable", &stat->where);
|
|
|
for (p = code->ext.alloc.list; p; p = p->next)
|
for (p = code->ext.alloc.list; p; p = p->next)
|
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
|
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
|
{
|
{
|
gfc_ref *ref1, *ref2;
|
gfc_ref *ref1, *ref2;
|
bool found = true;
|
bool found = true;
|
|
|
for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
|
for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
|
ref1 = ref1->next, ref2 = ref2->next)
|
ref1 = ref1->next, ref2 = ref2->next)
|
{
|
{
|
if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
|
if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
|
continue;
|
continue;
|
if (ref1->u.c.component->name != ref2->u.c.component->name)
|
if (ref1->u.c.component->name != ref2->u.c.component->name)
|
{
|
{
|
found = false;
|
found = false;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
if (found)
|
if (found)
|
{
|
{
|
gfc_error ("Stat-variable at %L shall not be %sd within "
|
gfc_error ("Stat-variable at %L shall not be %sd within "
|
"the same %s statement", &stat->where, fcn, fcn);
|
"the same %s statement", &stat->where, fcn, fcn);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* Check the errmsg variable. */
|
/* Check the errmsg variable. */
|
if (errmsg)
|
if (errmsg)
|
{
|
{
|
if (!stat)
|
if (!stat)
|
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
|
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
|
&errmsg->where);
|
&errmsg->where);
|
|
|
if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
|
if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
|
gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
|
gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
|
errmsg->symtree->n.sym->name, &errmsg->where);
|
errmsg->symtree->n.sym->name, &errmsg->where);
|
|
|
if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
|
if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
|
gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
|
gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
|
&errmsg->where);
|
&errmsg->where);
|
|
|
if ((errmsg->ts.type != BT_CHARACTER
|
if ((errmsg->ts.type != BT_CHARACTER
|
&& !(errmsg->ref
|
&& !(errmsg->ref
|
&& (errmsg->ref->type == REF_ARRAY
|
&& (errmsg->ref->type == REF_ARRAY
|
|| errmsg->ref->type == REF_COMPONENT)))
|
|| errmsg->ref->type == REF_COMPONENT)))
|
|| errmsg->rank > 0 )
|
|| errmsg->rank > 0 )
|
gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
|
gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
|
"variable", &errmsg->where);
|
"variable", &errmsg->where);
|
|
|
for (p = code->ext.alloc.list; p; p = p->next)
|
for (p = code->ext.alloc.list; p; p = p->next)
|
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
|
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
|
{
|
{
|
gfc_ref *ref1, *ref2;
|
gfc_ref *ref1, *ref2;
|
bool found = true;
|
bool found = true;
|
|
|
for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
|
for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
|
ref1 = ref1->next, ref2 = ref2->next)
|
ref1 = ref1->next, ref2 = ref2->next)
|
{
|
{
|
if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
|
if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
|
continue;
|
continue;
|
if (ref1->u.c.component->name != ref2->u.c.component->name)
|
if (ref1->u.c.component->name != ref2->u.c.component->name)
|
{
|
{
|
found = false;
|
found = false;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
if (found)
|
if (found)
|
{
|
{
|
gfc_error ("Errmsg-variable at %L shall not be %sd within "
|
gfc_error ("Errmsg-variable at %L shall not be %sd within "
|
"the same %s statement", &errmsg->where, fcn, fcn);
|
"the same %s statement", &errmsg->where, fcn, fcn);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* Check that an allocate-object appears only once in the statement.
|
/* Check that an allocate-object appears only once in the statement.
|
FIXME: Checking derived types is disabled. */
|
FIXME: Checking derived types is disabled. */
|
for (p = code->ext.alloc.list; p; p = p->next)
|
for (p = code->ext.alloc.list; p; p = p->next)
|
{
|
{
|
pe = p->expr;
|
pe = p->expr;
|
if ((pe->ref && pe->ref->type != REF_COMPONENT)
|
if ((pe->ref && pe->ref->type != REF_COMPONENT)
|
&& (pe->symtree->n.sym->ts.type != BT_DERIVED))
|
&& (pe->symtree->n.sym->ts.type != BT_DERIVED))
|
{
|
{
|
for (q = p->next; q; q = q->next)
|
for (q = p->next; q; q = q->next)
|
{
|
{
|
qe = q->expr;
|
qe = q->expr;
|
if ((qe->ref && qe->ref->type != REF_COMPONENT)
|
if ((qe->ref && qe->ref->type != REF_COMPONENT)
|
&& (qe->symtree->n.sym->ts.type != BT_DERIVED)
|
&& (qe->symtree->n.sym->ts.type != BT_DERIVED)
|
&& (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
|
&& (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
|
gfc_error ("Allocate-object at %L also appears at %L",
|
gfc_error ("Allocate-object at %L also appears at %L",
|
&pe->where, &qe->where);
|
&pe->where, &qe->where);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (strcmp (fcn, "ALLOCATE") == 0)
|
if (strcmp (fcn, "ALLOCATE") == 0)
|
{
|
{
|
for (a = code->ext.alloc.list; a; a = a->next)
|
for (a = code->ext.alloc.list; a; a = a->next)
|
resolve_allocate_expr (a->expr, code);
|
resolve_allocate_expr (a->expr, code);
|
}
|
}
|
else
|
else
|
{
|
{
|
for (a = code->ext.alloc.list; a; a = a->next)
|
for (a = code->ext.alloc.list; a; a = a->next)
|
resolve_deallocate_expr (a->expr);
|
resolve_deallocate_expr (a->expr);
|
}
|
}
|
}
|
}
|
|
|
|
|
/************ SELECT CASE resolution subroutines ************/
|
/************ SELECT CASE resolution subroutines ************/
|
|
|
/* Callback function for our mergesort variant. Determines interval
|
/* Callback function for our mergesort variant. Determines interval
|
overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
|
overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
|
op1 > op2. Assumes we're not dealing with the default case.
|
op1 > op2. Assumes we're not dealing with the default case.
|
We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
|
We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
|
There are nine situations to check. */
|
There are nine situations to check. */
|
|
|
static int
|
static int
|
compare_cases (const gfc_case *op1, const gfc_case *op2)
|
compare_cases (const gfc_case *op1, const gfc_case *op2)
|
{
|
{
|
int retval;
|
int retval;
|
|
|
if (op1->low == NULL) /* op1 = (:L) */
|
if (op1->low == NULL) /* op1 = (:L) */
|
{
|
{
|
/* op2 = (:N), so overlap. */
|
/* op2 = (:N), so overlap. */
|
retval = 0;
|
retval = 0;
|
/* op2 = (M:) or (M:N), L < M */
|
/* op2 = (M:) or (M:N), L < M */
|
if (op2->low != NULL
|
if (op2->low != NULL
|
&& gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
|
&& gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
|
retval = -1;
|
retval = -1;
|
}
|
}
|
else if (op1->high == NULL) /* op1 = (K:) */
|
else if (op1->high == NULL) /* op1 = (K:) */
|
{
|
{
|
/* op2 = (M:), so overlap. */
|
/* op2 = (M:), so overlap. */
|
retval = 0;
|
retval = 0;
|
/* op2 = (:N) or (M:N), K > N */
|
/* op2 = (:N) or (M:N), K > N */
|
if (op2->high != NULL
|
if (op2->high != NULL
|
&& gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
|
&& gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
|
retval = 1;
|
retval = 1;
|
}
|
}
|
else /* op1 = (K:L) */
|
else /* op1 = (K:L) */
|
{
|
{
|
if (op2->low == NULL) /* op2 = (:N), K > N */
|
if (op2->low == NULL) /* op2 = (:N), K > N */
|
retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
|
retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
|
? 1 : 0;
|
? 1 : 0;
|
else if (op2->high == NULL) /* op2 = (M:), L < M */
|
else if (op2->high == NULL) /* op2 = (M:), L < M */
|
retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
|
retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
|
? -1 : 0;
|
? -1 : 0;
|
else /* op2 = (M:N) */
|
else /* op2 = (M:N) */
|
{
|
{
|
retval = 0;
|
retval = 0;
|
/* L < M */
|
/* L < M */
|
if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
|
if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
|
retval = -1;
|
retval = -1;
|
/* K > N */
|
/* K > N */
|
else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
|
else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
|
retval = 1;
|
retval = 1;
|
}
|
}
|
}
|
}
|
|
|
return retval;
|
return retval;
|
}
|
}
|
|
|
|
|
/* Merge-sort a double linked case list, detecting overlap in the
|
/* Merge-sort a double linked case list, detecting overlap in the
|
process. LIST is the head of the double linked case list before it
|
process. LIST is the head of the double linked case list before it
|
is sorted. Returns the head of the sorted list if we don't see any
|
is sorted. Returns the head of the sorted list if we don't see any
|
overlap, or NULL otherwise. */
|
overlap, or NULL otherwise. */
|
|
|
static gfc_case *
|
static gfc_case *
|
check_case_overlap (gfc_case *list)
|
check_case_overlap (gfc_case *list)
|
{
|
{
|
gfc_case *p, *q, *e, *tail;
|
gfc_case *p, *q, *e, *tail;
|
int insize, nmerges, psize, qsize, cmp, overlap_seen;
|
int insize, nmerges, psize, qsize, cmp, overlap_seen;
|
|
|
/* If the passed list was empty, return immediately. */
|
/* If the passed list was empty, return immediately. */
|
if (!list)
|
if (!list)
|
return NULL;
|
return NULL;
|
|
|
overlap_seen = 0;
|
overlap_seen = 0;
|
insize = 1;
|
insize = 1;
|
|
|
/* Loop unconditionally. The only exit from this loop is a return
|
/* Loop unconditionally. The only exit from this loop is a return
|
statement, when we've finished sorting the case list. */
|
statement, when we've finished sorting the case list. */
|
for (;;)
|
for (;;)
|
{
|
{
|
p = list;
|
p = list;
|
list = NULL;
|
list = NULL;
|
tail = NULL;
|
tail = NULL;
|
|
|
/* Count the number of merges we do in this pass. */
|
/* Count the number of merges we do in this pass. */
|
nmerges = 0;
|
nmerges = 0;
|
|
|
/* Loop while there exists a merge to be done. */
|
/* Loop while there exists a merge to be done. */
|
while (p)
|
while (p)
|
{
|
{
|
int i;
|
int i;
|
|
|
/* Count this merge. */
|
/* Count this merge. */
|
nmerges++;
|
nmerges++;
|
|
|
/* Cut the list in two pieces by stepping INSIZE places
|
/* Cut the list in two pieces by stepping INSIZE places
|
forward in the list, starting from P. */
|
forward in the list, starting from P. */
|
psize = 0;
|
psize = 0;
|
q = p;
|
q = p;
|
for (i = 0; i < insize; i++)
|
for (i = 0; i < insize; i++)
|
{
|
{
|
psize++;
|
psize++;
|
q = q->right;
|
q = q->right;
|
if (!q)
|
if (!q)
|
break;
|
break;
|
}
|
}
|
qsize = insize;
|
qsize = insize;
|
|
|
/* Now we have two lists. Merge them! */
|
/* Now we have two lists. Merge them! */
|
while (psize > 0 || (qsize > 0 && q != NULL))
|
while (psize > 0 || (qsize > 0 && q != NULL))
|
{
|
{
|
/* See from which the next case to merge comes from. */
|
/* See from which the next case to merge comes from. */
|
if (psize == 0)
|
if (psize == 0)
|
{
|
{
|
/* P is empty so the next case must come from Q. */
|
/* P is empty so the next case must come from Q. */
|
e = q;
|
e = q;
|
q = q->right;
|
q = q->right;
|
qsize--;
|
qsize--;
|
}
|
}
|
else if (qsize == 0 || q == NULL)
|
else if (qsize == 0 || q == NULL)
|
{
|
{
|
/* Q is empty. */
|
/* Q is empty. */
|
e = p;
|
e = p;
|
p = p->right;
|
p = p->right;
|
psize--;
|
psize--;
|
}
|
}
|
else
|
else
|
{
|
{
|
cmp = compare_cases (p, q);
|
cmp = compare_cases (p, q);
|
if (cmp < 0)
|
if (cmp < 0)
|
{
|
{
|
/* The whole case range for P is less than the
|
/* The whole case range for P is less than the
|
one for Q. */
|
one for Q. */
|
e = p;
|
e = p;
|
p = p->right;
|
p = p->right;
|
psize--;
|
psize--;
|
}
|
}
|
else if (cmp > 0)
|
else if (cmp > 0)
|
{
|
{
|
/* The whole case range for Q is greater than
|
/* The whole case range for Q is greater than
|
the case range for P. */
|
the case range for P. */
|
e = q;
|
e = q;
|
q = q->right;
|
q = q->right;
|
qsize--;
|
qsize--;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* The cases overlap, or they are the same
|
/* The cases overlap, or they are the same
|
element in the list. Either way, we must
|
element in the list. Either way, we must
|
issue an error and get the next case from P. */
|
issue an error and get the next case from P. */
|
/* FIXME: Sort P and Q by line number. */
|
/* FIXME: Sort P and Q by line number. */
|
gfc_error ("CASE label at %L overlaps with CASE "
|
gfc_error ("CASE label at %L overlaps with CASE "
|
"label at %L", &p->where, &q->where);
|
"label at %L", &p->where, &q->where);
|
overlap_seen = 1;
|
overlap_seen = 1;
|
e = p;
|
e = p;
|
p = p->right;
|
p = p->right;
|
psize--;
|
psize--;
|
}
|
}
|
}
|
}
|
|
|
/* Add the next element to the merged list. */
|
/* Add the next element to the merged list. */
|
if (tail)
|
if (tail)
|
tail->right = e;
|
tail->right = e;
|
else
|
else
|
list = e;
|
list = e;
|
e->left = tail;
|
e->left = tail;
|
tail = e;
|
tail = e;
|
}
|
}
|
|
|
/* P has now stepped INSIZE places along, and so has Q. So
|
/* P has now stepped INSIZE places along, and so has Q. So
|
they're the same. */
|
they're the same. */
|
p = q;
|
p = q;
|
}
|
}
|
tail->right = NULL;
|
tail->right = NULL;
|
|
|
/* If we have done only one merge or none at all, we've
|
/* If we have done only one merge or none at all, we've
|
finished sorting the cases. */
|
finished sorting the cases. */
|
if (nmerges <= 1)
|
if (nmerges <= 1)
|
{
|
{
|
if (!overlap_seen)
|
if (!overlap_seen)
|
return list;
|
return list;
|
else
|
else
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
/* Otherwise repeat, merging lists twice the size. */
|
/* Otherwise repeat, merging lists twice the size. */
|
insize *= 2;
|
insize *= 2;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Check to see if an expression is suitable for use in a CASE statement.
|
/* Check to see if an expression is suitable for use in a CASE statement.
|
Makes sure that all case expressions are scalar constants of the same
|
Makes sure that all case expressions are scalar constants of the same
|
type. Return FAILURE if anything is wrong. */
|
type. Return FAILURE if anything is wrong. */
|
|
|
static gfc_try
|
static gfc_try
|
validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
|
validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
|
{
|
{
|
if (e == NULL) return SUCCESS;
|
if (e == NULL) return SUCCESS;
|
|
|
if (e->ts.type != case_expr->ts.type)
|
if (e->ts.type != case_expr->ts.type)
|
{
|
{
|
gfc_error ("Expression in CASE statement at %L must be of type %s",
|
gfc_error ("Expression in CASE statement at %L must be of type %s",
|
&e->where, gfc_basic_typename (case_expr->ts.type));
|
&e->where, gfc_basic_typename (case_expr->ts.type));
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* C805 (R808) For a given case-construct, each case-value shall be of
|
/* C805 (R808) For a given case-construct, each case-value shall be of
|
the same type as case-expr. For character type, length differences
|
the same type as case-expr. For character type, length differences
|
are allowed, but the kind type parameters shall be the same. */
|
are allowed, but the kind type parameters shall be the same. */
|
|
|
if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
|
if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
|
{
|
{
|
gfc_error ("Expression in CASE statement at %L must be of kind %d",
|
gfc_error ("Expression in CASE statement at %L must be of kind %d",
|
&e->where, case_expr->ts.kind);
|
&e->where, case_expr->ts.kind);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Convert the case value kind to that of case expression kind, if needed.
|
/* Convert the case value kind to that of case expression kind, if needed.
|
FIXME: Should a warning be issued? */
|
FIXME: Should a warning be issued? */
|
if (e->ts.kind != case_expr->ts.kind)
|
if (e->ts.kind != case_expr->ts.kind)
|
gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
|
gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
|
|
|
if (e->rank != 0)
|
if (e->rank != 0)
|
{
|
{
|
gfc_error ("Expression in CASE statement at %L must be scalar",
|
gfc_error ("Expression in CASE statement at %L must be scalar",
|
&e->where);
|
&e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Given a completely parsed select statement, we:
|
/* Given a completely parsed select statement, we:
|
|
|
- Validate all expressions and code within the SELECT.
|
- Validate all expressions and code within the SELECT.
|
- Make sure that the selection expression is not of the wrong type.
|
- Make sure that the selection expression is not of the wrong type.
|
- Make sure that no case ranges overlap.
|
- Make sure that no case ranges overlap.
|
- Eliminate unreachable cases and unreachable code resulting from
|
- Eliminate unreachable cases and unreachable code resulting from
|
removing case labels.
|
removing case labels.
|
|
|
The standard does allow unreachable cases, e.g. CASE (5:3). But
|
The standard does allow unreachable cases, e.g. CASE (5:3). But
|
they are a hassle for code generation, and to prevent that, we just
|
they are a hassle for code generation, and to prevent that, we just
|
cut them out here. This is not necessary for overlapping cases
|
cut them out here. This is not necessary for overlapping cases
|
because they are illegal and we never even try to generate code.
|
because they are illegal and we never even try to generate code.
|
|
|
We have the additional caveat that a SELECT construct could have
|
We have the additional caveat that a SELECT construct could have
|
been a computed GOTO in the source code. Fortunately we can fairly
|
been a computed GOTO in the source code. Fortunately we can fairly
|
easily work around that here: The case_expr for a "real" SELECT CASE
|
easily work around that here: The case_expr for a "real" SELECT CASE
|
is in code->expr1, but for a computed GOTO it is in code->expr2. All
|
is in code->expr1, but for a computed GOTO it is in code->expr2. All
|
we have to do is make sure that the case_expr is a scalar integer
|
we have to do is make sure that the case_expr is a scalar integer
|
expression. */
|
expression. */
|
|
|
static void
|
static void
|
resolve_select (gfc_code *code)
|
resolve_select (gfc_code *code)
|
{
|
{
|
gfc_code *body;
|
gfc_code *body;
|
gfc_expr *case_expr;
|
gfc_expr *case_expr;
|
gfc_case *cp, *default_case, *tail, *head;
|
gfc_case *cp, *default_case, *tail, *head;
|
int seen_unreachable;
|
int seen_unreachable;
|
int seen_logical;
|
int seen_logical;
|
int ncases;
|
int ncases;
|
bt type;
|
bt type;
|
gfc_try t;
|
gfc_try t;
|
|
|
if (code->expr1 == NULL)
|
if (code->expr1 == NULL)
|
{
|
{
|
/* This was actually a computed GOTO statement. */
|
/* This was actually a computed GOTO statement. */
|
case_expr = code->expr2;
|
case_expr = code->expr2;
|
if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
|
if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
|
gfc_error ("Selection expression in computed GOTO statement "
|
gfc_error ("Selection expression in computed GOTO statement "
|
"at %L must be a scalar integer expression",
|
"at %L must be a scalar integer expression",
|
&case_expr->where);
|
&case_expr->where);
|
|
|
/* Further checking is not necessary because this SELECT was built
|
/* Further checking is not necessary because this SELECT was built
|
by the compiler, so it should always be OK. Just move the
|
by the compiler, so it should always be OK. Just move the
|
case_expr from expr2 to expr so that we can handle computed
|
case_expr from expr2 to expr so that we can handle computed
|
GOTOs as normal SELECTs from here on. */
|
GOTOs as normal SELECTs from here on. */
|
code->expr1 = code->expr2;
|
code->expr1 = code->expr2;
|
code->expr2 = NULL;
|
code->expr2 = NULL;
|
return;
|
return;
|
}
|
}
|
|
|
case_expr = code->expr1;
|
case_expr = code->expr1;
|
|
|
type = case_expr->ts.type;
|
type = case_expr->ts.type;
|
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
|
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
|
{
|
{
|
gfc_error ("Argument of SELECT statement at %L cannot be %s",
|
gfc_error ("Argument of SELECT statement at %L cannot be %s",
|
&case_expr->where, gfc_typename (&case_expr->ts));
|
&case_expr->where, gfc_typename (&case_expr->ts));
|
|
|
/* Punt. Going on here just produce more garbage error messages. */
|
/* Punt. Going on here just produce more garbage error messages. */
|
return;
|
return;
|
}
|
}
|
|
|
if (case_expr->rank != 0)
|
if (case_expr->rank != 0)
|
{
|
{
|
gfc_error ("Argument of SELECT statement at %L must be a scalar "
|
gfc_error ("Argument of SELECT statement at %L must be a scalar "
|
"expression", &case_expr->where);
|
"expression", &case_expr->where);
|
|
|
/* Punt. */
|
/* Punt. */
|
return;
|
return;
|
}
|
}
|
|
|
/* PR 19168 has a long discussion concerning a mismatch of the kinds
|
/* PR 19168 has a long discussion concerning a mismatch of the kinds
|
of the SELECT CASE expression and its CASE values. Walk the lists
|
of the SELECT CASE expression and its CASE values. Walk the lists
|
of case values, and if we find a mismatch, promote case_expr to
|
of case values, and if we find a mismatch, promote case_expr to
|
the appropriate kind. */
|
the appropriate kind. */
|
|
|
if (type == BT_LOGICAL || type == BT_INTEGER)
|
if (type == BT_LOGICAL || type == BT_INTEGER)
|
{
|
{
|
for (body = code->block; body; body = body->block)
|
for (body = code->block; body; body = body->block)
|
{
|
{
|
/* Walk the case label list. */
|
/* Walk the case label list. */
|
for (cp = body->ext.case_list; cp; cp = cp->next)
|
for (cp = body->ext.case_list; cp; cp = cp->next)
|
{
|
{
|
/* Intercept the DEFAULT case. It does not have a kind. */
|
/* Intercept the DEFAULT case. It does not have a kind. */
|
if (cp->low == NULL && cp->high == NULL)
|
if (cp->low == NULL && cp->high == NULL)
|
continue;
|
continue;
|
|
|
/* Unreachable case ranges are discarded, so ignore. */
|
/* Unreachable case ranges are discarded, so ignore. */
|
if (cp->low != NULL && cp->high != NULL
|
if (cp->low != NULL && cp->high != NULL
|
&& cp->low != cp->high
|
&& cp->low != cp->high
|
&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
|
&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
|
continue;
|
continue;
|
|
|
/* FIXME: Should a warning be issued? */
|
/* FIXME: Should a warning be issued? */
|
if (cp->low != NULL
|
if (cp->low != NULL
|
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
|
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
|
gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
|
gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
|
|
|
if (cp->high != NULL
|
if (cp->high != NULL
|
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
|
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
|
gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
|
gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* Assume there is no DEFAULT case. */
|
/* Assume there is no DEFAULT case. */
|
default_case = NULL;
|
default_case = NULL;
|
head = tail = NULL;
|
head = tail = NULL;
|
ncases = 0;
|
ncases = 0;
|
seen_logical = 0;
|
seen_logical = 0;
|
|
|
for (body = code->block; body; body = body->block)
|
for (body = code->block; body; body = body->block)
|
{
|
{
|
/* Assume the CASE list is OK, and all CASE labels can be matched. */
|
/* Assume the CASE list is OK, and all CASE labels can be matched. */
|
t = SUCCESS;
|
t = SUCCESS;
|
seen_unreachable = 0;
|
seen_unreachable = 0;
|
|
|
/* Walk the case label list, making sure that all case labels
|
/* Walk the case label list, making sure that all case labels
|
are legal. */
|
are legal. */
|
for (cp = body->ext.case_list; cp; cp = cp->next)
|
for (cp = body->ext.case_list; cp; cp = cp->next)
|
{
|
{
|
/* Count the number of cases in the whole construct. */
|
/* Count the number of cases in the whole construct. */
|
ncases++;
|
ncases++;
|
|
|
/* Intercept the DEFAULT case. */
|
/* Intercept the DEFAULT case. */
|
if (cp->low == NULL && cp->high == NULL)
|
if (cp->low == NULL && cp->high == NULL)
|
{
|
{
|
if (default_case != NULL)
|
if (default_case != NULL)
|
{
|
{
|
gfc_error ("The DEFAULT CASE at %L cannot be followed "
|
gfc_error ("The DEFAULT CASE at %L cannot be followed "
|
"by a second DEFAULT CASE at %L",
|
"by a second DEFAULT CASE at %L",
|
&default_case->where, &cp->where);
|
&default_case->where, &cp->where);
|
t = FAILURE;
|
t = FAILURE;
|
break;
|
break;
|
}
|
}
|
else
|
else
|
{
|
{
|
default_case = cp;
|
default_case = cp;
|
continue;
|
continue;
|
}
|
}
|
}
|
}
|
|
|
/* Deal with single value cases and case ranges. Errors are
|
/* Deal with single value cases and case ranges. Errors are
|
issued from the validation function. */
|
issued from the validation function. */
|
if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
|
if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
|
|| validate_case_label_expr (cp->high, case_expr) != SUCCESS)
|
|| validate_case_label_expr (cp->high, case_expr) != SUCCESS)
|
{
|
{
|
t = FAILURE;
|
t = FAILURE;
|
break;
|
break;
|
}
|
}
|
|
|
if (type == BT_LOGICAL
|
if (type == BT_LOGICAL
|
&& ((cp->low == NULL || cp->high == NULL)
|
&& ((cp->low == NULL || cp->high == NULL)
|
|| cp->low != cp->high))
|
|| cp->low != cp->high))
|
{
|
{
|
gfc_error ("Logical range in CASE statement at %L is not "
|
gfc_error ("Logical range in CASE statement at %L is not "
|
"allowed", &cp->low->where);
|
"allowed", &cp->low->where);
|
t = FAILURE;
|
t = FAILURE;
|
break;
|
break;
|
}
|
}
|
|
|
if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
|
if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
|
{
|
{
|
int value;
|
int value;
|
value = cp->low->value.logical == 0 ? 2 : 1;
|
value = cp->low->value.logical == 0 ? 2 : 1;
|
if (value & seen_logical)
|
if (value & seen_logical)
|
{
|
{
|
gfc_error ("constant logical value in CASE statement "
|
gfc_error ("constant logical value in CASE statement "
|
"is repeated at %L",
|
"is repeated at %L",
|
&cp->low->where);
|
&cp->low->where);
|
t = FAILURE;
|
t = FAILURE;
|
break;
|
break;
|
}
|
}
|
seen_logical |= value;
|
seen_logical |= value;
|
}
|
}
|
|
|
if (cp->low != NULL && cp->high != NULL
|
if (cp->low != NULL && cp->high != NULL
|
&& cp->low != cp->high
|
&& cp->low != cp->high
|
&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
|
&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
|
{
|
{
|
if (gfc_option.warn_surprising)
|
if (gfc_option.warn_surprising)
|
gfc_warning ("Range specification at %L can never "
|
gfc_warning ("Range specification at %L can never "
|
"be matched", &cp->where);
|
"be matched", &cp->where);
|
|
|
cp->unreachable = 1;
|
cp->unreachable = 1;
|
seen_unreachable = 1;
|
seen_unreachable = 1;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* If the case range can be matched, it can also overlap with
|
/* If the case range can be matched, it can also overlap with
|
other cases. To make sure it does not, we put it in a
|
other cases. To make sure it does not, we put it in a
|
double linked list here. We sort that with a merge sort
|
double linked list here. We sort that with a merge sort
|
later on to detect any overlapping cases. */
|
later on to detect any overlapping cases. */
|
if (!head)
|
if (!head)
|
{
|
{
|
head = tail = cp;
|
head = tail = cp;
|
head->right = head->left = NULL;
|
head->right = head->left = NULL;
|
}
|
}
|
else
|
else
|
{
|
{
|
tail->right = cp;
|
tail->right = cp;
|
tail->right->left = tail;
|
tail->right->left = tail;
|
tail = tail->right;
|
tail = tail->right;
|
tail->right = NULL;
|
tail->right = NULL;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* It there was a failure in the previous case label, give up
|
/* It there was a failure in the previous case label, give up
|
for this case label list. Continue with the next block. */
|
for this case label list. Continue with the next block. */
|
if (t == FAILURE)
|
if (t == FAILURE)
|
continue;
|
continue;
|
|
|
/* See if any case labels that are unreachable have been seen.
|
/* See if any case labels that are unreachable have been seen.
|
If so, we eliminate them. This is a bit of a kludge because
|
If so, we eliminate them. This is a bit of a kludge because
|
the case lists for a single case statement (label) is a
|
the case lists for a single case statement (label) is a
|
single forward linked lists. */
|
single forward linked lists. */
|
if (seen_unreachable)
|
if (seen_unreachable)
|
{
|
{
|
/* Advance until the first case in the list is reachable. */
|
/* Advance until the first case in the list is reachable. */
|
while (body->ext.case_list != NULL
|
while (body->ext.case_list != NULL
|
&& body->ext.case_list->unreachable)
|
&& body->ext.case_list->unreachable)
|
{
|
{
|
gfc_case *n = body->ext.case_list;
|
gfc_case *n = body->ext.case_list;
|
body->ext.case_list = body->ext.case_list->next;
|
body->ext.case_list = body->ext.case_list->next;
|
n->next = NULL;
|
n->next = NULL;
|
gfc_free_case_list (n);
|
gfc_free_case_list (n);
|
}
|
}
|
|
|
/* Strip all other unreachable cases. */
|
/* Strip all other unreachable cases. */
|
if (body->ext.case_list)
|
if (body->ext.case_list)
|
{
|
{
|
for (cp = body->ext.case_list; cp->next; cp = cp->next)
|
for (cp = body->ext.case_list; cp->next; cp = cp->next)
|
{
|
{
|
if (cp->next->unreachable)
|
if (cp->next->unreachable)
|
{
|
{
|
gfc_case *n = cp->next;
|
gfc_case *n = cp->next;
|
cp->next = cp->next->next;
|
cp->next = cp->next->next;
|
n->next = NULL;
|
n->next = NULL;
|
gfc_free_case_list (n);
|
gfc_free_case_list (n);
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* See if there were overlapping cases. If the check returns NULL,
|
/* See if there were overlapping cases. If the check returns NULL,
|
there was overlap. In that case we don't do anything. If head
|
there was overlap. In that case we don't do anything. If head
|
is non-NULL, we prepend the DEFAULT case. The sorted list can
|
is non-NULL, we prepend the DEFAULT case. The sorted list can
|
then used during code generation for SELECT CASE constructs with
|
then used during code generation for SELECT CASE constructs with
|
a case expression of a CHARACTER type. */
|
a case expression of a CHARACTER type. */
|
if (head)
|
if (head)
|
{
|
{
|
head = check_case_overlap (head);
|
head = check_case_overlap (head);
|
|
|
/* Prepend the default_case if it is there. */
|
/* Prepend the default_case if it is there. */
|
if (head != NULL && default_case)
|
if (head != NULL && default_case)
|
{
|
{
|
default_case->left = NULL;
|
default_case->left = NULL;
|
default_case->right = head;
|
default_case->right = head;
|
head->left = default_case;
|
head->left = default_case;
|
}
|
}
|
}
|
}
|
|
|
/* Eliminate dead blocks that may be the result if we've seen
|
/* Eliminate dead blocks that may be the result if we've seen
|
unreachable case labels for a block. */
|
unreachable case labels for a block. */
|
for (body = code; body && body->block; body = body->block)
|
for (body = code; body && body->block; body = body->block)
|
{
|
{
|
if (body->block->ext.case_list == NULL)
|
if (body->block->ext.case_list == NULL)
|
{
|
{
|
/* Cut the unreachable block from the code chain. */
|
/* Cut the unreachable block from the code chain. */
|
gfc_code *c = body->block;
|
gfc_code *c = body->block;
|
body->block = c->block;
|
body->block = c->block;
|
|
|
/* Kill the dead block, but not the blocks below it. */
|
/* Kill the dead block, but not the blocks below it. */
|
c->block = NULL;
|
c->block = NULL;
|
gfc_free_statements (c);
|
gfc_free_statements (c);
|
}
|
}
|
}
|
}
|
|
|
/* More than two cases is legal but insane for logical selects.
|
/* More than two cases is legal but insane for logical selects.
|
Issue a warning for it. */
|
Issue a warning for it. */
|
if (gfc_option.warn_surprising && type == BT_LOGICAL
|
if (gfc_option.warn_surprising && type == BT_LOGICAL
|
&& ncases > 2)
|
&& ncases > 2)
|
gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
|
gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
|
&code->loc);
|
&code->loc);
|
}
|
}
|
|
|
|
|
/* Check if a derived type is extensible. */
|
/* Check if a derived type is extensible. */
|
|
|
bool
|
bool
|
gfc_type_is_extensible (gfc_symbol *sym)
|
gfc_type_is_extensible (gfc_symbol *sym)
|
{
|
{
|
return !(sym->attr.is_bind_c || sym->attr.sequence);
|
return !(sym->attr.is_bind_c || sym->attr.sequence);
|
}
|
}
|
|
|
|
|
/* Resolve a SELECT TYPE statement. */
|
/* Resolve a SELECT TYPE statement. */
|
|
|
static void
|
static void
|
resolve_select_type (gfc_code *code)
|
resolve_select_type (gfc_code *code)
|
{
|
{
|
gfc_symbol *selector_type;
|
gfc_symbol *selector_type;
|
gfc_code *body, *new_st, *if_st, *tail;
|
gfc_code *body, *new_st, *if_st, *tail;
|
gfc_code *class_is = NULL, *default_case = NULL;
|
gfc_code *class_is = NULL, *default_case = NULL;
|
gfc_case *c;
|
gfc_case *c;
|
gfc_symtree *st;
|
gfc_symtree *st;
|
char name[GFC_MAX_SYMBOL_LEN];
|
char name[GFC_MAX_SYMBOL_LEN];
|
gfc_namespace *ns;
|
gfc_namespace *ns;
|
int error = 0;
|
int error = 0;
|
|
|
ns = code->ext.ns;
|
ns = code->ext.ns;
|
gfc_resolve (ns);
|
gfc_resolve (ns);
|
|
|
if (code->expr2)
|
if (code->expr2)
|
selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
|
selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
|
else
|
else
|
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
|
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
|
|
|
/* Loop over TYPE IS / CLASS IS cases. */
|
/* Loop over TYPE IS / CLASS IS cases. */
|
for (body = code->block; body; body = body->block)
|
for (body = code->block; body; body = body->block)
|
{
|
{
|
c = body->ext.case_list;
|
c = body->ext.case_list;
|
|
|
/* Check F03:C815. */
|
/* Check F03:C815. */
|
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
&& !gfc_type_is_extensible (c->ts.u.derived))
|
&& !gfc_type_is_extensible (c->ts.u.derived))
|
{
|
{
|
gfc_error ("Derived type '%s' at %L must be extensible",
|
gfc_error ("Derived type '%s' at %L must be extensible",
|
c->ts.u.derived->name, &c->where);
|
c->ts.u.derived->name, &c->where);
|
error++;
|
error++;
|
continue;
|
continue;
|
}
|
}
|
|
|
/* Check F03:C816. */
|
/* Check F03:C816. */
|
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
&& !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
|
&& !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
|
{
|
{
|
gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
|
gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
|
c->ts.u.derived->name, &c->where, selector_type->name);
|
c->ts.u.derived->name, &c->where, selector_type->name);
|
error++;
|
error++;
|
continue;
|
continue;
|
}
|
}
|
|
|
/* Intercept the DEFAULT case. */
|
/* Intercept the DEFAULT case. */
|
if (c->ts.type == BT_UNKNOWN)
|
if (c->ts.type == BT_UNKNOWN)
|
{
|
{
|
/* Check F03:C818. */
|
/* Check F03:C818. */
|
if (default_case)
|
if (default_case)
|
{
|
{
|
gfc_error ("The DEFAULT CASE at %L cannot be followed "
|
gfc_error ("The DEFAULT CASE at %L cannot be followed "
|
"by a second DEFAULT CASE at %L",
|
"by a second DEFAULT CASE at %L",
|
&default_case->ext.case_list->where, &c->where);
|
&default_case->ext.case_list->where, &c->where);
|
error++;
|
error++;
|
continue;
|
continue;
|
}
|
}
|
else
|
else
|
default_case = body;
|
default_case = body;
|
}
|
}
|
}
|
}
|
|
|
if (error>0)
|
if (error>0)
|
return;
|
return;
|
|
|
if (code->expr2)
|
if (code->expr2)
|
{
|
{
|
/* Insert assignment for selector variable. */
|
/* Insert assignment for selector variable. */
|
new_st = gfc_get_code ();
|
new_st = gfc_get_code ();
|
new_st->op = EXEC_ASSIGN;
|
new_st->op = EXEC_ASSIGN;
|
new_st->expr1 = gfc_copy_expr (code->expr1);
|
new_st->expr1 = gfc_copy_expr (code->expr1);
|
new_st->expr2 = gfc_copy_expr (code->expr2);
|
new_st->expr2 = gfc_copy_expr (code->expr2);
|
ns->code = new_st;
|
ns->code = new_st;
|
}
|
}
|
|
|
/* Put SELECT TYPE statement inside a BLOCK. */
|
/* Put SELECT TYPE statement inside a BLOCK. */
|
new_st = gfc_get_code ();
|
new_st = gfc_get_code ();
|
new_st->op = code->op;
|
new_st->op = code->op;
|
new_st->expr1 = code->expr1;
|
new_st->expr1 = code->expr1;
|
new_st->expr2 = code->expr2;
|
new_st->expr2 = code->expr2;
|
new_st->block = code->block;
|
new_st->block = code->block;
|
if (!ns->code)
|
if (!ns->code)
|
ns->code = new_st;
|
ns->code = new_st;
|
else
|
else
|
ns->code->next = new_st;
|
ns->code->next = new_st;
|
code->op = EXEC_BLOCK;
|
code->op = EXEC_BLOCK;
|
code->expr1 = code->expr2 = NULL;
|
code->expr1 = code->expr2 = NULL;
|
code->block = NULL;
|
code->block = NULL;
|
|
|
code = new_st;
|
code = new_st;
|
|
|
/* Transform to EXEC_SELECT. */
|
/* Transform to EXEC_SELECT. */
|
code->op = EXEC_SELECT;
|
code->op = EXEC_SELECT;
|
gfc_add_component_ref (code->expr1, "$vptr");
|
gfc_add_component_ref (code->expr1, "$vptr");
|
gfc_add_component_ref (code->expr1, "$hash");
|
gfc_add_component_ref (code->expr1, "$hash");
|
|
|
/* Loop over TYPE IS / CLASS IS cases. */
|
/* Loop over TYPE IS / CLASS IS cases. */
|
for (body = code->block; body; body = body->block)
|
for (body = code->block; body; body = body->block)
|
{
|
{
|
c = body->ext.case_list;
|
c = body->ext.case_list;
|
|
|
if (c->ts.type == BT_DERIVED)
|
if (c->ts.type == BT_DERIVED)
|
c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
|
c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
|
else if (c->ts.type == BT_UNKNOWN)
|
else if (c->ts.type == BT_UNKNOWN)
|
continue;
|
continue;
|
|
|
/* Assign temporary to selector. */
|
/* Assign temporary to selector. */
|
if (c->ts.type == BT_CLASS)
|
if (c->ts.type == BT_CLASS)
|
sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
|
sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
|
else
|
else
|
sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
|
sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
|
st = gfc_find_symtree (ns->sym_root, name);
|
st = gfc_find_symtree (ns->sym_root, name);
|
new_st = gfc_get_code ();
|
new_st = gfc_get_code ();
|
new_st->expr1 = gfc_get_variable_expr (st);
|
new_st->expr1 = gfc_get_variable_expr (st);
|
new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
|
new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
|
if (c->ts.type == BT_DERIVED)
|
if (c->ts.type == BT_DERIVED)
|
{
|
{
|
new_st->op = EXEC_POINTER_ASSIGN;
|
new_st->op = EXEC_POINTER_ASSIGN;
|
gfc_add_component_ref (new_st->expr2, "$data");
|
gfc_add_component_ref (new_st->expr2, "$data");
|
}
|
}
|
else
|
else
|
new_st->op = EXEC_POINTER_ASSIGN;
|
new_st->op = EXEC_POINTER_ASSIGN;
|
new_st->next = body->next;
|
new_st->next = body->next;
|
body->next = new_st;
|
body->next = new_st;
|
}
|
}
|
|
|
/* Take out CLASS IS cases for separate treatment. */
|
/* Take out CLASS IS cases for separate treatment. */
|
body = code;
|
body = code;
|
while (body && body->block)
|
while (body && body->block)
|
{
|
{
|
if (body->block->ext.case_list->ts.type == BT_CLASS)
|
if (body->block->ext.case_list->ts.type == BT_CLASS)
|
{
|
{
|
/* Add to class_is list. */
|
/* Add to class_is list. */
|
if (class_is == NULL)
|
if (class_is == NULL)
|
{
|
{
|
class_is = body->block;
|
class_is = body->block;
|
tail = class_is;
|
tail = class_is;
|
}
|
}
|
else
|
else
|
{
|
{
|
for (tail = class_is; tail->block; tail = tail->block) ;
|
for (tail = class_is; tail->block; tail = tail->block) ;
|
tail->block = body->block;
|
tail->block = body->block;
|
tail = tail->block;
|
tail = tail->block;
|
}
|
}
|
/* Remove from EXEC_SELECT list. */
|
/* Remove from EXEC_SELECT list. */
|
body->block = body->block->block;
|
body->block = body->block->block;
|
tail->block = NULL;
|
tail->block = NULL;
|
}
|
}
|
else
|
else
|
body = body->block;
|
body = body->block;
|
}
|
}
|
|
|
if (class_is)
|
if (class_is)
|
{
|
{
|
gfc_symbol *vtab;
|
gfc_symbol *vtab;
|
|
|
if (!default_case)
|
if (!default_case)
|
{
|
{
|
/* Add a default case to hold the CLASS IS cases. */
|
/* Add a default case to hold the CLASS IS cases. */
|
for (tail = code; tail->block; tail = tail->block) ;
|
for (tail = code; tail->block; tail = tail->block) ;
|
tail->block = gfc_get_code ();
|
tail->block = gfc_get_code ();
|
tail = tail->block;
|
tail = tail->block;
|
tail->op = EXEC_SELECT_TYPE;
|
tail->op = EXEC_SELECT_TYPE;
|
tail->ext.case_list = gfc_get_case ();
|
tail->ext.case_list = gfc_get_case ();
|
tail->ext.case_list->ts.type = BT_UNKNOWN;
|
tail->ext.case_list->ts.type = BT_UNKNOWN;
|
tail->next = NULL;
|
tail->next = NULL;
|
default_case = tail;
|
default_case = tail;
|
}
|
}
|
|
|
/* More than one CLASS IS block? */
|
/* More than one CLASS IS block? */
|
if (class_is->block)
|
if (class_is->block)
|
{
|
{
|
gfc_code **c1,*c2;
|
gfc_code **c1,*c2;
|
bool swapped;
|
bool swapped;
|
/* Sort CLASS IS blocks by extension level. */
|
/* Sort CLASS IS blocks by extension level. */
|
do
|
do
|
{
|
{
|
swapped = false;
|
swapped = false;
|
for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
|
for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
|
{
|
{
|
c2 = (*c1)->block;
|
c2 = (*c1)->block;
|
/* F03:C817 (check for doubles). */
|
/* F03:C817 (check for doubles). */
|
if ((*c1)->ext.case_list->ts.u.derived->hash_value
|
if ((*c1)->ext.case_list->ts.u.derived->hash_value
|
== c2->ext.case_list->ts.u.derived->hash_value)
|
== c2->ext.case_list->ts.u.derived->hash_value)
|
{
|
{
|
gfc_error ("Double CLASS IS block in SELECT TYPE "
|
gfc_error ("Double CLASS IS block in SELECT TYPE "
|
"statement at %L", &c2->ext.case_list->where);
|
"statement at %L", &c2->ext.case_list->where);
|
return;
|
return;
|
}
|
}
|
if ((*c1)->ext.case_list->ts.u.derived->attr.extension
|
if ((*c1)->ext.case_list->ts.u.derived->attr.extension
|
< c2->ext.case_list->ts.u.derived->attr.extension)
|
< c2->ext.case_list->ts.u.derived->attr.extension)
|
{
|
{
|
/* Swap. */
|
/* Swap. */
|
(*c1)->block = c2->block;
|
(*c1)->block = c2->block;
|
c2->block = *c1;
|
c2->block = *c1;
|
*c1 = c2;
|
*c1 = c2;
|
swapped = true;
|
swapped = true;
|
}
|
}
|
}
|
}
|
}
|
}
|
while (swapped);
|
while (swapped);
|
}
|
}
|
|
|
/* Generate IF chain. */
|
/* Generate IF chain. */
|
if_st = gfc_get_code ();
|
if_st = gfc_get_code ();
|
if_st->op = EXEC_IF;
|
if_st->op = EXEC_IF;
|
new_st = if_st;
|
new_st = if_st;
|
for (body = class_is; body; body = body->block)
|
for (body = class_is; body; body = body->block)
|
{
|
{
|
new_st->block = gfc_get_code ();
|
new_st->block = gfc_get_code ();
|
new_st = new_st->block;
|
new_st = new_st->block;
|
new_st->op = EXEC_IF;
|
new_st->op = EXEC_IF;
|
/* Set up IF condition: Call _gfortran_is_extension_of. */
|
/* Set up IF condition: Call _gfortran_is_extension_of. */
|
new_st->expr1 = gfc_get_expr ();
|
new_st->expr1 = gfc_get_expr ();
|
new_st->expr1->expr_type = EXPR_FUNCTION;
|
new_st->expr1->expr_type = EXPR_FUNCTION;
|
new_st->expr1->ts.type = BT_LOGICAL;
|
new_st->expr1->ts.type = BT_LOGICAL;
|
new_st->expr1->ts.kind = 4;
|
new_st->expr1->ts.kind = 4;
|
new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
|
new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
|
new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
|
new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
|
new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
|
new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
|
/* Set up arguments. */
|
/* Set up arguments. */
|
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
|
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
|
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
|
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
|
gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
|
gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
|
vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
|
vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
|
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
|
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
|
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
|
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
|
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
|
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
|
new_st->next = body->next;
|
new_st->next = body->next;
|
}
|
}
|
if (default_case->next)
|
if (default_case->next)
|
{
|
{
|
new_st->block = gfc_get_code ();
|
new_st->block = gfc_get_code ();
|
new_st = new_st->block;
|
new_st = new_st->block;
|
new_st->op = EXEC_IF;
|
new_st->op = EXEC_IF;
|
new_st->next = default_case->next;
|
new_st->next = default_case->next;
|
}
|
}
|
|
|
/* Replace CLASS DEFAULT code by the IF chain. */
|
/* Replace CLASS DEFAULT code by the IF chain. */
|
default_case->next = if_st;
|
default_case->next = if_st;
|
}
|
}
|
|
|
resolve_select (code);
|
resolve_select (code);
|
|
|
}
|
}
|
|
|
|
|
/* Resolve a transfer statement. This is making sure that:
|
/* Resolve a transfer statement. This is making sure that:
|
-- a derived type being transferred has only non-pointer components
|
-- a derived type being transferred has only non-pointer components
|
-- a derived type being transferred doesn't have private components, unless
|
-- a derived type being transferred doesn't have private components, unless
|
it's being transferred from the module where the type was defined
|
it's being transferred from the module where the type was defined
|
-- we're not trying to transfer a whole assumed size array. */
|
-- we're not trying to transfer a whole assumed size array. */
|
|
|
static void
|
static void
|
resolve_transfer (gfc_code *code)
|
resolve_transfer (gfc_code *code)
|
{
|
{
|
gfc_typespec *ts;
|
gfc_typespec *ts;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
gfc_expr *exp;
|
gfc_expr *exp;
|
|
|
exp = code->expr1;
|
exp = code->expr1;
|
|
|
if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
|
if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
|
return;
|
return;
|
|
|
sym = exp->symtree->n.sym;
|
sym = exp->symtree->n.sym;
|
ts = &sym->ts;
|
ts = &sym->ts;
|
|
|
/* Go to actual component transferred. */
|
/* Go to actual component transferred. */
|
for (ref = code->expr1->ref; ref; ref = ref->next)
|
for (ref = code->expr1->ref; ref; ref = ref->next)
|
if (ref->type == REF_COMPONENT)
|
if (ref->type == REF_COMPONENT)
|
ts = &ref->u.c.component->ts;
|
ts = &ref->u.c.component->ts;
|
|
|
if (ts->type == BT_DERIVED)
|
if (ts->type == BT_DERIVED)
|
{
|
{
|
/* Check that transferred derived type doesn't contain POINTER
|
/* Check that transferred derived type doesn't contain POINTER
|
components. */
|
components. */
|
if (ts->u.derived->attr.pointer_comp)
|
if (ts->u.derived->attr.pointer_comp)
|
{
|
{
|
gfc_error ("Data transfer element at %L cannot have "
|
gfc_error ("Data transfer element at %L cannot have "
|
"POINTER components", &code->loc);
|
"POINTER components", &code->loc);
|
return;
|
return;
|
}
|
}
|
|
|
if (ts->u.derived->attr.alloc_comp)
|
if (ts->u.derived->attr.alloc_comp)
|
{
|
{
|
gfc_error ("Data transfer element at %L cannot have "
|
gfc_error ("Data transfer element at %L cannot have "
|
"ALLOCATABLE components", &code->loc);
|
"ALLOCATABLE components", &code->loc);
|
return;
|
return;
|
}
|
}
|
|
|
if (derived_inaccessible (ts->u.derived))
|
if (derived_inaccessible (ts->u.derived))
|
{
|
{
|
gfc_error ("Data transfer element at %L cannot have "
|
gfc_error ("Data transfer element at %L cannot have "
|
"PRIVATE components",&code->loc);
|
"PRIVATE components",&code->loc);
|
return;
|
return;
|
}
|
}
|
}
|
}
|
|
|
if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
|
if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
|
&& exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
|
&& exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
|
{
|
{
|
gfc_error ("Data transfer element at %L cannot be a full reference to "
|
gfc_error ("Data transfer element at %L cannot be a full reference to "
|
"an assumed-size array", &code->loc);
|
"an assumed-size array", &code->loc);
|
return;
|
return;
|
}
|
}
|
}
|
}
|
|
|
|
|
/*********** Toplevel code resolution subroutines ***********/
|
/*********** Toplevel code resolution subroutines ***********/
|
|
|
/* Find the set of labels that are reachable from this block. We also
|
/* Find the set of labels that are reachable from this block. We also
|
record the last statement in each block. */
|
record the last statement in each block. */
|
|
|
static void
|
static void
|
find_reachable_labels (gfc_code *block)
|
find_reachable_labels (gfc_code *block)
|
{
|
{
|
gfc_code *c;
|
gfc_code *c;
|
|
|
if (!block)
|
if (!block)
|
return;
|
return;
|
|
|
cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
|
cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
|
|
|
/* Collect labels in this block. We don't keep those corresponding
|
/* Collect labels in this block. We don't keep those corresponding
|
to END {IF|SELECT}, these are checked in resolve_branch by going
|
to END {IF|SELECT}, these are checked in resolve_branch by going
|
up through the code_stack. */
|
up through the code_stack. */
|
for (c = block; c; c = c->next)
|
for (c = block; c; c = c->next)
|
{
|
{
|
if (c->here && c->op != EXEC_END_BLOCK)
|
if (c->here && c->op != EXEC_END_BLOCK)
|
bitmap_set_bit (cs_base->reachable_labels, c->here->value);
|
bitmap_set_bit (cs_base->reachable_labels, c->here->value);
|
}
|
}
|
|
|
/* Merge with labels from parent block. */
|
/* Merge with labels from parent block. */
|
if (cs_base->prev)
|
if (cs_base->prev)
|
{
|
{
|
gcc_assert (cs_base->prev->reachable_labels);
|
gcc_assert (cs_base->prev->reachable_labels);
|
bitmap_ior_into (cs_base->reachable_labels,
|
bitmap_ior_into (cs_base->reachable_labels,
|
cs_base->prev->reachable_labels);
|
cs_base->prev->reachable_labels);
|
}
|
}
|
}
|
}
|
|
|
/* Given a branch to a label, see if the branch is conforming.
|
/* Given a branch to a label, see if the branch is conforming.
|
The code node describes where the branch is located. */
|
The code node describes where the branch is located. */
|
|
|
static void
|
static void
|
resolve_branch (gfc_st_label *label, gfc_code *code)
|
resolve_branch (gfc_st_label *label, gfc_code *code)
|
{
|
{
|
code_stack *stack;
|
code_stack *stack;
|
|
|
if (label == NULL)
|
if (label == NULL)
|
return;
|
return;
|
|
|
/* Step one: is this a valid branching target? */
|
/* Step one: is this a valid branching target? */
|
|
|
if (label->defined == ST_LABEL_UNKNOWN)
|
if (label->defined == ST_LABEL_UNKNOWN)
|
{
|
{
|
gfc_error ("Label %d referenced at %L is never defined", label->value,
|
gfc_error ("Label %d referenced at %L is never defined", label->value,
|
&label->where);
|
&label->where);
|
return;
|
return;
|
}
|
}
|
|
|
if (label->defined != ST_LABEL_TARGET)
|
if (label->defined != ST_LABEL_TARGET)
|
{
|
{
|
gfc_error ("Statement at %L is not a valid branch target statement "
|
gfc_error ("Statement at %L is not a valid branch target statement "
|
"for the branch statement at %L", &label->where, &code->loc);
|
"for the branch statement at %L", &label->where, &code->loc);
|
return;
|
return;
|
}
|
}
|
|
|
/* Step two: make sure this branch is not a branch to itself ;-) */
|
/* Step two: make sure this branch is not a branch to itself ;-) */
|
|
|
if (code->here == label)
|
if (code->here == label)
|
{
|
{
|
gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
|
gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
|
return;
|
return;
|
}
|
}
|
|
|
/* Step three: See if the label is in the same block as the
|
/* Step three: See if the label is in the same block as the
|
branching statement. The hard work has been done by setting up
|
branching statement. The hard work has been done by setting up
|
the bitmap reachable_labels. */
|
the bitmap reachable_labels. */
|
|
|
if (bitmap_bit_p (cs_base->reachable_labels, label->value))
|
if (bitmap_bit_p (cs_base->reachable_labels, label->value))
|
return;
|
return;
|
|
|
/* Step four: If we haven't found the label in the bitmap, it may
|
/* Step four: If we haven't found the label in the bitmap, it may
|
still be the label of the END of the enclosing block, in which
|
still be the label of the END of the enclosing block, in which
|
case we find it by going up the code_stack. */
|
case we find it by going up the code_stack. */
|
|
|
for (stack = cs_base; stack; stack = stack->prev)
|
for (stack = cs_base; stack; stack = stack->prev)
|
if (stack->current->next && stack->current->next->here == label)
|
if (stack->current->next && stack->current->next->here == label)
|
break;
|
break;
|
|
|
if (stack)
|
if (stack)
|
{
|
{
|
gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
|
gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
|
return;
|
return;
|
}
|
}
|
|
|
/* The label is not in an enclosing block, so illegal. This was
|
/* The label is not in an enclosing block, so illegal. This was
|
allowed in Fortran 66, so we allow it as extension. No
|
allowed in Fortran 66, so we allow it as extension. No
|
further checks are necessary in this case. */
|
further checks are necessary in this case. */
|
gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
|
gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
|
"as the GOTO statement at %L", &label->where,
|
"as the GOTO statement at %L", &label->where,
|
&code->loc);
|
&code->loc);
|
return;
|
return;
|
}
|
}
|
|
|
|
|
/* Check whether EXPR1 has the same shape as EXPR2. */
|
/* Check whether EXPR1 has the same shape as EXPR2. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
|
resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
|
{
|
{
|
mpz_t shape[GFC_MAX_DIMENSIONS];
|
mpz_t shape[GFC_MAX_DIMENSIONS];
|
mpz_t shape2[GFC_MAX_DIMENSIONS];
|
mpz_t shape2[GFC_MAX_DIMENSIONS];
|
gfc_try result = FAILURE;
|
gfc_try result = FAILURE;
|
int i;
|
int i;
|
|
|
/* Compare the rank. */
|
/* Compare the rank. */
|
if (expr1->rank != expr2->rank)
|
if (expr1->rank != expr2->rank)
|
return result;
|
return result;
|
|
|
/* Compare the size of each dimension. */
|
/* Compare the size of each dimension. */
|
for (i=0; i<expr1->rank; i++)
|
for (i=0; i<expr1->rank; i++)
|
{
|
{
|
if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
|
if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
|
goto ignore;
|
goto ignore;
|
|
|
if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
|
if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
|
goto ignore;
|
goto ignore;
|
|
|
if (mpz_cmp (shape[i], shape2[i]))
|
if (mpz_cmp (shape[i], shape2[i]))
|
goto over;
|
goto over;
|
}
|
}
|
|
|
/* When either of the two expression is an assumed size array, we
|
/* When either of the two expression is an assumed size array, we
|
ignore the comparison of dimension sizes. */
|
ignore the comparison of dimension sizes. */
|
ignore:
|
ignore:
|
result = SUCCESS;
|
result = SUCCESS;
|
|
|
over:
|
over:
|
for (i--; i >= 0; i--)
|
for (i--; i >= 0; i--)
|
{
|
{
|
mpz_clear (shape[i]);
|
mpz_clear (shape[i]);
|
mpz_clear (shape2[i]);
|
mpz_clear (shape2[i]);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Check whether a WHERE assignment target or a WHERE mask expression
|
/* Check whether a WHERE assignment target or a WHERE mask expression
|
has the same shape as the outmost WHERE mask expression. */
|
has the same shape as the outmost WHERE mask expression. */
|
|
|
static void
|
static void
|
resolve_where (gfc_code *code, gfc_expr *mask)
|
resolve_where (gfc_code *code, gfc_expr *mask)
|
{
|
{
|
gfc_code *cblock;
|
gfc_code *cblock;
|
gfc_code *cnext;
|
gfc_code *cnext;
|
gfc_expr *e = NULL;
|
gfc_expr *e = NULL;
|
|
|
cblock = code->block;
|
cblock = code->block;
|
|
|
/* Store the first WHERE mask-expr of the WHERE statement or construct.
|
/* Store the first WHERE mask-expr of the WHERE statement or construct.
|
In case of nested WHERE, only the outmost one is stored. */
|
In case of nested WHERE, only the outmost one is stored. */
|
if (mask == NULL) /* outmost WHERE */
|
if (mask == NULL) /* outmost WHERE */
|
e = cblock->expr1;
|
e = cblock->expr1;
|
else /* inner WHERE */
|
else /* inner WHERE */
|
e = mask;
|
e = mask;
|
|
|
while (cblock)
|
while (cblock)
|
{
|
{
|
if (cblock->expr1)
|
if (cblock->expr1)
|
{
|
{
|
/* Check if the mask-expr has a consistent shape with the
|
/* Check if the mask-expr has a consistent shape with the
|
outmost WHERE mask-expr. */
|
outmost WHERE mask-expr. */
|
if (resolve_where_shape (cblock->expr1, e) == FAILURE)
|
if (resolve_where_shape (cblock->expr1, e) == FAILURE)
|
gfc_error ("WHERE mask at %L has inconsistent shape",
|
gfc_error ("WHERE mask at %L has inconsistent shape",
|
&cblock->expr1->where);
|
&cblock->expr1->where);
|
}
|
}
|
|
|
/* the assignment statement of a WHERE statement, or the first
|
/* the assignment statement of a WHERE statement, or the first
|
statement in where-body-construct of a WHERE construct */
|
statement in where-body-construct of a WHERE construct */
|
cnext = cblock->next;
|
cnext = cblock->next;
|
while (cnext)
|
while (cnext)
|
{
|
{
|
switch (cnext->op)
|
switch (cnext->op)
|
{
|
{
|
/* WHERE assignment statement */
|
/* WHERE assignment statement */
|
case EXEC_ASSIGN:
|
case EXEC_ASSIGN:
|
|
|
/* Check shape consistent for WHERE assignment target. */
|
/* Check shape consistent for WHERE assignment target. */
|
if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
|
if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
|
gfc_error ("WHERE assignment target at %L has "
|
gfc_error ("WHERE assignment target at %L has "
|
"inconsistent shape", &cnext->expr1->where);
|
"inconsistent shape", &cnext->expr1->where);
|
break;
|
break;
|
|
|
|
|
case EXEC_ASSIGN_CALL:
|
case EXEC_ASSIGN_CALL:
|
resolve_call (cnext);
|
resolve_call (cnext);
|
if (!cnext->resolved_sym->attr.elemental)
|
if (!cnext->resolved_sym->attr.elemental)
|
gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
|
gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
|
&cnext->ext.actual->expr->where);
|
&cnext->ext.actual->expr->where);
|
break;
|
break;
|
|
|
/* WHERE or WHERE construct is part of a where-body-construct */
|
/* WHERE or WHERE construct is part of a where-body-construct */
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
resolve_where (cnext, e);
|
resolve_where (cnext, e);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_error ("Unsupported statement inside WHERE at %L",
|
gfc_error ("Unsupported statement inside WHERE at %L",
|
&cnext->loc);
|
&cnext->loc);
|
}
|
}
|
/* the next statement within the same where-body-construct */
|
/* the next statement within the same where-body-construct */
|
cnext = cnext->next;
|
cnext = cnext->next;
|
}
|
}
|
/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
|
/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
|
cblock = cblock->block;
|
cblock = cblock->block;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve assignment in FORALL construct.
|
/* Resolve assignment in FORALL construct.
|
NVAR is the number of FORALL index variables, and VAR_EXPR records the
|
NVAR is the number of FORALL index variables, and VAR_EXPR records the
|
FORALL index variables. */
|
FORALL index variables. */
|
|
|
static void
|
static void
|
gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
|
gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
|
{
|
{
|
int n;
|
int n;
|
|
|
for (n = 0; n < nvar; n++)
|
for (n = 0; n < nvar; n++)
|
{
|
{
|
gfc_symbol *forall_index;
|
gfc_symbol *forall_index;
|
|
|
forall_index = var_expr[n]->symtree->n.sym;
|
forall_index = var_expr[n]->symtree->n.sym;
|
|
|
/* Check whether the assignment target is one of the FORALL index
|
/* Check whether the assignment target is one of the FORALL index
|
variable. */
|
variable. */
|
if ((code->expr1->expr_type == EXPR_VARIABLE)
|
if ((code->expr1->expr_type == EXPR_VARIABLE)
|
&& (code->expr1->symtree->n.sym == forall_index))
|
&& (code->expr1->symtree->n.sym == forall_index))
|
gfc_error ("Assignment to a FORALL index variable at %L",
|
gfc_error ("Assignment to a FORALL index variable at %L",
|
&code->expr1->where);
|
&code->expr1->where);
|
else
|
else
|
{
|
{
|
/* If one of the FORALL index variables doesn't appear in the
|
/* If one of the FORALL index variables doesn't appear in the
|
assignment variable, then there could be a many-to-one
|
assignment variable, then there could be a many-to-one
|
assignment. Emit a warning rather than an error because the
|
assignment. Emit a warning rather than an error because the
|
mask could be resolving this problem. */
|
mask could be resolving this problem. */
|
if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
|
if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
|
gfc_warning ("The FORALL with index '%s' is not used on the "
|
gfc_warning ("The FORALL with index '%s' is not used on the "
|
"left side of the assignment at %L and so might "
|
"left side of the assignment at %L and so might "
|
"cause multiple assignment to this object",
|
"cause multiple assignment to this object",
|
var_expr[n]->symtree->name, &code->expr1->where);
|
var_expr[n]->symtree->name, &code->expr1->where);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve WHERE statement in FORALL construct. */
|
/* Resolve WHERE statement in FORALL construct. */
|
|
|
static void
|
static void
|
gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
|
gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
|
gfc_expr **var_expr)
|
gfc_expr **var_expr)
|
{
|
{
|
gfc_code *cblock;
|
gfc_code *cblock;
|
gfc_code *cnext;
|
gfc_code *cnext;
|
|
|
cblock = code->block;
|
cblock = code->block;
|
while (cblock)
|
while (cblock)
|
{
|
{
|
/* the assignment statement of a WHERE statement, or the first
|
/* the assignment statement of a WHERE statement, or the first
|
statement in where-body-construct of a WHERE construct */
|
statement in where-body-construct of a WHERE construct */
|
cnext = cblock->next;
|
cnext = cblock->next;
|
while (cnext)
|
while (cnext)
|
{
|
{
|
switch (cnext->op)
|
switch (cnext->op)
|
{
|
{
|
/* WHERE assignment statement */
|
/* WHERE assignment statement */
|
case EXEC_ASSIGN:
|
case EXEC_ASSIGN:
|
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
|
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
|
break;
|
break;
|
|
|
/* WHERE operator assignment statement */
|
/* WHERE operator assignment statement */
|
case EXEC_ASSIGN_CALL:
|
case EXEC_ASSIGN_CALL:
|
resolve_call (cnext);
|
resolve_call (cnext);
|
if (!cnext->resolved_sym->attr.elemental)
|
if (!cnext->resolved_sym->attr.elemental)
|
gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
|
gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
|
&cnext->ext.actual->expr->where);
|
&cnext->ext.actual->expr->where);
|
break;
|
break;
|
|
|
/* WHERE or WHERE construct is part of a where-body-construct */
|
/* WHERE or WHERE construct is part of a where-body-construct */
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
|
gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_error ("Unsupported statement inside WHERE at %L",
|
gfc_error ("Unsupported statement inside WHERE at %L",
|
&cnext->loc);
|
&cnext->loc);
|
}
|
}
|
/* the next statement within the same where-body-construct */
|
/* the next statement within the same where-body-construct */
|
cnext = cnext->next;
|
cnext = cnext->next;
|
}
|
}
|
/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
|
/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
|
cblock = cblock->block;
|
cblock = cblock->block;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Traverse the FORALL body to check whether the following errors exist:
|
/* Traverse the FORALL body to check whether the following errors exist:
|
1. For assignment, check if a many-to-one assignment happens.
|
1. For assignment, check if a many-to-one assignment happens.
|
2. For WHERE statement, check the WHERE body to see if there is any
|
2. For WHERE statement, check the WHERE body to see if there is any
|
many-to-one assignment. */
|
many-to-one assignment. */
|
|
|
static void
|
static void
|
gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
|
gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
|
{
|
{
|
gfc_code *c;
|
gfc_code *c;
|
|
|
c = code->block->next;
|
c = code->block->next;
|
while (c)
|
while (c)
|
{
|
{
|
switch (c->op)
|
switch (c->op)
|
{
|
{
|
case EXEC_ASSIGN:
|
case EXEC_ASSIGN:
|
case EXEC_POINTER_ASSIGN:
|
case EXEC_POINTER_ASSIGN:
|
gfc_resolve_assign_in_forall (c, nvar, var_expr);
|
gfc_resolve_assign_in_forall (c, nvar, var_expr);
|
break;
|
break;
|
|
|
case EXEC_ASSIGN_CALL:
|
case EXEC_ASSIGN_CALL:
|
resolve_call (c);
|
resolve_call (c);
|
break;
|
break;
|
|
|
/* Because the gfc_resolve_blocks() will handle the nested FORALL,
|
/* Because the gfc_resolve_blocks() will handle the nested FORALL,
|
there is no need to handle it here. */
|
there is no need to handle it here. */
|
case EXEC_FORALL:
|
case EXEC_FORALL:
|
break;
|
break;
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
gfc_resolve_where_code_in_forall(c, nvar, var_expr);
|
gfc_resolve_where_code_in_forall(c, nvar, var_expr);
|
break;
|
break;
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
/* The next statement in the FORALL body. */
|
/* The next statement in the FORALL body. */
|
c = c->next;
|
c = c->next;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Counts the number of iterators needed inside a forall construct, including
|
/* Counts the number of iterators needed inside a forall construct, including
|
nested forall constructs. This is used to allocate the needed memory
|
nested forall constructs. This is used to allocate the needed memory
|
in gfc_resolve_forall. */
|
in gfc_resolve_forall. */
|
|
|
static int
|
static int
|
gfc_count_forall_iterators (gfc_code *code)
|
gfc_count_forall_iterators (gfc_code *code)
|
{
|
{
|
int max_iters, sub_iters, current_iters;
|
int max_iters, sub_iters, current_iters;
|
gfc_forall_iterator *fa;
|
gfc_forall_iterator *fa;
|
|
|
gcc_assert(code->op == EXEC_FORALL);
|
gcc_assert(code->op == EXEC_FORALL);
|
max_iters = 0;
|
max_iters = 0;
|
current_iters = 0;
|
current_iters = 0;
|
|
|
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
|
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
|
current_iters ++;
|
current_iters ++;
|
|
|
code = code->block->next;
|
code = code->block->next;
|
|
|
while (code)
|
while (code)
|
{
|
{
|
if (code->op == EXEC_FORALL)
|
if (code->op == EXEC_FORALL)
|
{
|
{
|
sub_iters = gfc_count_forall_iterators (code);
|
sub_iters = gfc_count_forall_iterators (code);
|
if (sub_iters > max_iters)
|
if (sub_iters > max_iters)
|
max_iters = sub_iters;
|
max_iters = sub_iters;
|
}
|
}
|
code = code->next;
|
code = code->next;
|
}
|
}
|
|
|
return current_iters + max_iters;
|
return current_iters + max_iters;
|
}
|
}
|
|
|
|
|
/* Given a FORALL construct, first resolve the FORALL iterator, then call
|
/* Given a FORALL construct, first resolve the FORALL iterator, then call
|
gfc_resolve_forall_body to resolve the FORALL body. */
|
gfc_resolve_forall_body to resolve the FORALL body. */
|
|
|
static void
|
static void
|
gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
|
gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
|
{
|
{
|
static gfc_expr **var_expr;
|
static gfc_expr **var_expr;
|
static int total_var = 0;
|
static int total_var = 0;
|
static int nvar = 0;
|
static int nvar = 0;
|
int old_nvar, tmp;
|
int old_nvar, tmp;
|
gfc_forall_iterator *fa;
|
gfc_forall_iterator *fa;
|
int i;
|
int i;
|
|
|
old_nvar = nvar;
|
old_nvar = nvar;
|
|
|
/* Start to resolve a FORALL construct */
|
/* Start to resolve a FORALL construct */
|
if (forall_save == 0)
|
if (forall_save == 0)
|
{
|
{
|
/* Count the total number of FORALL index in the nested FORALL
|
/* Count the total number of FORALL index in the nested FORALL
|
construct in order to allocate the VAR_EXPR with proper size. */
|
construct in order to allocate the VAR_EXPR with proper size. */
|
total_var = gfc_count_forall_iterators (code);
|
total_var = gfc_count_forall_iterators (code);
|
|
|
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
|
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
|
var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
|
var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
|
}
|
}
|
|
|
/* The information about FORALL iterator, including FORALL index start, end
|
/* The information about FORALL iterator, including FORALL index start, end
|
and stride. The FORALL index can not appear in start, end or stride. */
|
and stride. The FORALL index can not appear in start, end or stride. */
|
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
|
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
|
{
|
{
|
/* Check if any outer FORALL index name is the same as the current
|
/* Check if any outer FORALL index name is the same as the current
|
one. */
|
one. */
|
for (i = 0; i < nvar; i++)
|
for (i = 0; i < nvar; i++)
|
{
|
{
|
if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
|
if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
|
{
|
{
|
gfc_error ("An outer FORALL construct already has an index "
|
gfc_error ("An outer FORALL construct already has an index "
|
"with this name %L", &fa->var->where);
|
"with this name %L", &fa->var->where);
|
}
|
}
|
}
|
}
|
|
|
/* Record the current FORALL index. */
|
/* Record the current FORALL index. */
|
var_expr[nvar] = gfc_copy_expr (fa->var);
|
var_expr[nvar] = gfc_copy_expr (fa->var);
|
|
|
nvar++;
|
nvar++;
|
|
|
/* No memory leak. */
|
/* No memory leak. */
|
gcc_assert (nvar <= total_var);
|
gcc_assert (nvar <= total_var);
|
}
|
}
|
|
|
/* Resolve the FORALL body. */
|
/* Resolve the FORALL body. */
|
gfc_resolve_forall_body (code, nvar, var_expr);
|
gfc_resolve_forall_body (code, nvar, var_expr);
|
|
|
/* May call gfc_resolve_forall to resolve the inner FORALL loop. */
|
/* May call gfc_resolve_forall to resolve the inner FORALL loop. */
|
gfc_resolve_blocks (code->block, ns);
|
gfc_resolve_blocks (code->block, ns);
|
|
|
tmp = nvar;
|
tmp = nvar;
|
nvar = old_nvar;
|
nvar = old_nvar;
|
/* Free only the VAR_EXPRs allocated in this frame. */
|
/* Free only the VAR_EXPRs allocated in this frame. */
|
for (i = nvar; i < tmp; i++)
|
for (i = nvar; i < tmp; i++)
|
gfc_free_expr (var_expr[i]);
|
gfc_free_expr (var_expr[i]);
|
|
|
if (nvar == 0)
|
if (nvar == 0)
|
{
|
{
|
/* We are in the outermost FORALL construct. */
|
/* We are in the outermost FORALL construct. */
|
gcc_assert (forall_save == 0);
|
gcc_assert (forall_save == 0);
|
|
|
/* VAR_EXPR is not needed any more. */
|
/* VAR_EXPR is not needed any more. */
|
gfc_free (var_expr);
|
gfc_free (var_expr);
|
total_var = 0;
|
total_var = 0;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve a BLOCK construct statement. */
|
/* Resolve a BLOCK construct statement. */
|
|
|
static void
|
static void
|
resolve_block_construct (gfc_code* code)
|
resolve_block_construct (gfc_code* code)
|
{
|
{
|
/* Eventually, we may want to do some checks here or handle special stuff.
|
/* Eventually, we may want to do some checks here or handle special stuff.
|
But so far the only thing we can do is resolving the local namespace. */
|
But so far the only thing we can do is resolving the local namespace. */
|
|
|
gfc_resolve (code->ext.ns);
|
gfc_resolve (code->ext.ns);
|
}
|
}
|
|
|
|
|
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
|
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
|
DO code nodes. */
|
DO code nodes. */
|
|
|
static void resolve_code (gfc_code *, gfc_namespace *);
|
static void resolve_code (gfc_code *, gfc_namespace *);
|
|
|
void
|
void
|
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
|
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
|
|
for (; b; b = b->block)
|
for (; b; b = b->block)
|
{
|
{
|
t = gfc_resolve_expr (b->expr1);
|
t = gfc_resolve_expr (b->expr1);
|
if (gfc_resolve_expr (b->expr2) == FAILURE)
|
if (gfc_resolve_expr (b->expr2) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
|
|
switch (b->op)
|
switch (b->op)
|
{
|
{
|
case EXEC_IF:
|
case EXEC_IF:
|
if (t == SUCCESS && b->expr1 != NULL
|
if (t == SUCCESS && b->expr1 != NULL
|
&& (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
|
&& (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
|
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
|
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
|
&b->expr1->where);
|
&b->expr1->where);
|
break;
|
break;
|
|
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
if (t == SUCCESS
|
if (t == SUCCESS
|
&& b->expr1 != NULL
|
&& b->expr1 != NULL
|
&& (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
|
&& (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
|
gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
|
gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
|
&b->expr1->where);
|
&b->expr1->where);
|
break;
|
break;
|
|
|
case EXEC_GOTO:
|
case EXEC_GOTO:
|
resolve_branch (b->label1, b);
|
resolve_branch (b->label1, b);
|
break;
|
break;
|
|
|
case EXEC_BLOCK:
|
case EXEC_BLOCK:
|
resolve_block_construct (b);
|
resolve_block_construct (b);
|
break;
|
break;
|
|
|
case EXEC_SELECT:
|
case EXEC_SELECT:
|
case EXEC_SELECT_TYPE:
|
case EXEC_SELECT_TYPE:
|
case EXEC_FORALL:
|
case EXEC_FORALL:
|
case EXEC_DO:
|
case EXEC_DO:
|
case EXEC_DO_WHILE:
|
case EXEC_DO_WHILE:
|
case EXEC_READ:
|
case EXEC_READ:
|
case EXEC_WRITE:
|
case EXEC_WRITE:
|
case EXEC_IOLENGTH:
|
case EXEC_IOLENGTH:
|
case EXEC_WAIT:
|
case EXEC_WAIT:
|
break;
|
break;
|
|
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_DO:
|
case EXEC_OMP_DO:
|
case EXEC_OMP_MASTER:
|
case EXEC_OMP_MASTER:
|
case EXEC_OMP_ORDERED:
|
case EXEC_OMP_ORDERED:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_TASK:
|
case EXEC_OMP_TASK:
|
case EXEC_OMP_TASKWAIT:
|
case EXEC_OMP_TASKWAIT:
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_WORKSHARE:
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
|
gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
|
}
|
}
|
|
|
resolve_code (b->next, ns);
|
resolve_code (b->next, ns);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Does everything to resolve an ordinary assignment. Returns true
|
/* Does everything to resolve an ordinary assignment. Returns true
|
if this is an interface assignment. */
|
if this is an interface assignment. */
|
static bool
|
static bool
|
resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
|
resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
|
{
|
{
|
bool rval = false;
|
bool rval = false;
|
gfc_expr *lhs;
|
gfc_expr *lhs;
|
gfc_expr *rhs;
|
gfc_expr *rhs;
|
int llen = 0;
|
int llen = 0;
|
int rlen = 0;
|
int rlen = 0;
|
int n;
|
int n;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
|
|
if (gfc_extend_assign (code, ns) == SUCCESS)
|
if (gfc_extend_assign (code, ns) == SUCCESS)
|
{
|
{
|
gfc_expr** rhsptr;
|
gfc_expr** rhsptr;
|
|
|
if (code->op == EXEC_ASSIGN_CALL)
|
if (code->op == EXEC_ASSIGN_CALL)
|
{
|
{
|
lhs = code->ext.actual->expr;
|
lhs = code->ext.actual->expr;
|
rhsptr = &code->ext.actual->next->expr;
|
rhsptr = &code->ext.actual->next->expr;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_actual_arglist* args;
|
gfc_actual_arglist* args;
|
gfc_typebound_proc* tbp;
|
gfc_typebound_proc* tbp;
|
|
|
gcc_assert (code->op == EXEC_COMPCALL);
|
gcc_assert (code->op == EXEC_COMPCALL);
|
|
|
args = code->expr1->value.compcall.actual;
|
args = code->expr1->value.compcall.actual;
|
lhs = args->expr;
|
lhs = args->expr;
|
rhsptr = &args->next->expr;
|
rhsptr = &args->next->expr;
|
|
|
tbp = code->expr1->value.compcall.tbp;
|
tbp = code->expr1->value.compcall.tbp;
|
gcc_assert (!tbp->is_generic);
|
gcc_assert (!tbp->is_generic);
|
}
|
}
|
|
|
/* Make a temporary rhs when there is a default initializer
|
/* Make a temporary rhs when there is a default initializer
|
and rhs is the same symbol as the lhs. */
|
and rhs is the same symbol as the lhs. */
|
if ((*rhsptr)->expr_type == EXPR_VARIABLE
|
if ((*rhsptr)->expr_type == EXPR_VARIABLE
|
&& (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
|
&& (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
|
&& has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
|
&& has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
|
&& (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
|
&& (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
|
*rhsptr = gfc_get_parentheses (*rhsptr);
|
*rhsptr = gfc_get_parentheses (*rhsptr);
|
|
|
return true;
|
return true;
|
}
|
}
|
|
|
lhs = code->expr1;
|
lhs = code->expr1;
|
rhs = code->expr2;
|
rhs = code->expr2;
|
|
|
if (rhs->is_boz
|
if (rhs->is_boz
|
&& gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
|
&& gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
|
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
|
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
|
&code->loc) == FAILURE)
|
&code->loc) == FAILURE)
|
return false;
|
return false;
|
|
|
/* Handle the case of a BOZ literal on the RHS. */
|
/* Handle the case of a BOZ literal on the RHS. */
|
if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
|
if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
|
{
|
{
|
int rc;
|
int rc;
|
if (gfc_option.warn_surprising)
|
if (gfc_option.warn_surprising)
|
gfc_warning ("BOZ literal at %L is bitwise transferred "
|
gfc_warning ("BOZ literal at %L is bitwise transferred "
|
"non-integer symbol '%s'", &code->loc,
|
"non-integer symbol '%s'", &code->loc,
|
lhs->symtree->n.sym->name);
|
lhs->symtree->n.sym->name);
|
|
|
if (!gfc_convert_boz (rhs, &lhs->ts))
|
if (!gfc_convert_boz (rhs, &lhs->ts))
|
return false;
|
return false;
|
if ((rc = gfc_range_check (rhs)) != ARITH_OK)
|
if ((rc = gfc_range_check (rhs)) != ARITH_OK)
|
{
|
{
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
|
gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
|
". This check can be disabled with the option "
|
". This check can be disabled with the option "
|
"-fno-range-check", &rhs->where);
|
"-fno-range-check", &rhs->where);
|
else if (rc == ARITH_OVERFLOW)
|
else if (rc == ARITH_OVERFLOW)
|
gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
|
gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
|
". This check can be disabled with the option "
|
". This check can be disabled with the option "
|
"-fno-range-check", &rhs->where);
|
"-fno-range-check", &rhs->where);
|
else if (rc == ARITH_NAN)
|
else if (rc == ARITH_NAN)
|
gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
|
gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
|
". This check can be disabled with the option "
|
". This check can be disabled with the option "
|
"-fno-range-check", &rhs->where);
|
"-fno-range-check", &rhs->where);
|
return false;
|
return false;
|
}
|
}
|
}
|
}
|
|
|
|
|
if (lhs->ts.type == BT_CHARACTER
|
if (lhs->ts.type == BT_CHARACTER
|
&& gfc_option.warn_character_truncation)
|
&& gfc_option.warn_character_truncation)
|
{
|
{
|
if (lhs->ts.u.cl != NULL
|
if (lhs->ts.u.cl != NULL
|
&& lhs->ts.u.cl->length != NULL
|
&& lhs->ts.u.cl->length != NULL
|
&& lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
&& lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
|
llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
|
|
|
if (rhs->expr_type == EXPR_CONSTANT)
|
if (rhs->expr_type == EXPR_CONSTANT)
|
rlen = rhs->value.character.length;
|
rlen = rhs->value.character.length;
|
|
|
else if (rhs->ts.u.cl != NULL
|
else if (rhs->ts.u.cl != NULL
|
&& rhs->ts.u.cl->length != NULL
|
&& rhs->ts.u.cl->length != NULL
|
&& rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
&& rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
|
rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
|
|
|
if (rlen && llen && rlen > llen)
|
if (rlen && llen && rlen > llen)
|
gfc_warning_now ("CHARACTER expression will be truncated "
|
gfc_warning_now ("CHARACTER expression will be truncated "
|
"in assignment (%d/%d) at %L",
|
"in assignment (%d/%d) at %L",
|
llen, rlen, &code->loc);
|
llen, rlen, &code->loc);
|
}
|
}
|
|
|
/* Ensure that a vector index expression for the lvalue is evaluated
|
/* Ensure that a vector index expression for the lvalue is evaluated
|
to a temporary if the lvalue symbol is referenced in it. */
|
to a temporary if the lvalue symbol is referenced in it. */
|
if (lhs->rank)
|
if (lhs->rank)
|
{
|
{
|
for (ref = lhs->ref; ref; ref= ref->next)
|
for (ref = lhs->ref; ref; ref= ref->next)
|
if (ref->type == REF_ARRAY)
|
if (ref->type == REF_ARRAY)
|
{
|
{
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
|
if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
|
&& gfc_find_sym_in_expr (lhs->symtree->n.sym,
|
&& gfc_find_sym_in_expr (lhs->symtree->n.sym,
|
ref->u.ar.start[n]))
|
ref->u.ar.start[n]))
|
ref->u.ar.start[n]
|
ref->u.ar.start[n]
|
= gfc_get_parentheses (ref->u.ar.start[n]);
|
= gfc_get_parentheses (ref->u.ar.start[n]);
|
}
|
}
|
}
|
}
|
|
|
if (gfc_pure (NULL))
|
if (gfc_pure (NULL))
|
{
|
{
|
if (gfc_impure_variable (lhs->symtree->n.sym))
|
if (gfc_impure_variable (lhs->symtree->n.sym))
|
{
|
{
|
gfc_error ("Cannot assign to variable '%s' in PURE "
|
gfc_error ("Cannot assign to variable '%s' in PURE "
|
"procedure at %L",
|
"procedure at %L",
|
lhs->symtree->n.sym->name,
|
lhs->symtree->n.sym->name,
|
&lhs->where);
|
&lhs->where);
|
return rval;
|
return rval;
|
}
|
}
|
|
|
if (lhs->ts.type == BT_DERIVED
|
if (lhs->ts.type == BT_DERIVED
|
&& lhs->expr_type == EXPR_VARIABLE
|
&& lhs->expr_type == EXPR_VARIABLE
|
&& lhs->ts.u.derived->attr.pointer_comp
|
&& lhs->ts.u.derived->attr.pointer_comp
|
&& rhs->expr_type == EXPR_VARIABLE
|
&& rhs->expr_type == EXPR_VARIABLE
|
&& gfc_impure_variable (rhs->symtree->n.sym))
|
&& gfc_impure_variable (rhs->symtree->n.sym))
|
{
|
{
|
gfc_error ("The impure variable at %L is assigned to "
|
gfc_error ("The impure variable at %L is assigned to "
|
"a derived type variable with a POINTER "
|
"a derived type variable with a POINTER "
|
"component in a PURE procedure (12.6)",
|
"component in a PURE procedure (12.6)",
|
&rhs->where);
|
&rhs->where);
|
return rval;
|
return rval;
|
}
|
}
|
}
|
}
|
|
|
/* F03:7.4.1.2. */
|
/* F03:7.4.1.2. */
|
if (lhs->ts.type == BT_CLASS)
|
if (lhs->ts.type == BT_CLASS)
|
{
|
{
|
gfc_error ("Variable must not be polymorphic in assignment at %L",
|
gfc_error ("Variable must not be polymorphic in assignment at %L",
|
&lhs->where);
|
&lhs->where);
|
return false;
|
return false;
|
}
|
}
|
|
|
gfc_check_assign (lhs, rhs, 1);
|
gfc_check_assign (lhs, rhs, 1);
|
return false;
|
return false;
|
}
|
}
|
|
|
|
|
/* Given a block of code, recursively resolve everything pointed to by this
|
/* Given a block of code, recursively resolve everything pointed to by this
|
code block. */
|
code block. */
|
|
|
static void
|
static void
|
resolve_code (gfc_code *code, gfc_namespace *ns)
|
resolve_code (gfc_code *code, gfc_namespace *ns)
|
{
|
{
|
int omp_workshare_save;
|
int omp_workshare_save;
|
int forall_save;
|
int forall_save;
|
code_stack frame;
|
code_stack frame;
|
gfc_try t;
|
gfc_try t;
|
|
|
frame.prev = cs_base;
|
frame.prev = cs_base;
|
frame.head = code;
|
frame.head = code;
|
cs_base = &frame;
|
cs_base = &frame;
|
|
|
find_reachable_labels (code);
|
find_reachable_labels (code);
|
|
|
for (; code; code = code->next)
|
for (; code; code = code->next)
|
{
|
{
|
frame.current = code;
|
frame.current = code;
|
forall_save = forall_flag;
|
forall_save = forall_flag;
|
|
|
if (code->op == EXEC_FORALL)
|
if (code->op == EXEC_FORALL)
|
{
|
{
|
forall_flag = 1;
|
forall_flag = 1;
|
gfc_resolve_forall (code, ns, forall_save);
|
gfc_resolve_forall (code, ns, forall_save);
|
forall_flag = 2;
|
forall_flag = 2;
|
}
|
}
|
else if (code->block)
|
else if (code->block)
|
{
|
{
|
omp_workshare_save = -1;
|
omp_workshare_save = -1;
|
switch (code->op)
|
switch (code->op)
|
{
|
{
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
omp_workshare_save = omp_workshare_flag;
|
omp_workshare_save = omp_workshare_flag;
|
omp_workshare_flag = 1;
|
omp_workshare_flag = 1;
|
gfc_resolve_omp_parallel_blocks (code, ns);
|
gfc_resolve_omp_parallel_blocks (code, ns);
|
break;
|
break;
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_TASK:
|
case EXEC_OMP_TASK:
|
omp_workshare_save = omp_workshare_flag;
|
omp_workshare_save = omp_workshare_flag;
|
omp_workshare_flag = 0;
|
omp_workshare_flag = 0;
|
gfc_resolve_omp_parallel_blocks (code, ns);
|
gfc_resolve_omp_parallel_blocks (code, ns);
|
break;
|
break;
|
case EXEC_OMP_DO:
|
case EXEC_OMP_DO:
|
gfc_resolve_omp_do_blocks (code, ns);
|
gfc_resolve_omp_do_blocks (code, ns);
|
break;
|
break;
|
case EXEC_SELECT_TYPE:
|
case EXEC_SELECT_TYPE:
|
gfc_current_ns = code->ext.ns;
|
gfc_current_ns = code->ext.ns;
|
gfc_resolve_blocks (code->block, gfc_current_ns);
|
gfc_resolve_blocks (code->block, gfc_current_ns);
|
gfc_current_ns = ns;
|
gfc_current_ns = ns;
|
break;
|
break;
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_WORKSHARE:
|
omp_workshare_save = omp_workshare_flag;
|
omp_workshare_save = omp_workshare_flag;
|
omp_workshare_flag = 1;
|
omp_workshare_flag = 1;
|
/* FALLTHROUGH */
|
/* FALLTHROUGH */
|
default:
|
default:
|
gfc_resolve_blocks (code->block, ns);
|
gfc_resolve_blocks (code->block, ns);
|
break;
|
break;
|
}
|
}
|
|
|
if (omp_workshare_save != -1)
|
if (omp_workshare_save != -1)
|
omp_workshare_flag = omp_workshare_save;
|
omp_workshare_flag = omp_workshare_save;
|
}
|
}
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
|
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
|
t = gfc_resolve_expr (code->expr1);
|
t = gfc_resolve_expr (code->expr1);
|
forall_flag = forall_save;
|
forall_flag = forall_save;
|
|
|
if (gfc_resolve_expr (code->expr2) == FAILURE)
|
if (gfc_resolve_expr (code->expr2) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
|
|
if (code->op == EXEC_ALLOCATE
|
if (code->op == EXEC_ALLOCATE
|
&& gfc_resolve_expr (code->expr3) == FAILURE)
|
&& gfc_resolve_expr (code->expr3) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
|
|
switch (code->op)
|
switch (code->op)
|
{
|
{
|
case EXEC_NOP:
|
case EXEC_NOP:
|
case EXEC_END_BLOCK:
|
case EXEC_END_BLOCK:
|
case EXEC_CYCLE:
|
case EXEC_CYCLE:
|
case EXEC_PAUSE:
|
case EXEC_PAUSE:
|
case EXEC_STOP:
|
case EXEC_STOP:
|
case EXEC_EXIT:
|
case EXEC_EXIT:
|
case EXEC_CONTINUE:
|
case EXEC_CONTINUE:
|
case EXEC_DT_END:
|
case EXEC_DT_END:
|
case EXEC_ASSIGN_CALL:
|
case EXEC_ASSIGN_CALL:
|
break;
|
break;
|
|
|
case EXEC_ENTRY:
|
case EXEC_ENTRY:
|
/* Keep track of which entry we are up to. */
|
/* Keep track of which entry we are up to. */
|
current_entry_id = code->ext.entry->id;
|
current_entry_id = code->ext.entry->id;
|
break;
|
break;
|
|
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
resolve_where (code, NULL);
|
resolve_where (code, NULL);
|
break;
|
break;
|
|
|
case EXEC_GOTO:
|
case EXEC_GOTO:
|
if (code->expr1 != NULL)
|
if (code->expr1 != NULL)
|
{
|
{
|
if (code->expr1->ts.type != BT_INTEGER)
|
if (code->expr1->ts.type != BT_INTEGER)
|
gfc_error ("ASSIGNED GOTO statement at %L requires an "
|
gfc_error ("ASSIGNED GOTO statement at %L requires an "
|
"INTEGER variable", &code->expr1->where);
|
"INTEGER variable", &code->expr1->where);
|
else if (code->expr1->symtree->n.sym->attr.assign != 1)
|
else if (code->expr1->symtree->n.sym->attr.assign != 1)
|
gfc_error ("Variable '%s' has not been assigned a target "
|
gfc_error ("Variable '%s' has not been assigned a target "
|
"label at %L", code->expr1->symtree->n.sym->name,
|
"label at %L", code->expr1->symtree->n.sym->name,
|
&code->expr1->where);
|
&code->expr1->where);
|
}
|
}
|
else
|
else
|
resolve_branch (code->label1, code);
|
resolve_branch (code->label1, code);
|
break;
|
break;
|
|
|
case EXEC_RETURN:
|
case EXEC_RETURN:
|
if (code->expr1 != NULL
|
if (code->expr1 != NULL
|
&& (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
|
&& (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
|
gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
|
gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
|
"INTEGER return specifier", &code->expr1->where);
|
"INTEGER return specifier", &code->expr1->where);
|
break;
|
break;
|
|
|
case EXEC_INIT_ASSIGN:
|
case EXEC_INIT_ASSIGN:
|
case EXEC_END_PROCEDURE:
|
case EXEC_END_PROCEDURE:
|
break;
|
break;
|
|
|
case EXEC_ASSIGN:
|
case EXEC_ASSIGN:
|
if (t == FAILURE)
|
if (t == FAILURE)
|
break;
|
break;
|
|
|
if (resolve_ordinary_assign (code, ns))
|
if (resolve_ordinary_assign (code, ns))
|
{
|
{
|
if (code->op == EXEC_COMPCALL)
|
if (code->op == EXEC_COMPCALL)
|
goto compcall;
|
goto compcall;
|
else
|
else
|
goto call;
|
goto call;
|
}
|
}
|
break;
|
break;
|
|
|
case EXEC_LABEL_ASSIGN:
|
case EXEC_LABEL_ASSIGN:
|
if (code->label1->defined == ST_LABEL_UNKNOWN)
|
if (code->label1->defined == ST_LABEL_UNKNOWN)
|
gfc_error ("Label %d referenced at %L is never defined",
|
gfc_error ("Label %d referenced at %L is never defined",
|
code->label1->value, &code->label1->where);
|
code->label1->value, &code->label1->where);
|
if (t == SUCCESS
|
if (t == SUCCESS
|
&& (code->expr1->expr_type != EXPR_VARIABLE
|
&& (code->expr1->expr_type != EXPR_VARIABLE
|
|| code->expr1->symtree->n.sym->ts.type != BT_INTEGER
|
|| code->expr1->symtree->n.sym->ts.type != BT_INTEGER
|
|| code->expr1->symtree->n.sym->ts.kind
|
|| code->expr1->symtree->n.sym->ts.kind
|
!= gfc_default_integer_kind
|
!= gfc_default_integer_kind
|
|| code->expr1->symtree->n.sym->as != NULL))
|
|| code->expr1->symtree->n.sym->as != NULL))
|
gfc_error ("ASSIGN statement at %L requires a scalar "
|
gfc_error ("ASSIGN statement at %L requires a scalar "
|
"default INTEGER variable", &code->expr1->where);
|
"default INTEGER variable", &code->expr1->where);
|
break;
|
break;
|
|
|
case EXEC_POINTER_ASSIGN:
|
case EXEC_POINTER_ASSIGN:
|
if (t == FAILURE)
|
if (t == FAILURE)
|
break;
|
break;
|
|
|
gfc_check_pointer_assign (code->expr1, code->expr2);
|
gfc_check_pointer_assign (code->expr1, code->expr2);
|
break;
|
break;
|
|
|
case EXEC_ARITHMETIC_IF:
|
case EXEC_ARITHMETIC_IF:
|
if (t == SUCCESS
|
if (t == SUCCESS
|
&& code->expr1->ts.type != BT_INTEGER
|
&& code->expr1->ts.type != BT_INTEGER
|
&& code->expr1->ts.type != BT_REAL)
|
&& code->expr1->ts.type != BT_REAL)
|
gfc_error ("Arithmetic IF statement at %L requires a numeric "
|
gfc_error ("Arithmetic IF statement at %L requires a numeric "
|
"expression", &code->expr1->where);
|
"expression", &code->expr1->where);
|
|
|
resolve_branch (code->label1, code);
|
resolve_branch (code->label1, code);
|
resolve_branch (code->label2, code);
|
resolve_branch (code->label2, code);
|
resolve_branch (code->label3, code);
|
resolve_branch (code->label3, code);
|
break;
|
break;
|
|
|
case EXEC_IF:
|
case EXEC_IF:
|
if (t == SUCCESS && code->expr1 != NULL
|
if (t == SUCCESS && code->expr1 != NULL
|
&& (code->expr1->ts.type != BT_LOGICAL
|
&& (code->expr1->ts.type != BT_LOGICAL
|
|| code->expr1->rank != 0))
|
|| code->expr1->rank != 0))
|
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
|
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
|
&code->expr1->where);
|
&code->expr1->where);
|
break;
|
break;
|
|
|
case EXEC_CALL:
|
case EXEC_CALL:
|
call:
|
call:
|
resolve_call (code);
|
resolve_call (code);
|
break;
|
break;
|
|
|
case EXEC_COMPCALL:
|
case EXEC_COMPCALL:
|
compcall:
|
compcall:
|
resolve_typebound_subroutine (code);
|
resolve_typebound_subroutine (code);
|
break;
|
break;
|
|
|
case EXEC_CALL_PPC:
|
case EXEC_CALL_PPC:
|
resolve_ppc_call (code);
|
resolve_ppc_call (code);
|
break;
|
break;
|
|
|
case EXEC_SELECT:
|
case EXEC_SELECT:
|
/* Select is complicated. Also, a SELECT construct could be
|
/* Select is complicated. Also, a SELECT construct could be
|
a transformed computed GOTO. */
|
a transformed computed GOTO. */
|
resolve_select (code);
|
resolve_select (code);
|
break;
|
break;
|
|
|
case EXEC_SELECT_TYPE:
|
case EXEC_SELECT_TYPE:
|
resolve_select_type (code);
|
resolve_select_type (code);
|
break;
|
break;
|
|
|
case EXEC_BLOCK:
|
case EXEC_BLOCK:
|
gfc_resolve (code->ext.ns);
|
gfc_resolve (code->ext.ns);
|
break;
|
break;
|
|
|
case EXEC_DO:
|
case EXEC_DO:
|
if (code->ext.iterator != NULL)
|
if (code->ext.iterator != NULL)
|
{
|
{
|
gfc_iterator *iter = code->ext.iterator;
|
gfc_iterator *iter = code->ext.iterator;
|
if (gfc_resolve_iterator (iter, true) != FAILURE)
|
if (gfc_resolve_iterator (iter, true) != FAILURE)
|
gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
|
gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
|
}
|
}
|
break;
|
break;
|
|
|
case EXEC_DO_WHILE:
|
case EXEC_DO_WHILE:
|
if (code->expr1 == NULL)
|
if (code->expr1 == NULL)
|
gfc_internal_error ("resolve_code(): No expression on DO WHILE");
|
gfc_internal_error ("resolve_code(): No expression on DO WHILE");
|
if (t == SUCCESS
|
if (t == SUCCESS
|
&& (code->expr1->rank != 0
|
&& (code->expr1->rank != 0
|
|| code->expr1->ts.type != BT_LOGICAL))
|
|| code->expr1->ts.type != BT_LOGICAL))
|
gfc_error ("Exit condition of DO WHILE loop at %L must be "
|
gfc_error ("Exit condition of DO WHILE loop at %L must be "
|
"a scalar LOGICAL expression", &code->expr1->where);
|
"a scalar LOGICAL expression", &code->expr1->where);
|
break;
|
break;
|
|
|
case EXEC_ALLOCATE:
|
case EXEC_ALLOCATE:
|
if (t == SUCCESS)
|
if (t == SUCCESS)
|
resolve_allocate_deallocate (code, "ALLOCATE");
|
resolve_allocate_deallocate (code, "ALLOCATE");
|
|
|
break;
|
break;
|
|
|
case EXEC_DEALLOCATE:
|
case EXEC_DEALLOCATE:
|
if (t == SUCCESS)
|
if (t == SUCCESS)
|
resolve_allocate_deallocate (code, "DEALLOCATE");
|
resolve_allocate_deallocate (code, "DEALLOCATE");
|
|
|
break;
|
break;
|
|
|
case EXEC_OPEN:
|
case EXEC_OPEN:
|
if (gfc_resolve_open (code->ext.open) == FAILURE)
|
if (gfc_resolve_open (code->ext.open) == FAILURE)
|
break;
|
break;
|
|
|
resolve_branch (code->ext.open->err, code);
|
resolve_branch (code->ext.open->err, code);
|
break;
|
break;
|
|
|
case EXEC_CLOSE:
|
case EXEC_CLOSE:
|
if (gfc_resolve_close (code->ext.close) == FAILURE)
|
if (gfc_resolve_close (code->ext.close) == FAILURE)
|
break;
|
break;
|
|
|
resolve_branch (code->ext.close->err, code);
|
resolve_branch (code->ext.close->err, code);
|
break;
|
break;
|
|
|
case EXEC_BACKSPACE:
|
case EXEC_BACKSPACE:
|
case EXEC_ENDFILE:
|
case EXEC_ENDFILE:
|
case EXEC_REWIND:
|
case EXEC_REWIND:
|
case EXEC_FLUSH:
|
case EXEC_FLUSH:
|
if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
|
if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
|
break;
|
break;
|
|
|
resolve_branch (code->ext.filepos->err, code);
|
resolve_branch (code->ext.filepos->err, code);
|
break;
|
break;
|
|
|
case EXEC_INQUIRE:
|
case EXEC_INQUIRE:
|
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
|
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
|
break;
|
break;
|
|
|
resolve_branch (code->ext.inquire->err, code);
|
resolve_branch (code->ext.inquire->err, code);
|
break;
|
break;
|
|
|
case EXEC_IOLENGTH:
|
case EXEC_IOLENGTH:
|
gcc_assert (code->ext.inquire != NULL);
|
gcc_assert (code->ext.inquire != NULL);
|
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
|
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
|
break;
|
break;
|
|
|
resolve_branch (code->ext.inquire->err, code);
|
resolve_branch (code->ext.inquire->err, code);
|
break;
|
break;
|
|
|
case EXEC_WAIT:
|
case EXEC_WAIT:
|
if (gfc_resolve_wait (code->ext.wait) == FAILURE)
|
if (gfc_resolve_wait (code->ext.wait) == FAILURE)
|
break;
|
break;
|
|
|
resolve_branch (code->ext.wait->err, code);
|
resolve_branch (code->ext.wait->err, code);
|
resolve_branch (code->ext.wait->end, code);
|
resolve_branch (code->ext.wait->end, code);
|
resolve_branch (code->ext.wait->eor, code);
|
resolve_branch (code->ext.wait->eor, code);
|
break;
|
break;
|
|
|
case EXEC_READ:
|
case EXEC_READ:
|
case EXEC_WRITE:
|
case EXEC_WRITE:
|
if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
|
if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
|
break;
|
break;
|
|
|
resolve_branch (code->ext.dt->err, code);
|
resolve_branch (code->ext.dt->err, code);
|
resolve_branch (code->ext.dt->end, code);
|
resolve_branch (code->ext.dt->end, code);
|
resolve_branch (code->ext.dt->eor, code);
|
resolve_branch (code->ext.dt->eor, code);
|
break;
|
break;
|
|
|
case EXEC_TRANSFER:
|
case EXEC_TRANSFER:
|
resolve_transfer (code);
|
resolve_transfer (code);
|
break;
|
break;
|
|
|
case EXEC_FORALL:
|
case EXEC_FORALL:
|
resolve_forall_iterators (code->ext.forall_iterator);
|
resolve_forall_iterators (code->ext.forall_iterator);
|
|
|
if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
|
if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
|
gfc_error ("FORALL mask clause at %L requires a LOGICAL "
|
gfc_error ("FORALL mask clause at %L requires a LOGICAL "
|
"expression", &code->expr1->where);
|
"expression", &code->expr1->where);
|
break;
|
break;
|
|
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_BARRIER:
|
case EXEC_OMP_BARRIER:
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_FLUSH:
|
case EXEC_OMP_FLUSH:
|
case EXEC_OMP_DO:
|
case EXEC_OMP_DO:
|
case EXEC_OMP_MASTER:
|
case EXEC_OMP_MASTER:
|
case EXEC_OMP_ORDERED:
|
case EXEC_OMP_ORDERED:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_TASKWAIT:
|
case EXEC_OMP_TASKWAIT:
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_WORKSHARE:
|
gfc_resolve_omp_directive (code, ns);
|
gfc_resolve_omp_directive (code, ns);
|
break;
|
break;
|
|
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_TASK:
|
case EXEC_OMP_TASK:
|
omp_workshare_save = omp_workshare_flag;
|
omp_workshare_save = omp_workshare_flag;
|
omp_workshare_flag = 0;
|
omp_workshare_flag = 0;
|
gfc_resolve_omp_directive (code, ns);
|
gfc_resolve_omp_directive (code, ns);
|
omp_workshare_flag = omp_workshare_save;
|
omp_workshare_flag = omp_workshare_save;
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("resolve_code(): Bad statement code");
|
gfc_internal_error ("resolve_code(): Bad statement code");
|
}
|
}
|
}
|
}
|
|
|
cs_base = frame.prev;
|
cs_base = frame.prev;
|
}
|
}
|
|
|
|
|
/* Resolve initial values and make sure they are compatible with
|
/* Resolve initial values and make sure they are compatible with
|
the variable. */
|
the variable. */
|
|
|
static void
|
static void
|
resolve_values (gfc_symbol *sym)
|
resolve_values (gfc_symbol *sym)
|
{
|
{
|
if (sym->value == NULL)
|
if (sym->value == NULL)
|
return;
|
return;
|
|
|
if (gfc_resolve_expr (sym->value) == FAILURE)
|
if (gfc_resolve_expr (sym->value) == FAILURE)
|
return;
|
return;
|
|
|
gfc_check_assign_symbol (sym, sym->value);
|
gfc_check_assign_symbol (sym, sym->value);
|
}
|
}
|
|
|
|
|
/* Verify the binding labels for common blocks that are BIND(C). The label
|
/* Verify the binding labels for common blocks that are BIND(C). The label
|
for a BIND(C) common block must be identical in all scoping units in which
|
for a BIND(C) common block must be identical in all scoping units in which
|
the common block is declared. Further, the binding label can not collide
|
the common block is declared. Further, the binding label can not collide
|
with any other global entity in the program. */
|
with any other global entity in the program. */
|
|
|
static void
|
static void
|
resolve_bind_c_comms (gfc_symtree *comm_block_tree)
|
resolve_bind_c_comms (gfc_symtree *comm_block_tree)
|
{
|
{
|
if (comm_block_tree->n.common->is_bind_c == 1)
|
if (comm_block_tree->n.common->is_bind_c == 1)
|
{
|
{
|
gfc_gsymbol *binding_label_gsym;
|
gfc_gsymbol *binding_label_gsym;
|
gfc_gsymbol *comm_name_gsym;
|
gfc_gsymbol *comm_name_gsym;
|
|
|
/* See if a global symbol exists by the common block's name. It may
|
/* See if a global symbol exists by the common block's name. It may
|
be NULL if the common block is use-associated. */
|
be NULL if the common block is use-associated. */
|
comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
|
comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
|
comm_block_tree->n.common->name);
|
comm_block_tree->n.common->name);
|
if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
|
if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
|
gfc_error ("Binding label '%s' for common block '%s' at %L collides "
|
gfc_error ("Binding label '%s' for common block '%s' at %L collides "
|
"with the global entity '%s' at %L",
|
"with the global entity '%s' at %L",
|
comm_block_tree->n.common->binding_label,
|
comm_block_tree->n.common->binding_label,
|
comm_block_tree->n.common->name,
|
comm_block_tree->n.common->name,
|
&(comm_block_tree->n.common->where),
|
&(comm_block_tree->n.common->where),
|
comm_name_gsym->name, &(comm_name_gsym->where));
|
comm_name_gsym->name, &(comm_name_gsym->where));
|
else if (comm_name_gsym != NULL
|
else if (comm_name_gsym != NULL
|
&& strcmp (comm_name_gsym->name,
|
&& strcmp (comm_name_gsym->name,
|
comm_block_tree->n.common->name) == 0)
|
comm_block_tree->n.common->name) == 0)
|
{
|
{
|
/* TODO: Need to make sure the fields of gfc_gsymbol are initialized
|
/* TODO: Need to make sure the fields of gfc_gsymbol are initialized
|
as expected. */
|
as expected. */
|
if (comm_name_gsym->binding_label == NULL)
|
if (comm_name_gsym->binding_label == NULL)
|
/* No binding label for common block stored yet; save this one. */
|
/* No binding label for common block stored yet; save this one. */
|
comm_name_gsym->binding_label =
|
comm_name_gsym->binding_label =
|
comm_block_tree->n.common->binding_label;
|
comm_block_tree->n.common->binding_label;
|
else
|
else
|
if (strcmp (comm_name_gsym->binding_label,
|
if (strcmp (comm_name_gsym->binding_label,
|
comm_block_tree->n.common->binding_label) != 0)
|
comm_block_tree->n.common->binding_label) != 0)
|
{
|
{
|
/* Common block names match but binding labels do not. */
|
/* Common block names match but binding labels do not. */
|
gfc_error ("Binding label '%s' for common block '%s' at %L "
|
gfc_error ("Binding label '%s' for common block '%s' at %L "
|
"does not match the binding label '%s' for common "
|
"does not match the binding label '%s' for common "
|
"block '%s' at %L",
|
"block '%s' at %L",
|
comm_block_tree->n.common->binding_label,
|
comm_block_tree->n.common->binding_label,
|
comm_block_tree->n.common->name,
|
comm_block_tree->n.common->name,
|
&(comm_block_tree->n.common->where),
|
&(comm_block_tree->n.common->where),
|
comm_name_gsym->binding_label,
|
comm_name_gsym->binding_label,
|
comm_name_gsym->name,
|
comm_name_gsym->name,
|
&(comm_name_gsym->where));
|
&(comm_name_gsym->where));
|
return;
|
return;
|
}
|
}
|
}
|
}
|
|
|
/* There is no binding label (NAME="") so we have nothing further to
|
/* There is no binding label (NAME="") so we have nothing further to
|
check and nothing to add as a global symbol for the label. */
|
check and nothing to add as a global symbol for the label. */
|
if (comm_block_tree->n.common->binding_label[0] == '\0' )
|
if (comm_block_tree->n.common->binding_label[0] == '\0' )
|
return;
|
return;
|
|
|
binding_label_gsym =
|
binding_label_gsym =
|
gfc_find_gsymbol (gfc_gsym_root,
|
gfc_find_gsymbol (gfc_gsym_root,
|
comm_block_tree->n.common->binding_label);
|
comm_block_tree->n.common->binding_label);
|
if (binding_label_gsym == NULL)
|
if (binding_label_gsym == NULL)
|
{
|
{
|
/* Need to make a global symbol for the binding label to prevent
|
/* Need to make a global symbol for the binding label to prevent
|
it from colliding with another. */
|
it from colliding with another. */
|
binding_label_gsym =
|
binding_label_gsym =
|
gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
|
gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
|
binding_label_gsym->sym_name = comm_block_tree->n.common->name;
|
binding_label_gsym->sym_name = comm_block_tree->n.common->name;
|
binding_label_gsym->type = GSYM_COMMON;
|
binding_label_gsym->type = GSYM_COMMON;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* If comm_name_gsym is NULL, the name common block is use
|
/* If comm_name_gsym is NULL, the name common block is use
|
associated and the name could be colliding. */
|
associated and the name could be colliding. */
|
if (binding_label_gsym->type != GSYM_COMMON)
|
if (binding_label_gsym->type != GSYM_COMMON)
|
gfc_error ("Binding label '%s' for common block '%s' at %L "
|
gfc_error ("Binding label '%s' for common block '%s' at %L "
|
"collides with the global entity '%s' at %L",
|
"collides with the global entity '%s' at %L",
|
comm_block_tree->n.common->binding_label,
|
comm_block_tree->n.common->binding_label,
|
comm_block_tree->n.common->name,
|
comm_block_tree->n.common->name,
|
&(comm_block_tree->n.common->where),
|
&(comm_block_tree->n.common->where),
|
binding_label_gsym->name,
|
binding_label_gsym->name,
|
&(binding_label_gsym->where));
|
&(binding_label_gsym->where));
|
else if (comm_name_gsym != NULL
|
else if (comm_name_gsym != NULL
|
&& (strcmp (binding_label_gsym->name,
|
&& (strcmp (binding_label_gsym->name,
|
comm_name_gsym->binding_label) != 0)
|
comm_name_gsym->binding_label) != 0)
|
&& (strcmp (binding_label_gsym->sym_name,
|
&& (strcmp (binding_label_gsym->sym_name,
|
comm_name_gsym->name) != 0))
|
comm_name_gsym->name) != 0))
|
gfc_error ("Binding label '%s' for common block '%s' at %L "
|
gfc_error ("Binding label '%s' for common block '%s' at %L "
|
"collides with global entity '%s' at %L",
|
"collides with global entity '%s' at %L",
|
binding_label_gsym->name, binding_label_gsym->sym_name,
|
binding_label_gsym->name, binding_label_gsym->sym_name,
|
&(comm_block_tree->n.common->where),
|
&(comm_block_tree->n.common->where),
|
comm_name_gsym->name, &(comm_name_gsym->where));
|
comm_name_gsym->name, &(comm_name_gsym->where));
|
}
|
}
|
}
|
}
|
|
|
return;
|
return;
|
}
|
}
|
|
|
|
|
/* Verify any BIND(C) derived types in the namespace so we can report errors
|
/* Verify any BIND(C) derived types in the namespace so we can report errors
|
for them once, rather than for each variable declared of that type. */
|
for them once, rather than for each variable declared of that type. */
|
|
|
static void
|
static void
|
resolve_bind_c_derived_types (gfc_symbol *derived_sym)
|
resolve_bind_c_derived_types (gfc_symbol *derived_sym)
|
{
|
{
|
if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
|
if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
|
&& derived_sym->attr.is_bind_c == 1)
|
&& derived_sym->attr.is_bind_c == 1)
|
verify_bind_c_derived_type (derived_sym);
|
verify_bind_c_derived_type (derived_sym);
|
|
|
return;
|
return;
|
}
|
}
|
|
|
|
|
/* Verify that any binding labels used in a given namespace do not collide
|
/* Verify that any binding labels used in a given namespace do not collide
|
with the names or binding labels of any global symbols. */
|
with the names or binding labels of any global symbols. */
|
|
|
static void
|
static void
|
gfc_verify_binding_labels (gfc_symbol *sym)
|
gfc_verify_binding_labels (gfc_symbol *sym)
|
{
|
{
|
int has_error = 0;
|
int has_error = 0;
|
|
|
if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
|
if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
|
&& sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
|
&& sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
|
{
|
{
|
gfc_gsymbol *bind_c_sym;
|
gfc_gsymbol *bind_c_sym;
|
|
|
bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
|
bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
|
if (bind_c_sym != NULL
|
if (bind_c_sym != NULL
|
&& strcmp (bind_c_sym->name, sym->binding_label) == 0)
|
&& strcmp (bind_c_sym->name, sym->binding_label) == 0)
|
{
|
{
|
if (sym->attr.if_source == IFSRC_DECL
|
if (sym->attr.if_source == IFSRC_DECL
|
&& (bind_c_sym->type != GSYM_SUBROUTINE
|
&& (bind_c_sym->type != GSYM_SUBROUTINE
|
&& bind_c_sym->type != GSYM_FUNCTION)
|
&& bind_c_sym->type != GSYM_FUNCTION)
|
&& ((sym->attr.contained == 1
|
&& ((sym->attr.contained == 1
|
&& strcmp (bind_c_sym->sym_name, sym->name) != 0)
|
&& strcmp (bind_c_sym->sym_name, sym->name) != 0)
|
|| (sym->attr.use_assoc == 1
|
|| (sym->attr.use_assoc == 1
|
&& (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
|
&& (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
|
{
|
{
|
/* Make sure global procedures don't collide with anything. */
|
/* Make sure global procedures don't collide with anything. */
|
gfc_error ("Binding label '%s' at %L collides with the global "
|
gfc_error ("Binding label '%s' at %L collides with the global "
|
"entity '%s' at %L", sym->binding_label,
|
"entity '%s' at %L", sym->binding_label,
|
&(sym->declared_at), bind_c_sym->name,
|
&(sym->declared_at), bind_c_sym->name,
|
&(bind_c_sym->where));
|
&(bind_c_sym->where));
|
has_error = 1;
|
has_error = 1;
|
}
|
}
|
else if (sym->attr.contained == 0
|
else if (sym->attr.contained == 0
|
&& (sym->attr.if_source == IFSRC_IFBODY
|
&& (sym->attr.if_source == IFSRC_IFBODY
|
&& sym->attr.flavor == FL_PROCEDURE)
|
&& sym->attr.flavor == FL_PROCEDURE)
|
&& (bind_c_sym->sym_name != NULL
|
&& (bind_c_sym->sym_name != NULL
|
&& strcmp (bind_c_sym->sym_name, sym->name) != 0))
|
&& strcmp (bind_c_sym->sym_name, sym->name) != 0))
|
{
|
{
|
/* Make sure procedures in interface bodies don't collide. */
|
/* Make sure procedures in interface bodies don't collide. */
|
gfc_error ("Binding label '%s' in interface body at %L collides "
|
gfc_error ("Binding label '%s' in interface body at %L collides "
|
"with the global entity '%s' at %L",
|
"with the global entity '%s' at %L",
|
sym->binding_label,
|
sym->binding_label,
|
&(sym->declared_at), bind_c_sym->name,
|
&(sym->declared_at), bind_c_sym->name,
|
&(bind_c_sym->where));
|
&(bind_c_sym->where));
|
has_error = 1;
|
has_error = 1;
|
}
|
}
|
else if (sym->attr.contained == 0
|
else if (sym->attr.contained == 0
|
&& sym->attr.if_source == IFSRC_UNKNOWN)
|
&& sym->attr.if_source == IFSRC_UNKNOWN)
|
if ((sym->attr.use_assoc && bind_c_sym->mod_name
|
if ((sym->attr.use_assoc && bind_c_sym->mod_name
|
&& strcmp (bind_c_sym->mod_name, sym->module) != 0)
|
&& strcmp (bind_c_sym->mod_name, sym->module) != 0)
|
|| sym->attr.use_assoc == 0)
|
|| sym->attr.use_assoc == 0)
|
{
|
{
|
gfc_error ("Binding label '%s' at %L collides with global "
|
gfc_error ("Binding label '%s' at %L collides with global "
|
"entity '%s' at %L", sym->binding_label,
|
"entity '%s' at %L", sym->binding_label,
|
&(sym->declared_at), bind_c_sym->name,
|
&(sym->declared_at), bind_c_sym->name,
|
&(bind_c_sym->where));
|
&(bind_c_sym->where));
|
has_error = 1;
|
has_error = 1;
|
}
|
}
|
|
|
if (has_error != 0)
|
if (has_error != 0)
|
/* Clear the binding label to prevent checking multiple times. */
|
/* Clear the binding label to prevent checking multiple times. */
|
sym->binding_label[0] = '\0';
|
sym->binding_label[0] = '\0';
|
}
|
}
|
else if (bind_c_sym == NULL)
|
else if (bind_c_sym == NULL)
|
{
|
{
|
bind_c_sym = gfc_get_gsymbol (sym->binding_label);
|
bind_c_sym = gfc_get_gsymbol (sym->binding_label);
|
bind_c_sym->where = sym->declared_at;
|
bind_c_sym->where = sym->declared_at;
|
bind_c_sym->sym_name = sym->name;
|
bind_c_sym->sym_name = sym->name;
|
|
|
if (sym->attr.use_assoc == 1)
|
if (sym->attr.use_assoc == 1)
|
bind_c_sym->mod_name = sym->module;
|
bind_c_sym->mod_name = sym->module;
|
else
|
else
|
if (sym->ns->proc_name != NULL)
|
if (sym->ns->proc_name != NULL)
|
bind_c_sym->mod_name = sym->ns->proc_name->name;
|
bind_c_sym->mod_name = sym->ns->proc_name->name;
|
|
|
if (sym->attr.contained == 0)
|
if (sym->attr.contained == 0)
|
{
|
{
|
if (sym->attr.subroutine)
|
if (sym->attr.subroutine)
|
bind_c_sym->type = GSYM_SUBROUTINE;
|
bind_c_sym->type = GSYM_SUBROUTINE;
|
else if (sym->attr.function)
|
else if (sym->attr.function)
|
bind_c_sym->type = GSYM_FUNCTION;
|
bind_c_sym->type = GSYM_FUNCTION;
|
}
|
}
|
}
|
}
|
}
|
}
|
return;
|
return;
|
}
|
}
|
|
|
|
|
/* Resolve an index expression. */
|
/* Resolve an index expression. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_index_expr (gfc_expr *e)
|
resolve_index_expr (gfc_expr *e)
|
{
|
{
|
if (gfc_resolve_expr (e) == FAILURE)
|
if (gfc_resolve_expr (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_simplify_expr (e, 0) == FAILURE)
|
if (gfc_simplify_expr (e, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_specification_expr (e) == FAILURE)
|
if (gfc_specification_expr (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* Resolve a charlen structure. */
|
/* Resolve a charlen structure. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_charlen (gfc_charlen *cl)
|
resolve_charlen (gfc_charlen *cl)
|
{
|
{
|
int i, k;
|
int i, k;
|
|
|
if (cl->resolved)
|
if (cl->resolved)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
cl->resolved = 1;
|
cl->resolved = 1;
|
|
|
specification_expr = 1;
|
specification_expr = 1;
|
|
|
if (resolve_index_expr (cl->length) == FAILURE)
|
if (resolve_index_expr (cl->length) == FAILURE)
|
{
|
{
|
specification_expr = 0;
|
specification_expr = 0;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* "If the character length parameter value evaluates to a negative
|
/* "If the character length parameter value evaluates to a negative
|
value, the length of character entities declared is zero." */
|
value, the length of character entities declared is zero." */
|
if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
|
if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
|
{
|
{
|
if (gfc_option.warn_surprising)
|
if (gfc_option.warn_surprising)
|
gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
|
gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
|
" the length has been set to zero",
|
" the length has been set to zero",
|
&cl->length->where, i);
|
&cl->length->where, i);
|
gfc_replace_expr (cl->length, gfc_int_expr (0));
|
gfc_replace_expr (cl->length, gfc_int_expr (0));
|
}
|
}
|
|
|
/* Check that the character length is not too large. */
|
/* Check that the character length is not too large. */
|
k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
|
k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
|
if (cl->length && cl->length->expr_type == EXPR_CONSTANT
|
if (cl->length && cl->length->expr_type == EXPR_CONSTANT
|
&& cl->length->ts.type == BT_INTEGER
|
&& cl->length->ts.type == BT_INTEGER
|
&& mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
|
&& mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
|
{
|
{
|
gfc_error ("String length at %L is too large", &cl->length->where);
|
gfc_error ("String length at %L is too large", &cl->length->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Test for non-constant shape arrays. */
|
/* Test for non-constant shape arrays. */
|
|
|
static bool
|
static bool
|
is_non_constant_shape_array (gfc_symbol *sym)
|
is_non_constant_shape_array (gfc_symbol *sym)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
int i;
|
int i;
|
bool not_constant;
|
bool not_constant;
|
|
|
not_constant = false;
|
not_constant = false;
|
if (sym->as != NULL)
|
if (sym->as != NULL)
|
{
|
{
|
/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
|
/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
|
has not been simplified; parameter array references. Do the
|
has not been simplified; parameter array references. Do the
|
simplification now. */
|
simplification now. */
|
for (i = 0; i < sym->as->rank; i++)
|
for (i = 0; i < sym->as->rank; i++)
|
{
|
{
|
e = sym->as->lower[i];
|
e = sym->as->lower[i];
|
if (e && (resolve_index_expr (e) == FAILURE
|
if (e && (resolve_index_expr (e) == FAILURE
|
|| !gfc_is_constant_expr (e)))
|
|| !gfc_is_constant_expr (e)))
|
not_constant = true;
|
not_constant = true;
|
|
|
e = sym->as->upper[i];
|
e = sym->as->upper[i];
|
if (e && (resolve_index_expr (e) == FAILURE
|
if (e && (resolve_index_expr (e) == FAILURE
|
|| !gfc_is_constant_expr (e)))
|
|| !gfc_is_constant_expr (e)))
|
not_constant = true;
|
not_constant = true;
|
}
|
}
|
}
|
}
|
return not_constant;
|
return not_constant;
|
}
|
}
|
|
|
/* Given a symbol and an initialization expression, add code to initialize
|
/* Given a symbol and an initialization expression, add code to initialize
|
the symbol to the function entry. */
|
the symbol to the function entry. */
|
static void
|
static void
|
build_init_assign (gfc_symbol *sym, gfc_expr *init)
|
build_init_assign (gfc_symbol *sym, gfc_expr *init)
|
{
|
{
|
gfc_expr *lval;
|
gfc_expr *lval;
|
gfc_code *init_st;
|
gfc_code *init_st;
|
gfc_namespace *ns = sym->ns;
|
gfc_namespace *ns = sym->ns;
|
|
|
/* Search for the function namespace if this is a contained
|
/* Search for the function namespace if this is a contained
|
function without an explicit result. */
|
function without an explicit result. */
|
if (sym->attr.function && sym == sym->result
|
if (sym->attr.function && sym == sym->result
|
&& sym->name != sym->ns->proc_name->name)
|
&& sym->name != sym->ns->proc_name->name)
|
{
|
{
|
ns = ns->contained;
|
ns = ns->contained;
|
for (;ns; ns = ns->sibling)
|
for (;ns; ns = ns->sibling)
|
if (strcmp (ns->proc_name->name, sym->name) == 0)
|
if (strcmp (ns->proc_name->name, sym->name) == 0)
|
break;
|
break;
|
}
|
}
|
|
|
if (ns == NULL)
|
if (ns == NULL)
|
{
|
{
|
gfc_free_expr (init);
|
gfc_free_expr (init);
|
return;
|
return;
|
}
|
}
|
|
|
/* Build an l-value expression for the result. */
|
/* Build an l-value expression for the result. */
|
lval = gfc_lval_expr_from_sym (sym);
|
lval = gfc_lval_expr_from_sym (sym);
|
|
|
/* Add the code at scope entry. */
|
/* Add the code at scope entry. */
|
init_st = gfc_get_code ();
|
init_st = gfc_get_code ();
|
init_st->next = ns->code;
|
init_st->next = ns->code;
|
ns->code = init_st;
|
ns->code = init_st;
|
|
|
/* Assign the default initializer to the l-value. */
|
/* Assign the default initializer to the l-value. */
|
init_st->loc = sym->declared_at;
|
init_st->loc = sym->declared_at;
|
init_st->op = EXEC_INIT_ASSIGN;
|
init_st->op = EXEC_INIT_ASSIGN;
|
init_st->expr1 = lval;
|
init_st->expr1 = lval;
|
init_st->expr2 = init;
|
init_st->expr2 = init;
|
}
|
}
|
|
|
/* Assign the default initializer to a derived type variable or result. */
|
/* Assign the default initializer to a derived type variable or result. */
|
|
|
static void
|
static void
|
apply_default_init (gfc_symbol *sym)
|
apply_default_init (gfc_symbol *sym)
|
{
|
{
|
gfc_expr *init = NULL;
|
gfc_expr *init = NULL;
|
|
|
if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
|
if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
|
return;
|
return;
|
|
|
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
|
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
|
init = gfc_default_initializer (&sym->ts);
|
init = gfc_default_initializer (&sym->ts);
|
|
|
if (init == NULL)
|
if (init == NULL)
|
return;
|
return;
|
|
|
build_init_assign (sym, init);
|
build_init_assign (sym, init);
|
}
|
}
|
|
|
/* Build an initializer for a local integer, real, complex, logical, or
|
/* Build an initializer for a local integer, real, complex, logical, or
|
character variable, based on the command line flags finit-local-zero,
|
character variable, based on the command line flags finit-local-zero,
|
finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
|
finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
|
null if the symbol should not have a default initialization. */
|
null if the symbol should not have a default initialization. */
|
static gfc_expr *
|
static gfc_expr *
|
build_default_init_expr (gfc_symbol *sym)
|
build_default_init_expr (gfc_symbol *sym)
|
{
|
{
|
int char_len;
|
int char_len;
|
gfc_expr *init_expr;
|
gfc_expr *init_expr;
|
int i;
|
int i;
|
|
|
/* These symbols should never have a default initialization. */
|
/* These symbols should never have a default initialization. */
|
if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
|
if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
|
|| sym->attr.external
|
|| sym->attr.external
|
|| sym->attr.dummy
|
|| sym->attr.dummy
|
|| sym->attr.pointer
|
|| sym->attr.pointer
|
|| sym->attr.in_equivalence
|
|| sym->attr.in_equivalence
|
|| sym->attr.in_common
|
|| sym->attr.in_common
|
|| sym->attr.data
|
|| sym->attr.data
|
|| sym->module
|
|| sym->module
|
|| sym->attr.cray_pointee
|
|| sym->attr.cray_pointee
|
|| sym->attr.cray_pointer)
|
|| sym->attr.cray_pointer)
|
return NULL;
|
return NULL;
|
|
|
/* Now we'll try to build an initializer expression. */
|
/* Now we'll try to build an initializer expression. */
|
init_expr = gfc_get_expr ();
|
init_expr = gfc_get_expr ();
|
init_expr->expr_type = EXPR_CONSTANT;
|
init_expr->expr_type = EXPR_CONSTANT;
|
init_expr->ts.type = sym->ts.type;
|
init_expr->ts.type = sym->ts.type;
|
init_expr->ts.kind = sym->ts.kind;
|
init_expr->ts.kind = sym->ts.kind;
|
init_expr->where = sym->declared_at;
|
init_expr->where = sym->declared_at;
|
|
|
/* We will only initialize integers, reals, complex, logicals, and
|
/* We will only initialize integers, reals, complex, logicals, and
|
characters, and only if the corresponding command-line flags
|
characters, and only if the corresponding command-line flags
|
were set. Otherwise, we free init_expr and return null. */
|
were set. Otherwise, we free init_expr and return null. */
|
switch (sym->ts.type)
|
switch (sym->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
|
if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
|
mpz_init_set_si (init_expr->value.integer,
|
mpz_init_set_si (init_expr->value.integer,
|
gfc_option.flag_init_integer_value);
|
gfc_option.flag_init_integer_value);
|
else
|
else
|
{
|
{
|
gfc_free_expr (init_expr);
|
gfc_free_expr (init_expr);
|
init_expr = NULL;
|
init_expr = NULL;
|
}
|
}
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
mpfr_init (init_expr->value.real);
|
mpfr_init (init_expr->value.real);
|
switch (gfc_option.flag_init_real)
|
switch (gfc_option.flag_init_real)
|
{
|
{
|
case GFC_INIT_REAL_SNAN:
|
case GFC_INIT_REAL_SNAN:
|
init_expr->is_snan = 1;
|
init_expr->is_snan = 1;
|
/* Fall through. */
|
/* Fall through. */
|
case GFC_INIT_REAL_NAN:
|
case GFC_INIT_REAL_NAN:
|
mpfr_set_nan (init_expr->value.real);
|
mpfr_set_nan (init_expr->value.real);
|
break;
|
break;
|
|
|
case GFC_INIT_REAL_INF:
|
case GFC_INIT_REAL_INF:
|
mpfr_set_inf (init_expr->value.real, 1);
|
mpfr_set_inf (init_expr->value.real, 1);
|
break;
|
break;
|
|
|
case GFC_INIT_REAL_NEG_INF:
|
case GFC_INIT_REAL_NEG_INF:
|
mpfr_set_inf (init_expr->value.real, -1);
|
mpfr_set_inf (init_expr->value.real, -1);
|
break;
|
break;
|
|
|
case GFC_INIT_REAL_ZERO:
|
case GFC_INIT_REAL_ZERO:
|
mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
|
mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_free_expr (init_expr);
|
gfc_free_expr (init_expr);
|
init_expr = NULL;
|
init_expr = NULL;
|
break;
|
break;
|
}
|
}
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
|
mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
|
switch (gfc_option.flag_init_real)
|
switch (gfc_option.flag_init_real)
|
{
|
{
|
case GFC_INIT_REAL_SNAN:
|
case GFC_INIT_REAL_SNAN:
|
init_expr->is_snan = 1;
|
init_expr->is_snan = 1;
|
/* Fall through. */
|
/* Fall through. */
|
case GFC_INIT_REAL_NAN:
|
case GFC_INIT_REAL_NAN:
|
mpfr_set_nan (mpc_realref (init_expr->value.complex));
|
mpfr_set_nan (mpc_realref (init_expr->value.complex));
|
mpfr_set_nan (mpc_imagref (init_expr->value.complex));
|
mpfr_set_nan (mpc_imagref (init_expr->value.complex));
|
break;
|
break;
|
|
|
case GFC_INIT_REAL_INF:
|
case GFC_INIT_REAL_INF:
|
mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
|
mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
|
mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
|
mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
|
break;
|
break;
|
|
|
case GFC_INIT_REAL_NEG_INF:
|
case GFC_INIT_REAL_NEG_INF:
|
mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
|
mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
|
mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
|
mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
|
break;
|
break;
|
|
|
case GFC_INIT_REAL_ZERO:
|
case GFC_INIT_REAL_ZERO:
|
mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
|
mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_free_expr (init_expr);
|
gfc_free_expr (init_expr);
|
init_expr = NULL;
|
init_expr = NULL;
|
break;
|
break;
|
}
|
}
|
break;
|
break;
|
|
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
|
if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
|
init_expr->value.logical = 0;
|
init_expr->value.logical = 0;
|
else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
|
else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
|
init_expr->value.logical = 1;
|
init_expr->value.logical = 1;
|
else
|
else
|
{
|
{
|
gfc_free_expr (init_expr);
|
gfc_free_expr (init_expr);
|
init_expr = NULL;
|
init_expr = NULL;
|
}
|
}
|
break;
|
break;
|
|
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
/* For characters, the length must be constant in order to
|
/* For characters, the length must be constant in order to
|
create a default initializer. */
|
create a default initializer. */
|
if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
|
if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
|
&& sym->ts.u.cl->length
|
&& sym->ts.u.cl->length
|
&& sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
&& sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
{
|
{
|
char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
|
char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
|
init_expr->value.character.length = char_len;
|
init_expr->value.character.length = char_len;
|
init_expr->value.character.string = gfc_get_wide_string (char_len+1);
|
init_expr->value.character.string = gfc_get_wide_string (char_len+1);
|
for (i = 0; i < char_len; i++)
|
for (i = 0; i < char_len; i++)
|
init_expr->value.character.string[i]
|
init_expr->value.character.string[i]
|
= (unsigned char) gfc_option.flag_init_character_value;
|
= (unsigned char) gfc_option.flag_init_character_value;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_free_expr (init_expr);
|
gfc_free_expr (init_expr);
|
init_expr = NULL;
|
init_expr = NULL;
|
}
|
}
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_free_expr (init_expr);
|
gfc_free_expr (init_expr);
|
init_expr = NULL;
|
init_expr = NULL;
|
}
|
}
|
return init_expr;
|
return init_expr;
|
}
|
}
|
|
|
/* Add an initialization expression to a local variable. */
|
/* Add an initialization expression to a local variable. */
|
static void
|
static void
|
apply_default_init_local (gfc_symbol *sym)
|
apply_default_init_local (gfc_symbol *sym)
|
{
|
{
|
gfc_expr *init = NULL;
|
gfc_expr *init = NULL;
|
|
|
/* The symbol should be a variable or a function return value. */
|
/* The symbol should be a variable or a function return value. */
|
if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
|
if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
|
|| (sym->attr.function && sym->result != sym))
|
|| (sym->attr.function && sym->result != sym))
|
return;
|
return;
|
|
|
/* Try to build the initializer expression. If we can't initialize
|
/* Try to build the initializer expression. If we can't initialize
|
this symbol, then init will be NULL. */
|
this symbol, then init will be NULL. */
|
init = build_default_init_expr (sym);
|
init = build_default_init_expr (sym);
|
if (init == NULL)
|
if (init == NULL)
|
return;
|
return;
|
|
|
/* For saved variables, we don't want to add an initializer at
|
/* For saved variables, we don't want to add an initializer at
|
function entry, so we just add a static initializer. */
|
function entry, so we just add a static initializer. */
|
if (sym->attr.save || sym->ns->save_all
|
if (sym->attr.save || sym->ns->save_all
|
|| gfc_option.flag_max_stack_var_size == 0)
|
|| gfc_option.flag_max_stack_var_size == 0)
|
{
|
{
|
/* Don't clobber an existing initializer! */
|
/* Don't clobber an existing initializer! */
|
gcc_assert (sym->value == NULL);
|
gcc_assert (sym->value == NULL);
|
sym->value = init;
|
sym->value = init;
|
return;
|
return;
|
}
|
}
|
|
|
build_init_assign (sym, init);
|
build_init_assign (sym, init);
|
}
|
}
|
|
|
/* Resolution of common features of flavors variable and procedure. */
|
/* Resolution of common features of flavors variable and procedure. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
|
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
|
{
|
{
|
/* Constraints on deferred shape variable. */
|
/* Constraints on deferred shape variable. */
|
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
|
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
|
{
|
{
|
if (sym->attr.allocatable)
|
if (sym->attr.allocatable)
|
{
|
{
|
if (sym->attr.dimension)
|
if (sym->attr.dimension)
|
{
|
{
|
gfc_error ("Allocatable array '%s' at %L must have "
|
gfc_error ("Allocatable array '%s' at %L must have "
|
"a deferred shape", sym->name, &sym->declared_at);
|
"a deferred shape", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
|
else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
|
"may not be ALLOCATABLE", sym->name,
|
"may not be ALLOCATABLE", sym->name,
|
&sym->declared_at) == FAILURE)
|
&sym->declared_at) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (sym->attr.pointer && sym->attr.dimension)
|
if (sym->attr.pointer && sym->attr.dimension)
|
{
|
{
|
gfc_error ("Array pointer '%s' at %L must have a deferred shape",
|
gfc_error ("Array pointer '%s' at %L must have a deferred shape",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
}
|
}
|
else
|
else
|
{
|
{
|
if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
|
if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
|
&& !sym->attr.dummy && sym->ts.type != BT_CLASS)
|
&& !sym->attr.dummy && sym->ts.type != BT_CLASS)
|
{
|
{
|
gfc_error ("Array '%s' at %L cannot have a deferred shape",
|
gfc_error ("Array '%s' at %L cannot have a deferred shape",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Additional checks for symbols with flavor variable and derived
|
/* Additional checks for symbols with flavor variable and derived
|
type. To be called from resolve_fl_variable. */
|
type. To be called from resolve_fl_variable. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
|
resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
|
{
|
{
|
gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
|
gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
|
|
|
/* Check to see if a derived type is blocked from being host
|
/* Check to see if a derived type is blocked from being host
|
associated by the presence of another class I symbol in the same
|
associated by the presence of another class I symbol in the same
|
namespace. 14.6.1.3 of the standard and the discussion on
|
namespace. 14.6.1.3 of the standard and the discussion on
|
comp.lang.fortran. */
|
comp.lang.fortran. */
|
if (sym->ns != sym->ts.u.derived->ns
|
if (sym->ns != sym->ts.u.derived->ns
|
&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
|
&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
|
{
|
{
|
gfc_symbol *s;
|
gfc_symbol *s;
|
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
|
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
|
if (s && s->attr.flavor != FL_DERIVED)
|
if (s && s->attr.flavor != FL_DERIVED)
|
{
|
{
|
gfc_error ("The type '%s' cannot be host associated at %L "
|
gfc_error ("The type '%s' cannot be host associated at %L "
|
"because it is blocked by an incompatible object "
|
"because it is blocked by an incompatible object "
|
"of the same name declared at %L",
|
"of the same name declared at %L",
|
sym->ts.u.derived->name, &sym->declared_at,
|
sym->ts.u.derived->name, &sym->declared_at,
|
&s->declared_at);
|
&s->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* 4th constraint in section 11.3: "If an object of a type for which
|
/* 4th constraint in section 11.3: "If an object of a type for which
|
component-initialization is specified (R429) appears in the
|
component-initialization is specified (R429) appears in the
|
specification-part of a module and does not have the ALLOCATABLE
|
specification-part of a module and does not have the ALLOCATABLE
|
or POINTER attribute, the object shall have the SAVE attribute."
|
or POINTER attribute, the object shall have the SAVE attribute."
|
|
|
The check for initializers is performed with
|
The check for initializers is performed with
|
has_default_initializer because gfc_default_initializer generates
|
has_default_initializer because gfc_default_initializer generates
|
a hidden default for allocatable components. */
|
a hidden default for allocatable components. */
|
if (!(sym->value || no_init_flag) && sym->ns->proc_name
|
if (!(sym->value || no_init_flag) && sym->ns->proc_name
|
&& sym->ns->proc_name->attr.flavor == FL_MODULE
|
&& sym->ns->proc_name->attr.flavor == FL_MODULE
|
&& !sym->ns->save_all && !sym->attr.save
|
&& !sym->ns->save_all && !sym->attr.save
|
&& !sym->attr.pointer && !sym->attr.allocatable
|
&& !sym->attr.pointer && !sym->attr.allocatable
|
&& has_default_initializer (sym->ts.u.derived)
|
&& has_default_initializer (sym->ts.u.derived)
|
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
|
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
|
"module variable '%s' at %L, needed due to "
|
"module variable '%s' at %L, needed due to "
|
"the default initialization", sym->name,
|
"the default initialization", sym->name,
|
&sym->declared_at) == FAILURE)
|
&sym->declared_at) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (sym->ts.type == BT_CLASS)
|
if (sym->ts.type == BT_CLASS)
|
{
|
{
|
/* C502. */
|
/* C502. */
|
if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
|
if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
|
{
|
{
|
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
|
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
|
sym->ts.u.derived->components->ts.u.derived->name,
|
sym->ts.u.derived->components->ts.u.derived->name,
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* C509. */
|
/* C509. */
|
/* Assume that use associated symbols were checked in the module ns. */
|
/* Assume that use associated symbols were checked in the module ns. */
|
if (!sym->attr.class_ok && !sym->attr.use_assoc)
|
if (!sym->attr.class_ok && !sym->attr.use_assoc)
|
{
|
{
|
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
|
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
|
"or pointer", sym->name, &sym->declared_at);
|
"or pointer", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Assign default initializer. */
|
/* Assign default initializer. */
|
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
|
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
|
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
|
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
|
{
|
{
|
sym->value = gfc_default_initializer (&sym->ts);
|
sym->value = gfc_default_initializer (&sym->ts);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve symbols with flavor variable. */
|
/* Resolve symbols with flavor variable. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
|
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
|
{
|
{
|
int no_init_flag, automatic_flag;
|
int no_init_flag, automatic_flag;
|
gfc_expr *e;
|
gfc_expr *e;
|
const char *auto_save_msg;
|
const char *auto_save_msg;
|
|
|
auto_save_msg = "Automatic object '%s' at %L cannot have the "
|
auto_save_msg = "Automatic object '%s' at %L cannot have the "
|
"SAVE attribute";
|
"SAVE attribute";
|
|
|
if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
|
if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Set this flag to check that variables are parameters of all entries.
|
/* Set this flag to check that variables are parameters of all entries.
|
This check is effected by the call to gfc_resolve_expr through
|
This check is effected by the call to gfc_resolve_expr through
|
is_non_constant_shape_array. */
|
is_non_constant_shape_array. */
|
specification_expr = 1;
|
specification_expr = 1;
|
|
|
if (sym->ns->proc_name
|
if (sym->ns->proc_name
|
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|
|| sym->ns->proc_name->attr.is_main_program)
|
|| sym->ns->proc_name->attr.is_main_program)
|
&& !sym->attr.use_assoc
|
&& !sym->attr.use_assoc
|
&& !sym->attr.allocatable
|
&& !sym->attr.allocatable
|
&& !sym->attr.pointer
|
&& !sym->attr.pointer
|
&& is_non_constant_shape_array (sym))
|
&& is_non_constant_shape_array (sym))
|
{
|
{
|
/* The shape of a main program or module array needs to be
|
/* The shape of a main program or module array needs to be
|
constant. */
|
constant. */
|
gfc_error ("The module or main program array '%s' at %L must "
|
gfc_error ("The module or main program array '%s' at %L must "
|
"have constant shape", sym->name, &sym->declared_at);
|
"have constant shape", sym->name, &sym->declared_at);
|
specification_expr = 0;
|
specification_expr = 0;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (sym->ts.type == BT_CHARACTER)
|
if (sym->ts.type == BT_CHARACTER)
|
{
|
{
|
/* Make sure that character string variables with assumed length are
|
/* Make sure that character string variables with assumed length are
|
dummy arguments. */
|
dummy arguments. */
|
e = sym->ts.u.cl->length;
|
e = sym->ts.u.cl->length;
|
if (e == NULL && !sym->attr.dummy && !sym->attr.result)
|
if (e == NULL && !sym->attr.dummy && !sym->attr.result)
|
{
|
{
|
gfc_error ("Entity with assumed character length at %L must be a "
|
gfc_error ("Entity with assumed character length at %L must be a "
|
"dummy argument or a PARAMETER", &sym->declared_at);
|
"dummy argument or a PARAMETER", &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (e && sym->attr.save && !gfc_is_constant_expr (e))
|
if (e && sym->attr.save && !gfc_is_constant_expr (e))
|
{
|
{
|
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
|
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!gfc_is_constant_expr (e)
|
if (!gfc_is_constant_expr (e)
|
&& !(e->expr_type == EXPR_VARIABLE
|
&& !(e->expr_type == EXPR_VARIABLE
|
&& e->symtree->n.sym->attr.flavor == FL_PARAMETER)
|
&& e->symtree->n.sym->attr.flavor == FL_PARAMETER)
|
&& sym->ns->proc_name
|
&& sym->ns->proc_name
|
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|
|| sym->ns->proc_name->attr.is_main_program)
|
|| sym->ns->proc_name->attr.is_main_program)
|
&& !sym->attr.use_assoc)
|
&& !sym->attr.use_assoc)
|
{
|
{
|
gfc_error ("'%s' at %L must have constant character length "
|
gfc_error ("'%s' at %L must have constant character length "
|
"in this context", sym->name, &sym->declared_at);
|
"in this context", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
if (sym->value == NULL && sym->attr.referenced)
|
if (sym->value == NULL && sym->attr.referenced)
|
apply_default_init_local (sym); /* Try to apply a default initialization. */
|
apply_default_init_local (sym); /* Try to apply a default initialization. */
|
|
|
/* Determine if the symbol may not have an initializer. */
|
/* Determine if the symbol may not have an initializer. */
|
no_init_flag = automatic_flag = 0;
|
no_init_flag = automatic_flag = 0;
|
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|
|| sym->attr.intrinsic || sym->attr.result)
|
|| sym->attr.intrinsic || sym->attr.result)
|
no_init_flag = 1;
|
no_init_flag = 1;
|
else if (sym->attr.dimension && !sym->attr.pointer
|
else if (sym->attr.dimension && !sym->attr.pointer
|
&& is_non_constant_shape_array (sym))
|
&& is_non_constant_shape_array (sym))
|
{
|
{
|
no_init_flag = automatic_flag = 1;
|
no_init_flag = automatic_flag = 1;
|
|
|
/* Also, they must not have the SAVE attribute.
|
/* Also, they must not have the SAVE attribute.
|
SAVE_IMPLICIT is checked below. */
|
SAVE_IMPLICIT is checked below. */
|
if (sym->attr.save == SAVE_EXPLICIT)
|
if (sym->attr.save == SAVE_EXPLICIT)
|
{
|
{
|
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
|
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Ensure that any initializer is simplified. */
|
/* Ensure that any initializer is simplified. */
|
if (sym->value)
|
if (sym->value)
|
gfc_simplify_expr (sym->value, 1);
|
gfc_simplify_expr (sym->value, 1);
|
|
|
/* Reject illegal initializers. */
|
/* Reject illegal initializers. */
|
if (!sym->mark && sym->value)
|
if (!sym->mark && sym->value)
|
{
|
{
|
if (sym->attr.allocatable)
|
if (sym->attr.allocatable)
|
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
|
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
else if (sym->attr.external)
|
else if (sym->attr.external)
|
gfc_error ("External '%s' at %L cannot have an initializer",
|
gfc_error ("External '%s' at %L cannot have an initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
else if (sym->attr.dummy
|
else if (sym->attr.dummy
|
&& !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
|
&& !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
|
gfc_error ("Dummy '%s' at %L cannot have an initializer",
|
gfc_error ("Dummy '%s' at %L cannot have an initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
else if (sym->attr.intrinsic)
|
else if (sym->attr.intrinsic)
|
gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
|
gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
else if (sym->attr.result)
|
else if (sym->attr.result)
|
gfc_error ("Function result '%s' at %L cannot have an initializer",
|
gfc_error ("Function result '%s' at %L cannot have an initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
else if (automatic_flag)
|
else if (automatic_flag)
|
gfc_error ("Automatic array '%s' at %L cannot have an initializer",
|
gfc_error ("Automatic array '%s' at %L cannot have an initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
else
|
else
|
goto no_init_error;
|
goto no_init_error;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
no_init_error:
|
no_init_error:
|
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
|
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
|
return resolve_fl_variable_derived (sym, no_init_flag);
|
return resolve_fl_variable_derived (sym, no_init_flag);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a procedure. */
|
/* Resolve a procedure. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
|
resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
|
{
|
{
|
gfc_formal_arglist *arg;
|
gfc_formal_arglist *arg;
|
|
|
if (sym->attr.function
|
if (sym->attr.function
|
&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
|
&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (sym->ts.type == BT_CHARACTER)
|
if (sym->ts.type == BT_CHARACTER)
|
{
|
{
|
gfc_charlen *cl = sym->ts.u.cl;
|
gfc_charlen *cl = sym->ts.u.cl;
|
|
|
if (cl && cl->length && gfc_is_constant_expr (cl->length)
|
if (cl && cl->length && gfc_is_constant_expr (cl->length)
|
&& resolve_charlen (cl) == FAILURE)
|
&& resolve_charlen (cl) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
|
if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
|
&& sym->attr.proc == PROC_ST_FUNCTION)
|
&& sym->attr.proc == PROC_ST_FUNCTION)
|
{
|
{
|
gfc_error ("Character-valued statement function '%s' at %L must "
|
gfc_error ("Character-valued statement function '%s' at %L must "
|
"have constant length", sym->name, &sym->declared_at);
|
"have constant length", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* Ensure that derived type for are not of a private type. Internal
|
/* Ensure that derived type for are not of a private type. Internal
|
module procedures are excluded by 2.2.3.3 - i.e., they are not
|
module procedures are excluded by 2.2.3.3 - i.e., they are not
|
externally accessible and can access all the objects accessible in
|
externally accessible and can access all the objects accessible in
|
the host. */
|
the host. */
|
if (!(sym->ns->parent
|
if (!(sym->ns->parent
|
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
|
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
|
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
|
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
|
{
|
{
|
gfc_interface *iface;
|
gfc_interface *iface;
|
|
|
for (arg = sym->formal; arg; arg = arg->next)
|
for (arg = sym->formal; arg; arg = arg->next)
|
{
|
{
|
if (arg->sym
|
if (arg->sym
|
&& arg->sym->ts.type == BT_DERIVED
|
&& arg->sym->ts.type == BT_DERIVED
|
&& !arg->sym->ts.u.derived->attr.use_assoc
|
&& !arg->sym->ts.u.derived->attr.use_assoc
|
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
arg->sym->ts.u.derived->ns->default_access)
|
arg->sym->ts.u.derived->ns->default_access)
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
|
"PRIVATE type and cannot be a dummy argument"
|
"PRIVATE type and cannot be a dummy argument"
|
" of '%s', which is PUBLIC at %L",
|
" of '%s', which is PUBLIC at %L",
|
arg->sym->name, sym->name, &sym->declared_at)
|
arg->sym->name, sym->name, &sym->declared_at)
|
== FAILURE)
|
== FAILURE)
|
{
|
{
|
/* Stop this message from recurring. */
|
/* Stop this message from recurring. */
|
arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
|
arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* PUBLIC interfaces may expose PRIVATE procedures that take types
|
/* PUBLIC interfaces may expose PRIVATE procedures that take types
|
PRIVATE to the containing module. */
|
PRIVATE to the containing module. */
|
for (iface = sym->generic; iface; iface = iface->next)
|
for (iface = sym->generic; iface; iface = iface->next)
|
{
|
{
|
for (arg = iface->sym->formal; arg; arg = arg->next)
|
for (arg = iface->sym->formal; arg; arg = arg->next)
|
{
|
{
|
if (arg->sym
|
if (arg->sym
|
&& arg->sym->ts.type == BT_DERIVED
|
&& arg->sym->ts.type == BT_DERIVED
|
&& !arg->sym->ts.u.derived->attr.use_assoc
|
&& !arg->sym->ts.u.derived->attr.use_assoc
|
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
arg->sym->ts.u.derived->ns->default_access)
|
arg->sym->ts.u.derived->ns->default_access)
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
|
"'%s' in PUBLIC interface '%s' at %L "
|
"'%s' in PUBLIC interface '%s' at %L "
|
"takes dummy arguments of '%s' which is "
|
"takes dummy arguments of '%s' which is "
|
"PRIVATE", iface->sym->name, sym->name,
|
"PRIVATE", iface->sym->name, sym->name,
|
&iface->sym->declared_at,
|
&iface->sym->declared_at,
|
gfc_typename (&arg->sym->ts)) == FAILURE)
|
gfc_typename (&arg->sym->ts)) == FAILURE)
|
{
|
{
|
/* Stop this message from recurring. */
|
/* Stop this message from recurring. */
|
arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
|
arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* PUBLIC interfaces may expose PRIVATE procedures that take types
|
/* PUBLIC interfaces may expose PRIVATE procedures that take types
|
PRIVATE to the containing module. */
|
PRIVATE to the containing module. */
|
for (iface = sym->generic; iface; iface = iface->next)
|
for (iface = sym->generic; iface; iface = iface->next)
|
{
|
{
|
for (arg = iface->sym->formal; arg; arg = arg->next)
|
for (arg = iface->sym->formal; arg; arg = arg->next)
|
{
|
{
|
if (arg->sym
|
if (arg->sym
|
&& arg->sym->ts.type == BT_DERIVED
|
&& arg->sym->ts.type == BT_DERIVED
|
&& !arg->sym->ts.u.derived->attr.use_assoc
|
&& !arg->sym->ts.u.derived->attr.use_assoc
|
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
arg->sym->ts.u.derived->ns->default_access)
|
arg->sym->ts.u.derived->ns->default_access)
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
|
"'%s' in PUBLIC interface '%s' at %L "
|
"'%s' in PUBLIC interface '%s' at %L "
|
"takes dummy arguments of '%s' which is "
|
"takes dummy arguments of '%s' which is "
|
"PRIVATE", iface->sym->name, sym->name,
|
"PRIVATE", iface->sym->name, sym->name,
|
&iface->sym->declared_at,
|
&iface->sym->declared_at,
|
gfc_typename (&arg->sym->ts)) == FAILURE)
|
gfc_typename (&arg->sym->ts)) == FAILURE)
|
{
|
{
|
/* Stop this message from recurring. */
|
/* Stop this message from recurring. */
|
arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
|
arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
|
if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
|
&& !sym->attr.proc_pointer)
|
&& !sym->attr.proc_pointer)
|
{
|
{
|
gfc_error ("Function '%s' at %L cannot have an initializer",
|
gfc_error ("Function '%s' at %L cannot have an initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* An external symbol may not have an initializer because it is taken to be
|
/* An external symbol may not have an initializer because it is taken to be
|
a procedure. Exception: Procedure Pointers. */
|
a procedure. Exception: Procedure Pointers. */
|
if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
|
if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
|
{
|
{
|
gfc_error ("External object '%s' at %L may not have an initializer",
|
gfc_error ("External object '%s' at %L may not have an initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* An elemental function is required to return a scalar 12.7.1 */
|
/* An elemental function is required to return a scalar 12.7.1 */
|
if (sym->attr.elemental && sym->attr.function && sym->as)
|
if (sym->attr.elemental && sym->attr.function && sym->as)
|
{
|
{
|
gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
|
gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
|
"result", sym->name, &sym->declared_at);
|
"result", sym->name, &sym->declared_at);
|
/* Reset so that the error only occurs once. */
|
/* Reset so that the error only occurs once. */
|
sym->attr.elemental = 0;
|
sym->attr.elemental = 0;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* 5.1.1.5 of the Standard: A function name declared with an asterisk
|
/* 5.1.1.5 of the Standard: A function name declared with an asterisk
|
char-len-param shall not be array-valued, pointer-valued, recursive
|
char-len-param shall not be array-valued, pointer-valued, recursive
|
or pure. ....snip... A character value of * may only be used in the
|
or pure. ....snip... A character value of * may only be used in the
|
following ways: (i) Dummy arg of procedure - dummy associates with
|
following ways: (i) Dummy arg of procedure - dummy associates with
|
actual length; (ii) To declare a named constant; or (iii) External
|
actual length; (ii) To declare a named constant; or (iii) External
|
function - but length must be declared in calling scoping unit. */
|
function - but length must be declared in calling scoping unit. */
|
if (sym->attr.function
|
if (sym->attr.function
|
&& sym->ts.type == BT_CHARACTER
|
&& sym->ts.type == BT_CHARACTER
|
&& sym->ts.u.cl && sym->ts.u.cl->length == NULL)
|
&& sym->ts.u.cl && sym->ts.u.cl->length == NULL)
|
{
|
{
|
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
|
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
|
|| (sym->attr.recursive) || (sym->attr.pure))
|
|| (sym->attr.recursive) || (sym->attr.pure))
|
{
|
{
|
if (sym->as && sym->as->rank)
|
if (sym->as && sym->as->rank)
|
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
|
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
|
"array-valued", sym->name, &sym->declared_at);
|
"array-valued", sym->name, &sym->declared_at);
|
|
|
if (sym->attr.pointer)
|
if (sym->attr.pointer)
|
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
|
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
|
"pointer-valued", sym->name, &sym->declared_at);
|
"pointer-valued", sym->name, &sym->declared_at);
|
|
|
if (sym->attr.pure)
|
if (sym->attr.pure)
|
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
|
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
|
"pure", sym->name, &sym->declared_at);
|
"pure", sym->name, &sym->declared_at);
|
|
|
if (sym->attr.recursive)
|
if (sym->attr.recursive)
|
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
|
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
|
"recursive", sym->name, &sym->declared_at);
|
"recursive", sym->name, &sym->declared_at);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Appendix B.2 of the standard. Contained functions give an
|
/* Appendix B.2 of the standard. Contained functions give an
|
error anyway. Fixed-form is likely to be F77/legacy. */
|
error anyway. Fixed-form is likely to be F77/legacy. */
|
if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
|
if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
|
gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
|
gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
|
"CHARACTER(*) function '%s' at %L",
|
"CHARACTER(*) function '%s' at %L",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
}
|
}
|
|
|
if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
|
if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
|
{
|
{
|
gfc_formal_arglist *curr_arg;
|
gfc_formal_arglist *curr_arg;
|
int has_non_interop_arg = 0;
|
int has_non_interop_arg = 0;
|
|
|
if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
|
if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
|
sym->common_block) == FAILURE)
|
sym->common_block) == FAILURE)
|
{
|
{
|
/* Clear these to prevent looking at them again if there was an
|
/* Clear these to prevent looking at them again if there was an
|
error. */
|
error. */
|
sym->attr.is_bind_c = 0;
|
sym->attr.is_bind_c = 0;
|
sym->attr.is_c_interop = 0;
|
sym->attr.is_c_interop = 0;
|
sym->ts.is_c_interop = 0;
|
sym->ts.is_c_interop = 0;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* So far, no errors have been found. */
|
/* So far, no errors have been found. */
|
sym->attr.is_c_interop = 1;
|
sym->attr.is_c_interop = 1;
|
sym->ts.is_c_interop = 1;
|
sym->ts.is_c_interop = 1;
|
}
|
}
|
|
|
curr_arg = sym->formal;
|
curr_arg = sym->formal;
|
while (curr_arg != NULL)
|
while (curr_arg != NULL)
|
{
|
{
|
/* Skip implicitly typed dummy args here. */
|
/* Skip implicitly typed dummy args here. */
|
if (curr_arg->sym->attr.implicit_type == 0)
|
if (curr_arg->sym->attr.implicit_type == 0)
|
if (verify_c_interop_param (curr_arg->sym) == FAILURE)
|
if (verify_c_interop_param (curr_arg->sym) == FAILURE)
|
/* If something is found to fail, record the fact so we
|
/* If something is found to fail, record the fact so we
|
can mark the symbol for the procedure as not being
|
can mark the symbol for the procedure as not being
|
BIND(C) to try and prevent multiple errors being
|
BIND(C) to try and prevent multiple errors being
|
reported. */
|
reported. */
|
has_non_interop_arg = 1;
|
has_non_interop_arg = 1;
|
|
|
curr_arg = curr_arg->next;
|
curr_arg = curr_arg->next;
|
}
|
}
|
|
|
/* See if any of the arguments were not interoperable and if so, clear
|
/* See if any of the arguments were not interoperable and if so, clear
|
the procedure symbol to prevent duplicate error messages. */
|
the procedure symbol to prevent duplicate error messages. */
|
if (has_non_interop_arg != 0)
|
if (has_non_interop_arg != 0)
|
{
|
{
|
sym->attr.is_c_interop = 0;
|
sym->attr.is_c_interop = 0;
|
sym->ts.is_c_interop = 0;
|
sym->ts.is_c_interop = 0;
|
sym->attr.is_bind_c = 0;
|
sym->attr.is_bind_c = 0;
|
}
|
}
|
}
|
}
|
|
|
if (!sym->attr.proc_pointer)
|
if (!sym->attr.proc_pointer)
|
{
|
{
|
if (sym->attr.save == SAVE_EXPLICIT)
|
if (sym->attr.save == SAVE_EXPLICIT)
|
{
|
{
|
gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
|
gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
|
"in '%s' at %L", sym->name, &sym->declared_at);
|
"in '%s' at %L", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
if (sym->attr.intent)
|
if (sym->attr.intent)
|
{
|
{
|
gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
|
gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
|
"in '%s' at %L", sym->name, &sym->declared_at);
|
"in '%s' at %L", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
if (sym->attr.subroutine && sym->attr.result)
|
if (sym->attr.subroutine && sym->attr.result)
|
{
|
{
|
gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
|
gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
|
"in '%s' at %L", sym->name, &sym->declared_at);
|
"in '%s' at %L", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
if (sym->attr.external && sym->attr.function
|
if (sym->attr.external && sym->attr.function
|
&& ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
|
&& ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
|
|| sym->attr.contained))
|
|| sym->attr.contained))
|
{
|
{
|
gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
|
gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
|
"in '%s' at %L", sym->name, &sym->declared_at);
|
"in '%s' at %L", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
if (strcmp ("ppr@", sym->name) == 0)
|
if (strcmp ("ppr@", sym->name) == 0)
|
{
|
{
|
gfc_error ("Procedure pointer result '%s' at %L "
|
gfc_error ("Procedure pointer result '%s' at %L "
|
"is missing the pointer attribute",
|
"is missing the pointer attribute",
|
sym->ns->proc_name->name, &sym->declared_at);
|
sym->ns->proc_name->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a list of finalizer procedures. That is, after they have hopefully
|
/* Resolve a list of finalizer procedures. That is, after they have hopefully
|
been defined and we now know their defined arguments, check that they fulfill
|
been defined and we now know their defined arguments, check that they fulfill
|
the requirements of the standard for procedures used as finalizers. */
|
the requirements of the standard for procedures used as finalizers. */
|
|
|
static gfc_try
|
static gfc_try
|
gfc_resolve_finalizers (gfc_symbol* derived)
|
gfc_resolve_finalizers (gfc_symbol* derived)
|
{
|
{
|
gfc_finalizer* list;
|
gfc_finalizer* list;
|
gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
|
gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
|
gfc_try result = SUCCESS;
|
gfc_try result = SUCCESS;
|
bool seen_scalar = false;
|
bool seen_scalar = false;
|
|
|
if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
|
if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* Walk over the list of finalizer-procedures, check them, and if any one
|
/* Walk over the list of finalizer-procedures, check them, and if any one
|
does not fit in with the standard's definition, print an error and remove
|
does not fit in with the standard's definition, print an error and remove
|
it from the list. */
|
it from the list. */
|
prev_link = &derived->f2k_derived->finalizers;
|
prev_link = &derived->f2k_derived->finalizers;
|
for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
|
for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
|
{
|
{
|
gfc_symbol* arg;
|
gfc_symbol* arg;
|
gfc_finalizer* i;
|
gfc_finalizer* i;
|
int my_rank;
|
int my_rank;
|
|
|
/* Skip this finalizer if we already resolved it. */
|
/* Skip this finalizer if we already resolved it. */
|
if (list->proc_tree)
|
if (list->proc_tree)
|
{
|
{
|
prev_link = &(list->next);
|
prev_link = &(list->next);
|
continue;
|
continue;
|
}
|
}
|
|
|
/* Check this exists and is a SUBROUTINE. */
|
/* Check this exists and is a SUBROUTINE. */
|
if (!list->proc_sym->attr.subroutine)
|
if (!list->proc_sym->attr.subroutine)
|
{
|
{
|
gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
|
gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
|
list->proc_sym->name, &list->where);
|
list->proc_sym->name, &list->where);
|
goto error;
|
goto error;
|
}
|
}
|
|
|
/* We should have exactly one argument. */
|
/* We should have exactly one argument. */
|
if (!list->proc_sym->formal || list->proc_sym->formal->next)
|
if (!list->proc_sym->formal || list->proc_sym->formal->next)
|
{
|
{
|
gfc_error ("FINAL procedure at %L must have exactly one argument",
|
gfc_error ("FINAL procedure at %L must have exactly one argument",
|
&list->where);
|
&list->where);
|
goto error;
|
goto error;
|
}
|
}
|
arg = list->proc_sym->formal->sym;
|
arg = list->proc_sym->formal->sym;
|
|
|
/* This argument must be of our type. */
|
/* This argument must be of our type. */
|
if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
|
if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
|
{
|
{
|
gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
|
gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
|
&arg->declared_at, derived->name);
|
&arg->declared_at, derived->name);
|
goto error;
|
goto error;
|
}
|
}
|
|
|
/* It must neither be a pointer nor allocatable nor optional. */
|
/* It must neither be a pointer nor allocatable nor optional. */
|
if (arg->attr.pointer)
|
if (arg->attr.pointer)
|
{
|
{
|
gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
|
gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
|
&arg->declared_at);
|
&arg->declared_at);
|
goto error;
|
goto error;
|
}
|
}
|
if (arg->attr.allocatable)
|
if (arg->attr.allocatable)
|
{
|
{
|
gfc_error ("Argument of FINAL procedure at %L must not be"
|
gfc_error ("Argument of FINAL procedure at %L must not be"
|
" ALLOCATABLE", &arg->declared_at);
|
" ALLOCATABLE", &arg->declared_at);
|
goto error;
|
goto error;
|
}
|
}
|
if (arg->attr.optional)
|
if (arg->attr.optional)
|
{
|
{
|
gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
|
gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
|
&arg->declared_at);
|
&arg->declared_at);
|
goto error;
|
goto error;
|
}
|
}
|
|
|
/* It must not be INTENT(OUT). */
|
/* It must not be INTENT(OUT). */
|
if (arg->attr.intent == INTENT_OUT)
|
if (arg->attr.intent == INTENT_OUT)
|
{
|
{
|
gfc_error ("Argument of FINAL procedure at %L must not be"
|
gfc_error ("Argument of FINAL procedure at %L must not be"
|
" INTENT(OUT)", &arg->declared_at);
|
" INTENT(OUT)", &arg->declared_at);
|
goto error;
|
goto error;
|
}
|
}
|
|
|
/* Warn if the procedure is non-scalar and not assumed shape. */
|
/* Warn if the procedure is non-scalar and not assumed shape. */
|
if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
|
if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
|
&& arg->as->type != AS_ASSUMED_SHAPE)
|
&& arg->as->type != AS_ASSUMED_SHAPE)
|
gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
|
gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
|
" shape argument", &arg->declared_at);
|
" shape argument", &arg->declared_at);
|
|
|
/* Check that it does not match in kind and rank with a FINAL procedure
|
/* Check that it does not match in kind and rank with a FINAL procedure
|
defined earlier. To really loop over the *earlier* declarations,
|
defined earlier. To really loop over the *earlier* declarations,
|
we need to walk the tail of the list as new ones were pushed at the
|
we need to walk the tail of the list as new ones were pushed at the
|
front. */
|
front. */
|
/* TODO: Handle kind parameters once they are implemented. */
|
/* TODO: Handle kind parameters once they are implemented. */
|
my_rank = (arg->as ? arg->as->rank : 0);
|
my_rank = (arg->as ? arg->as->rank : 0);
|
for (i = list->next; i; i = i->next)
|
for (i = list->next; i; i = i->next)
|
{
|
{
|
/* Argument list might be empty; that is an error signalled earlier,
|
/* Argument list might be empty; that is an error signalled earlier,
|
but we nevertheless continued resolving. */
|
but we nevertheless continued resolving. */
|
if (i->proc_sym->formal)
|
if (i->proc_sym->formal)
|
{
|
{
|
gfc_symbol* i_arg = i->proc_sym->formal->sym;
|
gfc_symbol* i_arg = i->proc_sym->formal->sym;
|
const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
|
const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
|
if (i_rank == my_rank)
|
if (i_rank == my_rank)
|
{
|
{
|
gfc_error ("FINAL procedure '%s' declared at %L has the same"
|
gfc_error ("FINAL procedure '%s' declared at %L has the same"
|
" rank (%d) as '%s'",
|
" rank (%d) as '%s'",
|
list->proc_sym->name, &list->where, my_rank,
|
list->proc_sym->name, &list->where, my_rank,
|
i->proc_sym->name);
|
i->proc_sym->name);
|
goto error;
|
goto error;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* Is this the/a scalar finalizer procedure? */
|
/* Is this the/a scalar finalizer procedure? */
|
if (!arg->as || arg->as->rank == 0)
|
if (!arg->as || arg->as->rank == 0)
|
seen_scalar = true;
|
seen_scalar = true;
|
|
|
/* Find the symtree for this procedure. */
|
/* Find the symtree for this procedure. */
|
gcc_assert (!list->proc_tree);
|
gcc_assert (!list->proc_tree);
|
list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
|
list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
|
|
|
prev_link = &list->next;
|
prev_link = &list->next;
|
continue;
|
continue;
|
|
|
/* Remove wrong nodes immediately from the list so we don't risk any
|
/* Remove wrong nodes immediately from the list so we don't risk any
|
troubles in the future when they might fail later expectations. */
|
troubles in the future when they might fail later expectations. */
|
error:
|
error:
|
result = FAILURE;
|
result = FAILURE;
|
i = list;
|
i = list;
|
*prev_link = list->next;
|
*prev_link = list->next;
|
gfc_free_finalizer (i);
|
gfc_free_finalizer (i);
|
}
|
}
|
|
|
/* Warn if we haven't seen a scalar finalizer procedure (but we know there
|
/* Warn if we haven't seen a scalar finalizer procedure (but we know there
|
were nodes in the list, must have been for arrays. It is surely a good
|
were nodes in the list, must have been for arrays. It is surely a good
|
idea to have a scalar version there if there's something to finalize. */
|
idea to have a scalar version there if there's something to finalize. */
|
if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
|
if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
|
gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
|
gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
|
" defined at %L, suggest also scalar one",
|
" defined at %L, suggest also scalar one",
|
derived->name, &derived->declared_at);
|
derived->name, &derived->declared_at);
|
|
|
/* TODO: Remove this error when finalization is finished. */
|
/* TODO: Remove this error when finalization is finished. */
|
gfc_error ("Finalization at %L is not yet implemented",
|
gfc_error ("Finalization at %L is not yet implemented",
|
&derived->declared_at);
|
&derived->declared_at);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Check that it is ok for the typebound procedure proc to override the
|
/* Check that it is ok for the typebound procedure proc to override the
|
procedure old. */
|
procedure old. */
|
|
|
static gfc_try
|
static gfc_try
|
check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
|
check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
|
{
|
{
|
locus where;
|
locus where;
|
const gfc_symbol* proc_target;
|
const gfc_symbol* proc_target;
|
const gfc_symbol* old_target;
|
const gfc_symbol* old_target;
|
unsigned proc_pass_arg, old_pass_arg, argpos;
|
unsigned proc_pass_arg, old_pass_arg, argpos;
|
gfc_formal_arglist* proc_formal;
|
gfc_formal_arglist* proc_formal;
|
gfc_formal_arglist* old_formal;
|
gfc_formal_arglist* old_formal;
|
|
|
/* This procedure should only be called for non-GENERIC proc. */
|
/* This procedure should only be called for non-GENERIC proc. */
|
gcc_assert (!proc->n.tb->is_generic);
|
gcc_assert (!proc->n.tb->is_generic);
|
|
|
/* If the overwritten procedure is GENERIC, this is an error. */
|
/* If the overwritten procedure is GENERIC, this is an error. */
|
if (old->n.tb->is_generic)
|
if (old->n.tb->is_generic)
|
{
|
{
|
gfc_error ("Can't overwrite GENERIC '%s' at %L",
|
gfc_error ("Can't overwrite GENERIC '%s' at %L",
|
old->name, &proc->n.tb->where);
|
old->name, &proc->n.tb->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
where = proc->n.tb->where;
|
where = proc->n.tb->where;
|
proc_target = proc->n.tb->u.specific->n.sym;
|
proc_target = proc->n.tb->u.specific->n.sym;
|
old_target = old->n.tb->u.specific->n.sym;
|
old_target = old->n.tb->u.specific->n.sym;
|
|
|
/* Check that overridden binding is not NON_OVERRIDABLE. */
|
/* Check that overridden binding is not NON_OVERRIDABLE. */
|
if (old->n.tb->non_overridable)
|
if (old->n.tb->non_overridable)
|
{
|
{
|
gfc_error ("'%s' at %L overrides a procedure binding declared"
|
gfc_error ("'%s' at %L overrides a procedure binding declared"
|
" NON_OVERRIDABLE", proc->name, &where);
|
" NON_OVERRIDABLE", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
|
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
|
if (!old->n.tb->deferred && proc->n.tb->deferred)
|
if (!old->n.tb->deferred && proc->n.tb->deferred)
|
{
|
{
|
gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
|
gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
|
" non-DEFERRED binding", proc->name, &where);
|
" non-DEFERRED binding", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* If the overridden binding is PURE, the overriding must be, too. */
|
/* If the overridden binding is PURE, the overriding must be, too. */
|
if (old_target->attr.pure && !proc_target->attr.pure)
|
if (old_target->attr.pure && !proc_target->attr.pure)
|
{
|
{
|
gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
|
gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
|
proc->name, &where);
|
proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
|
/* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
|
is not, the overriding must not be either. */
|
is not, the overriding must not be either. */
|
if (old_target->attr.elemental && !proc_target->attr.elemental)
|
if (old_target->attr.elemental && !proc_target->attr.elemental)
|
{
|
{
|
gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
|
gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
|
" ELEMENTAL", proc->name, &where);
|
" ELEMENTAL", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
if (!old_target->attr.elemental && proc_target->attr.elemental)
|
if (!old_target->attr.elemental && proc_target->attr.elemental)
|
{
|
{
|
gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
|
gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
|
" be ELEMENTAL, either", proc->name, &where);
|
" be ELEMENTAL, either", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* If the overridden binding is a SUBROUTINE, the overriding must also be a
|
/* If the overridden binding is a SUBROUTINE, the overriding must also be a
|
SUBROUTINE. */
|
SUBROUTINE. */
|
if (old_target->attr.subroutine && !proc_target->attr.subroutine)
|
if (old_target->attr.subroutine && !proc_target->attr.subroutine)
|
{
|
{
|
gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
|
gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
|
" SUBROUTINE", proc->name, &where);
|
" SUBROUTINE", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* If the overridden binding is a FUNCTION, the overriding must also be a
|
/* If the overridden binding is a FUNCTION, the overriding must also be a
|
FUNCTION and have the same characteristics. */
|
FUNCTION and have the same characteristics. */
|
if (old_target->attr.function)
|
if (old_target->attr.function)
|
{
|
{
|
if (!proc_target->attr.function)
|
if (!proc_target->attr.function)
|
{
|
{
|
gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
|
gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
|
" FUNCTION", proc->name, &where);
|
" FUNCTION", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* FIXME: Do more comprehensive checking (including, for instance, the
|
/* FIXME: Do more comprehensive checking (including, for instance, the
|
rank and array-shape). */
|
rank and array-shape). */
|
gcc_assert (proc_target->result && old_target->result);
|
gcc_assert (proc_target->result && old_target->result);
|
if (!gfc_compare_types (&proc_target->result->ts,
|
if (!gfc_compare_types (&proc_target->result->ts,
|
&old_target->result->ts))
|
&old_target->result->ts))
|
{
|
{
|
gfc_error ("'%s' at %L and the overridden FUNCTION should have"
|
gfc_error ("'%s' at %L and the overridden FUNCTION should have"
|
" matching result types", proc->name, &where);
|
" matching result types", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
/* If the overridden binding is PUBLIC, the overriding one must not be
|
/* If the overridden binding is PUBLIC, the overriding one must not be
|
PRIVATE. */
|
PRIVATE. */
|
if (old->n.tb->access == ACCESS_PUBLIC
|
if (old->n.tb->access == ACCESS_PUBLIC
|
&& proc->n.tb->access == ACCESS_PRIVATE)
|
&& proc->n.tb->access == ACCESS_PRIVATE)
|
{
|
{
|
gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
|
gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
|
" PRIVATE", proc->name, &where);
|
" PRIVATE", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Compare the formal argument lists of both procedures. This is also abused
|
/* Compare the formal argument lists of both procedures. This is also abused
|
to find the position of the passed-object dummy arguments of both
|
to find the position of the passed-object dummy arguments of both
|
bindings as at least the overridden one might not yet be resolved and we
|
bindings as at least the overridden one might not yet be resolved and we
|
need those positions in the check below. */
|
need those positions in the check below. */
|
proc_pass_arg = old_pass_arg = 0;
|
proc_pass_arg = old_pass_arg = 0;
|
if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
|
if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
|
proc_pass_arg = 1;
|
proc_pass_arg = 1;
|
if (!old->n.tb->nopass && !old->n.tb->pass_arg)
|
if (!old->n.tb->nopass && !old->n.tb->pass_arg)
|
old_pass_arg = 1;
|
old_pass_arg = 1;
|
argpos = 1;
|
argpos = 1;
|
for (proc_formal = proc_target->formal, old_formal = old_target->formal;
|
for (proc_formal = proc_target->formal, old_formal = old_target->formal;
|
proc_formal && old_formal;
|
proc_formal && old_formal;
|
proc_formal = proc_formal->next, old_formal = old_formal->next)
|
proc_formal = proc_formal->next, old_formal = old_formal->next)
|
{
|
{
|
if (proc->n.tb->pass_arg
|
if (proc->n.tb->pass_arg
|
&& !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
|
&& !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
|
proc_pass_arg = argpos;
|
proc_pass_arg = argpos;
|
if (old->n.tb->pass_arg
|
if (old->n.tb->pass_arg
|
&& !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
|
&& !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
|
old_pass_arg = argpos;
|
old_pass_arg = argpos;
|
|
|
/* Check that the names correspond. */
|
/* Check that the names correspond. */
|
if (strcmp (proc_formal->sym->name, old_formal->sym->name))
|
if (strcmp (proc_formal->sym->name, old_formal->sym->name))
|
{
|
{
|
gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
|
gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
|
" to match the corresponding argument of the overridden"
|
" to match the corresponding argument of the overridden"
|
" procedure", proc_formal->sym->name, proc->name, &where,
|
" procedure", proc_formal->sym->name, proc->name, &where,
|
old_formal->sym->name);
|
old_formal->sym->name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Check that the types correspond if neither is the passed-object
|
/* Check that the types correspond if neither is the passed-object
|
argument. */
|
argument. */
|
/* FIXME: Do more comprehensive testing here. */
|
/* FIXME: Do more comprehensive testing here. */
|
if (proc_pass_arg != argpos && old_pass_arg != argpos
|
if (proc_pass_arg != argpos && old_pass_arg != argpos
|
&& !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
|
&& !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
|
{
|
{
|
gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
|
gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
|
"in respect to the overridden procedure",
|
"in respect to the overridden procedure",
|
proc_formal->sym->name, proc->name, &where);
|
proc_formal->sym->name, proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
++argpos;
|
++argpos;
|
}
|
}
|
if (proc_formal || old_formal)
|
if (proc_formal || old_formal)
|
{
|
{
|
gfc_error ("'%s' at %L must have the same number of formal arguments as"
|
gfc_error ("'%s' at %L must have the same number of formal arguments as"
|
" the overridden procedure", proc->name, &where);
|
" the overridden procedure", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* If the overridden binding is NOPASS, the overriding one must also be
|
/* If the overridden binding is NOPASS, the overriding one must also be
|
NOPASS. */
|
NOPASS. */
|
if (old->n.tb->nopass && !proc->n.tb->nopass)
|
if (old->n.tb->nopass && !proc->n.tb->nopass)
|
{
|
{
|
gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
|
gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
|
" NOPASS", proc->name, &where);
|
" NOPASS", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* If the overridden binding is PASS(x), the overriding one must also be
|
/* If the overridden binding is PASS(x), the overriding one must also be
|
PASS and the passed-object dummy arguments must correspond. */
|
PASS and the passed-object dummy arguments must correspond. */
|
if (!old->n.tb->nopass)
|
if (!old->n.tb->nopass)
|
{
|
{
|
if (proc->n.tb->nopass)
|
if (proc->n.tb->nopass)
|
{
|
{
|
gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
|
gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
|
" PASS", proc->name, &where);
|
" PASS", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (proc_pass_arg != old_pass_arg)
|
if (proc_pass_arg != old_pass_arg)
|
{
|
{
|
gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
|
gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
|
" the same position as the passed-object dummy argument of"
|
" the same position as the passed-object dummy argument of"
|
" the overridden procedure", proc->name, &where);
|
" the overridden procedure", proc->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
|
/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
|
|
|
static gfc_try
|
static gfc_try
|
check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
|
check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
|
const char* generic_name, locus where)
|
const char* generic_name, locus where)
|
{
|
{
|
gfc_symbol* sym1;
|
gfc_symbol* sym1;
|
gfc_symbol* sym2;
|
gfc_symbol* sym2;
|
|
|
gcc_assert (t1->specific && t2->specific);
|
gcc_assert (t1->specific && t2->specific);
|
gcc_assert (!t1->specific->is_generic);
|
gcc_assert (!t1->specific->is_generic);
|
gcc_assert (!t2->specific->is_generic);
|
gcc_assert (!t2->specific->is_generic);
|
|
|
sym1 = t1->specific->u.specific->n.sym;
|
sym1 = t1->specific->u.specific->n.sym;
|
sym2 = t2->specific->u.specific->n.sym;
|
sym2 = t2->specific->u.specific->n.sym;
|
|
|
if (sym1 == sym2)
|
if (sym1 == sym2)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* Both must be SUBROUTINEs or both must be FUNCTIONs. */
|
/* Both must be SUBROUTINEs or both must be FUNCTIONs. */
|
if (sym1->attr.subroutine != sym2->attr.subroutine
|
if (sym1->attr.subroutine != sym2->attr.subroutine
|
|| sym1->attr.function != sym2->attr.function)
|
|| sym1->attr.function != sym2->attr.function)
|
{
|
{
|
gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
|
gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
|
" GENERIC '%s' at %L",
|
" GENERIC '%s' at %L",
|
sym1->name, sym2->name, generic_name, &where);
|
sym1->name, sym2->name, generic_name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Compare the interfaces. */
|
/* Compare the interfaces. */
|
if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
|
if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
|
{
|
{
|
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
|
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
|
sym1->name, sym2->name, generic_name, &where);
|
sym1->name, sym2->name, generic_name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Worker function for resolving a generic procedure binding; this is used to
|
/* Worker function for resolving a generic procedure binding; this is used to
|
resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
|
resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
|
|
|
The difference between those cases is finding possible inherited bindings
|
The difference between those cases is finding possible inherited bindings
|
that are overridden, as one has to look for them in tb_sym_root,
|
that are overridden, as one has to look for them in tb_sym_root,
|
tb_uop_root or tb_op, respectively. Thus the caller must already find
|
tb_uop_root or tb_op, respectively. Thus the caller must already find
|
the super-type and set p->overridden correctly. */
|
the super-type and set p->overridden correctly. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_tb_generic_targets (gfc_symbol* super_type,
|
resolve_tb_generic_targets (gfc_symbol* super_type,
|
gfc_typebound_proc* p, const char* name)
|
gfc_typebound_proc* p, const char* name)
|
{
|
{
|
gfc_tbp_generic* target;
|
gfc_tbp_generic* target;
|
gfc_symtree* first_target;
|
gfc_symtree* first_target;
|
gfc_symtree* inherited;
|
gfc_symtree* inherited;
|
|
|
gcc_assert (p && p->is_generic);
|
gcc_assert (p && p->is_generic);
|
|
|
/* Try to find the specific bindings for the symtrees in our target-list. */
|
/* Try to find the specific bindings for the symtrees in our target-list. */
|
gcc_assert (p->u.generic);
|
gcc_assert (p->u.generic);
|
for (target = p->u.generic; target; target = target->next)
|
for (target = p->u.generic; target; target = target->next)
|
if (!target->specific)
|
if (!target->specific)
|
{
|
{
|
gfc_typebound_proc* overridden_tbp;
|
gfc_typebound_proc* overridden_tbp;
|
gfc_tbp_generic* g;
|
gfc_tbp_generic* g;
|
const char* target_name;
|
const char* target_name;
|
|
|
target_name = target->specific_st->name;
|
target_name = target->specific_st->name;
|
|
|
/* Defined for this type directly. */
|
/* Defined for this type directly. */
|
if (target->specific_st->n.tb)
|
if (target->specific_st->n.tb)
|
{
|
{
|
target->specific = target->specific_st->n.tb;
|
target->specific = target->specific_st->n.tb;
|
goto specific_found;
|
goto specific_found;
|
}
|
}
|
|
|
/* Look for an inherited specific binding. */
|
/* Look for an inherited specific binding. */
|
if (super_type)
|
if (super_type)
|
{
|
{
|
inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
|
inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
|
true, NULL);
|
true, NULL);
|
|
|
if (inherited)
|
if (inherited)
|
{
|
{
|
gcc_assert (inherited->n.tb);
|
gcc_assert (inherited->n.tb);
|
target->specific = inherited->n.tb;
|
target->specific = inherited->n.tb;
|
goto specific_found;
|
goto specific_found;
|
}
|
}
|
}
|
}
|
|
|
gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
|
gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
|
" at %L", target_name, name, &p->where);
|
" at %L", target_name, name, &p->where);
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Once we've found the specific binding, check it is not ambiguous with
|
/* Once we've found the specific binding, check it is not ambiguous with
|
other specifics already found or inherited for the same GENERIC. */
|
other specifics already found or inherited for the same GENERIC. */
|
specific_found:
|
specific_found:
|
gcc_assert (target->specific);
|
gcc_assert (target->specific);
|
|
|
/* This must really be a specific binding! */
|
/* This must really be a specific binding! */
|
if (target->specific->is_generic)
|
if (target->specific->is_generic)
|
{
|
{
|
gfc_error ("GENERIC '%s' at %L must target a specific binding,"
|
gfc_error ("GENERIC '%s' at %L must target a specific binding,"
|
" '%s' is GENERIC, too", name, &p->where, target_name);
|
" '%s' is GENERIC, too", name, &p->where, target_name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Check those already resolved on this type directly. */
|
/* Check those already resolved on this type directly. */
|
for (g = p->u.generic; g; g = g->next)
|
for (g = p->u.generic; g; g = g->next)
|
if (g != target && g->specific
|
if (g != target && g->specific
|
&& check_generic_tbp_ambiguity (target, g, name, p->where)
|
&& check_generic_tbp_ambiguity (target, g, name, p->where)
|
== FAILURE)
|
== FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Check for ambiguity with inherited specific targets. */
|
/* Check for ambiguity with inherited specific targets. */
|
for (overridden_tbp = p->overridden; overridden_tbp;
|
for (overridden_tbp = p->overridden; overridden_tbp;
|
overridden_tbp = overridden_tbp->overridden)
|
overridden_tbp = overridden_tbp->overridden)
|
if (overridden_tbp->is_generic)
|
if (overridden_tbp->is_generic)
|
{
|
{
|
for (g = overridden_tbp->u.generic; g; g = g->next)
|
for (g = overridden_tbp->u.generic; g; g = g->next)
|
{
|
{
|
gcc_assert (g->specific);
|
gcc_assert (g->specific);
|
if (check_generic_tbp_ambiguity (target, g,
|
if (check_generic_tbp_ambiguity (target, g,
|
name, p->where) == FAILURE)
|
name, p->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* If we attempt to "overwrite" a specific binding, this is an error. */
|
/* If we attempt to "overwrite" a specific binding, this is an error. */
|
if (p->overridden && !p->overridden->is_generic)
|
if (p->overridden && !p->overridden->is_generic)
|
{
|
{
|
gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
|
gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
|
" the same name", name, &p->where);
|
" the same name", name, &p->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
|
/* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
|
all must have the same attributes here. */
|
all must have the same attributes here. */
|
first_target = p->u.generic->specific->u.specific;
|
first_target = p->u.generic->specific->u.specific;
|
gcc_assert (first_target);
|
gcc_assert (first_target);
|
p->subroutine = first_target->n.sym->attr.subroutine;
|
p->subroutine = first_target->n.sym->attr.subroutine;
|
p->function = first_target->n.sym->attr.function;
|
p->function = first_target->n.sym->attr.function;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a GENERIC procedure binding for a derived type. */
|
/* Resolve a GENERIC procedure binding for a derived type. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
|
resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
|
{
|
{
|
gfc_symbol* super_type;
|
gfc_symbol* super_type;
|
|
|
/* Find the overridden binding if any. */
|
/* Find the overridden binding if any. */
|
st->n.tb->overridden = NULL;
|
st->n.tb->overridden = NULL;
|
super_type = gfc_get_derived_super_type (derived);
|
super_type = gfc_get_derived_super_type (derived);
|
if (super_type)
|
if (super_type)
|
{
|
{
|
gfc_symtree* overridden;
|
gfc_symtree* overridden;
|
overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
|
overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
|
true, NULL);
|
true, NULL);
|
|
|
if (overridden && overridden->n.tb)
|
if (overridden && overridden->n.tb)
|
st->n.tb->overridden = overridden->n.tb;
|
st->n.tb->overridden = overridden->n.tb;
|
}
|
}
|
|
|
/* Resolve using worker function. */
|
/* Resolve using worker function. */
|
return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
|
return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
|
}
|
}
|
|
|
|
|
/* Retrieve the target-procedure of an operator binding and do some checks in
|
/* Retrieve the target-procedure of an operator binding and do some checks in
|
common for intrinsic and user-defined type-bound operators. */
|
common for intrinsic and user-defined type-bound operators. */
|
|
|
static gfc_symbol*
|
static gfc_symbol*
|
get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
|
get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
|
{
|
{
|
gfc_symbol* target_proc;
|
gfc_symbol* target_proc;
|
|
|
gcc_assert (target->specific && !target->specific->is_generic);
|
gcc_assert (target->specific && !target->specific->is_generic);
|
target_proc = target->specific->u.specific->n.sym;
|
target_proc = target->specific->u.specific->n.sym;
|
gcc_assert (target_proc);
|
gcc_assert (target_proc);
|
|
|
/* All operator bindings must have a passed-object dummy argument. */
|
/* All operator bindings must have a passed-object dummy argument. */
|
if (target->specific->nopass)
|
if (target->specific->nopass)
|
{
|
{
|
gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
|
gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return target_proc;
|
return target_proc;
|
}
|
}
|
|
|
|
|
/* Resolve a type-bound intrinsic operator. */
|
/* Resolve a type-bound intrinsic operator. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
|
resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
|
gfc_typebound_proc* p)
|
gfc_typebound_proc* p)
|
{
|
{
|
gfc_symbol* super_type;
|
gfc_symbol* super_type;
|
gfc_tbp_generic* target;
|
gfc_tbp_generic* target;
|
|
|
/* If there's already an error here, do nothing (but don't fail again). */
|
/* If there's already an error here, do nothing (but don't fail again). */
|
if (p->error)
|
if (p->error)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* Operators should always be GENERIC bindings. */
|
/* Operators should always be GENERIC bindings. */
|
gcc_assert (p->is_generic);
|
gcc_assert (p->is_generic);
|
|
|
/* Look for an overridden binding. */
|
/* Look for an overridden binding. */
|
super_type = gfc_get_derived_super_type (derived);
|
super_type = gfc_get_derived_super_type (derived);
|
if (super_type && super_type->f2k_derived)
|
if (super_type && super_type->f2k_derived)
|
p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
|
p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
|
op, true, NULL);
|
op, true, NULL);
|
else
|
else
|
p->overridden = NULL;
|
p->overridden = NULL;
|
|
|
/* Resolve general GENERIC properties using worker function. */
|
/* Resolve general GENERIC properties using worker function. */
|
if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
|
if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
|
goto error;
|
goto error;
|
|
|
/* Check the targets to be procedures of correct interface. */
|
/* Check the targets to be procedures of correct interface. */
|
for (target = p->u.generic; target; target = target->next)
|
for (target = p->u.generic; target; target = target->next)
|
{
|
{
|
gfc_symbol* target_proc;
|
gfc_symbol* target_proc;
|
|
|
target_proc = get_checked_tb_operator_target (target, p->where);
|
target_proc = get_checked_tb_operator_target (target, p->where);
|
if (!target_proc)
|
if (!target_proc)
|
goto error;
|
goto error;
|
|
|
if (!gfc_check_operator_interface (target_proc, op, p->where))
|
if (!gfc_check_operator_interface (target_proc, op, p->where))
|
goto error;
|
goto error;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
|
|
error:
|
error:
|
p->error = 1;
|
p->error = 1;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Resolve a type-bound user operator (tree-walker callback). */
|
/* Resolve a type-bound user operator (tree-walker callback). */
|
|
|
static gfc_symbol* resolve_bindings_derived;
|
static gfc_symbol* resolve_bindings_derived;
|
static gfc_try resolve_bindings_result;
|
static gfc_try resolve_bindings_result;
|
|
|
static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
|
static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
|
|
|
static void
|
static void
|
resolve_typebound_user_op (gfc_symtree* stree)
|
resolve_typebound_user_op (gfc_symtree* stree)
|
{
|
{
|
gfc_symbol* super_type;
|
gfc_symbol* super_type;
|
gfc_tbp_generic* target;
|
gfc_tbp_generic* target;
|
|
|
gcc_assert (stree && stree->n.tb);
|
gcc_assert (stree && stree->n.tb);
|
|
|
if (stree->n.tb->error)
|
if (stree->n.tb->error)
|
return;
|
return;
|
|
|
/* Operators should always be GENERIC bindings. */
|
/* Operators should always be GENERIC bindings. */
|
gcc_assert (stree->n.tb->is_generic);
|
gcc_assert (stree->n.tb->is_generic);
|
|
|
/* Find overridden procedure, if any. */
|
/* Find overridden procedure, if any. */
|
super_type = gfc_get_derived_super_type (resolve_bindings_derived);
|
super_type = gfc_get_derived_super_type (resolve_bindings_derived);
|
if (super_type && super_type->f2k_derived)
|
if (super_type && super_type->f2k_derived)
|
{
|
{
|
gfc_symtree* overridden;
|
gfc_symtree* overridden;
|
overridden = gfc_find_typebound_user_op (super_type, NULL,
|
overridden = gfc_find_typebound_user_op (super_type, NULL,
|
stree->name, true, NULL);
|
stree->name, true, NULL);
|
|
|
if (overridden && overridden->n.tb)
|
if (overridden && overridden->n.tb)
|
stree->n.tb->overridden = overridden->n.tb;
|
stree->n.tb->overridden = overridden->n.tb;
|
}
|
}
|
else
|
else
|
stree->n.tb->overridden = NULL;
|
stree->n.tb->overridden = NULL;
|
|
|
/* Resolve basically using worker function. */
|
/* Resolve basically using worker function. */
|
if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
|
if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
|
== FAILURE)
|
== FAILURE)
|
goto error;
|
goto error;
|
|
|
/* Check the targets to be functions of correct interface. */
|
/* Check the targets to be functions of correct interface. */
|
for (target = stree->n.tb->u.generic; target; target = target->next)
|
for (target = stree->n.tb->u.generic; target; target = target->next)
|
{
|
{
|
gfc_symbol* target_proc;
|
gfc_symbol* target_proc;
|
|
|
target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
|
target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
|
if (!target_proc)
|
if (!target_proc)
|
goto error;
|
goto error;
|
|
|
if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
|
if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
|
goto error;
|
goto error;
|
}
|
}
|
|
|
return;
|
return;
|
|
|
error:
|
error:
|
resolve_bindings_result = FAILURE;
|
resolve_bindings_result = FAILURE;
|
stree->n.tb->error = 1;
|
stree->n.tb->error = 1;
|
}
|
}
|
|
|
|
|
/* Resolve the type-bound procedures for a derived type. */
|
/* Resolve the type-bound procedures for a derived type. */
|
|
|
static void
|
static void
|
resolve_typebound_procedure (gfc_symtree* stree)
|
resolve_typebound_procedure (gfc_symtree* stree)
|
{
|
{
|
gfc_symbol* proc;
|
gfc_symbol* proc;
|
locus where;
|
locus where;
|
gfc_symbol* me_arg;
|
gfc_symbol* me_arg;
|
gfc_symbol* super_type;
|
gfc_symbol* super_type;
|
gfc_component* comp;
|
gfc_component* comp;
|
|
|
gcc_assert (stree);
|
gcc_assert (stree);
|
|
|
/* Undefined specific symbol from GENERIC target definition. */
|
/* Undefined specific symbol from GENERIC target definition. */
|
if (!stree->n.tb)
|
if (!stree->n.tb)
|
return;
|
return;
|
|
|
if (stree->n.tb->error)
|
if (stree->n.tb->error)
|
return;
|
return;
|
|
|
/* If this is a GENERIC binding, use that routine. */
|
/* If this is a GENERIC binding, use that routine. */
|
if (stree->n.tb->is_generic)
|
if (stree->n.tb->is_generic)
|
{
|
{
|
if (resolve_typebound_generic (resolve_bindings_derived, stree)
|
if (resolve_typebound_generic (resolve_bindings_derived, stree)
|
== FAILURE)
|
== FAILURE)
|
goto error;
|
goto error;
|
return;
|
return;
|
}
|
}
|
|
|
/* Get the target-procedure to check it. */
|
/* Get the target-procedure to check it. */
|
gcc_assert (!stree->n.tb->is_generic);
|
gcc_assert (!stree->n.tb->is_generic);
|
gcc_assert (stree->n.tb->u.specific);
|
gcc_assert (stree->n.tb->u.specific);
|
proc = stree->n.tb->u.specific->n.sym;
|
proc = stree->n.tb->u.specific->n.sym;
|
where = stree->n.tb->where;
|
where = stree->n.tb->where;
|
|
|
/* Default access should already be resolved from the parser. */
|
/* Default access should already be resolved from the parser. */
|
gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
|
gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
|
|
|
/* It should be a module procedure or an external procedure with explicit
|
/* It should be a module procedure or an external procedure with explicit
|
interface. For DEFERRED bindings, abstract interfaces are ok as well. */
|
interface. For DEFERRED bindings, abstract interfaces are ok as well. */
|
if ((!proc->attr.subroutine && !proc->attr.function)
|
if ((!proc->attr.subroutine && !proc->attr.function)
|
|| (proc->attr.proc != PROC_MODULE
|
|| (proc->attr.proc != PROC_MODULE
|
&& proc->attr.if_source != IFSRC_IFBODY)
|
&& proc->attr.if_source != IFSRC_IFBODY)
|
|| (proc->attr.abstract && !stree->n.tb->deferred))
|
|| (proc->attr.abstract && !stree->n.tb->deferred))
|
{
|
{
|
gfc_error ("'%s' must be a module procedure or an external procedure with"
|
gfc_error ("'%s' must be a module procedure or an external procedure with"
|
" an explicit interface at %L", proc->name, &where);
|
" an explicit interface at %L", proc->name, &where);
|
goto error;
|
goto error;
|
}
|
}
|
stree->n.tb->subroutine = proc->attr.subroutine;
|
stree->n.tb->subroutine = proc->attr.subroutine;
|
stree->n.tb->function = proc->attr.function;
|
stree->n.tb->function = proc->attr.function;
|
|
|
/* Find the super-type of the current derived type. We could do this once and
|
/* Find the super-type of the current derived type. We could do this once and
|
store in a global if speed is needed, but as long as not I believe this is
|
store in a global if speed is needed, but as long as not I believe this is
|
more readable and clearer. */
|
more readable and clearer. */
|
super_type = gfc_get_derived_super_type (resolve_bindings_derived);
|
super_type = gfc_get_derived_super_type (resolve_bindings_derived);
|
|
|
/* If PASS, resolve and check arguments if not already resolved / loaded
|
/* If PASS, resolve and check arguments if not already resolved / loaded
|
from a .mod file. */
|
from a .mod file. */
|
if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
|
if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
|
{
|
{
|
if (stree->n.tb->pass_arg)
|
if (stree->n.tb->pass_arg)
|
{
|
{
|
gfc_formal_arglist* i;
|
gfc_formal_arglist* i;
|
|
|
/* If an explicit passing argument name is given, walk the arg-list
|
/* If an explicit passing argument name is given, walk the arg-list
|
and look for it. */
|
and look for it. */
|
|
|
me_arg = NULL;
|
me_arg = NULL;
|
stree->n.tb->pass_arg_num = 1;
|
stree->n.tb->pass_arg_num = 1;
|
for (i = proc->formal; i; i = i->next)
|
for (i = proc->formal; i; i = i->next)
|
{
|
{
|
if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
|
if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
|
{
|
{
|
me_arg = i->sym;
|
me_arg = i->sym;
|
break;
|
break;
|
}
|
}
|
++stree->n.tb->pass_arg_num;
|
++stree->n.tb->pass_arg_num;
|
}
|
}
|
|
|
if (!me_arg)
|
if (!me_arg)
|
{
|
{
|
gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
|
gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
|
" argument '%s'",
|
" argument '%s'",
|
proc->name, stree->n.tb->pass_arg, &where,
|
proc->name, stree->n.tb->pass_arg, &where,
|
stree->n.tb->pass_arg);
|
stree->n.tb->pass_arg);
|
goto error;
|
goto error;
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Otherwise, take the first one; there should in fact be at least
|
/* Otherwise, take the first one; there should in fact be at least
|
one. */
|
one. */
|
stree->n.tb->pass_arg_num = 1;
|
stree->n.tb->pass_arg_num = 1;
|
if (!proc->formal)
|
if (!proc->formal)
|
{
|
{
|
gfc_error ("Procedure '%s' with PASS at %L must have at"
|
gfc_error ("Procedure '%s' with PASS at %L must have at"
|
" least one argument", proc->name, &where);
|
" least one argument", proc->name, &where);
|
goto error;
|
goto error;
|
}
|
}
|
me_arg = proc->formal->sym;
|
me_arg = proc->formal->sym;
|
}
|
}
|
|
|
/* Now check that the argument-type matches and the passed-object
|
/* Now check that the argument-type matches and the passed-object
|
dummy argument is generally fine. */
|
dummy argument is generally fine. */
|
|
|
gcc_assert (me_arg);
|
gcc_assert (me_arg);
|
|
|
if (me_arg->ts.type != BT_CLASS)
|
if (me_arg->ts.type != BT_CLASS)
|
{
|
{
|
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
|
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
|
" at %L", proc->name, &where);
|
" at %L", proc->name, &where);
|
goto error;
|
goto error;
|
}
|
}
|
|
|
if (me_arg->ts.u.derived->components->ts.u.derived
|
if (me_arg->ts.u.derived->components->ts.u.derived
|
!= resolve_bindings_derived)
|
!= resolve_bindings_derived)
|
{
|
{
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
|
" the derived-type '%s'", me_arg->name, proc->name,
|
" the derived-type '%s'", me_arg->name, proc->name,
|
me_arg->name, &where, resolve_bindings_derived->name);
|
me_arg->name, &where, resolve_bindings_derived->name);
|
goto error;
|
goto error;
|
}
|
}
|
|
|
gcc_assert (me_arg->ts.type == BT_CLASS);
|
gcc_assert (me_arg->ts.type == BT_CLASS);
|
if (me_arg->ts.u.derived->components->as
|
if (me_arg->ts.u.derived->components->as
|
&& me_arg->ts.u.derived->components->as->rank > 0)
|
&& me_arg->ts.u.derived->components->as->rank > 0)
|
{
|
{
|
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
|
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
|
" scalar", proc->name, &where);
|
" scalar", proc->name, &where);
|
goto error;
|
goto error;
|
}
|
}
|
if (me_arg->ts.u.derived->components->attr.allocatable)
|
if (me_arg->ts.u.derived->components->attr.allocatable)
|
{
|
{
|
gfc_error ("Passed-object dummy argument of '%s' at %L must not"
|
gfc_error ("Passed-object dummy argument of '%s' at %L must not"
|
" be ALLOCATABLE", proc->name, &where);
|
" be ALLOCATABLE", proc->name, &where);
|
goto error;
|
goto error;
|
}
|
}
|
if (me_arg->ts.u.derived->components->attr.class_pointer)
|
if (me_arg->ts.u.derived->components->attr.class_pointer)
|
{
|
{
|
gfc_error ("Passed-object dummy argument of '%s' at %L must not"
|
gfc_error ("Passed-object dummy argument of '%s' at %L must not"
|
" be POINTER", proc->name, &where);
|
" be POINTER", proc->name, &where);
|
goto error;
|
goto error;
|
}
|
}
|
}
|
}
|
|
|
/* If we are extending some type, check that we don't override a procedure
|
/* If we are extending some type, check that we don't override a procedure
|
flagged NON_OVERRIDABLE. */
|
flagged NON_OVERRIDABLE. */
|
stree->n.tb->overridden = NULL;
|
stree->n.tb->overridden = NULL;
|
if (super_type)
|
if (super_type)
|
{
|
{
|
gfc_symtree* overridden;
|
gfc_symtree* overridden;
|
overridden = gfc_find_typebound_proc (super_type, NULL,
|
overridden = gfc_find_typebound_proc (super_type, NULL,
|
stree->name, true, NULL);
|
stree->name, true, NULL);
|
|
|
if (overridden && overridden->n.tb)
|
if (overridden && overridden->n.tb)
|
stree->n.tb->overridden = overridden->n.tb;
|
stree->n.tb->overridden = overridden->n.tb;
|
|
|
if (overridden && check_typebound_override (stree, overridden) == FAILURE)
|
if (overridden && check_typebound_override (stree, overridden) == FAILURE)
|
goto error;
|
goto error;
|
}
|
}
|
|
|
/* See if there's a name collision with a component directly in this type. */
|
/* See if there's a name collision with a component directly in this type. */
|
for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
|
for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
|
if (!strcmp (comp->name, stree->name))
|
if (!strcmp (comp->name, stree->name))
|
{
|
{
|
gfc_error ("Procedure '%s' at %L has the same name as a component of"
|
gfc_error ("Procedure '%s' at %L has the same name as a component of"
|
" '%s'",
|
" '%s'",
|
stree->name, &where, resolve_bindings_derived->name);
|
stree->name, &where, resolve_bindings_derived->name);
|
goto error;
|
goto error;
|
}
|
}
|
|
|
/* Try to find a name collision with an inherited component. */
|
/* Try to find a name collision with an inherited component. */
|
if (super_type && gfc_find_component (super_type, stree->name, true, true))
|
if (super_type && gfc_find_component (super_type, stree->name, true, true))
|
{
|
{
|
gfc_error ("Procedure '%s' at %L has the same name as an inherited"
|
gfc_error ("Procedure '%s' at %L has the same name as an inherited"
|
" component of '%s'",
|
" component of '%s'",
|
stree->name, &where, resolve_bindings_derived->name);
|
stree->name, &where, resolve_bindings_derived->name);
|
goto error;
|
goto error;
|
}
|
}
|
|
|
stree->n.tb->error = 0;
|
stree->n.tb->error = 0;
|
return;
|
return;
|
|
|
error:
|
error:
|
resolve_bindings_result = FAILURE;
|
resolve_bindings_result = FAILURE;
|
stree->n.tb->error = 1;
|
stree->n.tb->error = 1;
|
}
|
}
|
|
|
static gfc_try
|
static gfc_try
|
resolve_typebound_procedures (gfc_symbol* derived)
|
resolve_typebound_procedures (gfc_symbol* derived)
|
{
|
{
|
int op;
|
int op;
|
|
|
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
|
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
resolve_bindings_derived = derived;
|
resolve_bindings_derived = derived;
|
resolve_bindings_result = SUCCESS;
|
resolve_bindings_result = SUCCESS;
|
|
|
if (derived->f2k_derived->tb_sym_root)
|
if (derived->f2k_derived->tb_sym_root)
|
gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
|
gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
|
&resolve_typebound_procedure);
|
&resolve_typebound_procedure);
|
|
|
if (derived->f2k_derived->tb_uop_root)
|
if (derived->f2k_derived->tb_uop_root)
|
gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
|
gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
|
&resolve_typebound_user_op);
|
&resolve_typebound_user_op);
|
|
|
for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
|
for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
|
{
|
{
|
gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
|
gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
|
if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
|
if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
|
p) == FAILURE)
|
p) == FAILURE)
|
resolve_bindings_result = FAILURE;
|
resolve_bindings_result = FAILURE;
|
}
|
}
|
|
|
return resolve_bindings_result;
|
return resolve_bindings_result;
|
}
|
}
|
|
|
|
|
/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
|
/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
|
to give all identical derived types the same backend_decl. */
|
to give all identical derived types the same backend_decl. */
|
static void
|
static void
|
add_dt_to_dt_list (gfc_symbol *derived)
|
add_dt_to_dt_list (gfc_symbol *derived)
|
{
|
{
|
gfc_dt_list *dt_list;
|
gfc_dt_list *dt_list;
|
|
|
for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
|
for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
|
if (derived == dt_list->derived)
|
if (derived == dt_list->derived)
|
break;
|
break;
|
|
|
if (dt_list == NULL)
|
if (dt_list == NULL)
|
{
|
{
|
dt_list = gfc_get_dt_list ();
|
dt_list = gfc_get_dt_list ();
|
dt_list->next = gfc_derived_types;
|
dt_list->next = gfc_derived_types;
|
dt_list->derived = derived;
|
dt_list->derived = derived;
|
gfc_derived_types = dt_list;
|
gfc_derived_types = dt_list;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Ensure that a derived-type is really not abstract, meaning that every
|
/* Ensure that a derived-type is really not abstract, meaning that every
|
inherited DEFERRED binding is overridden by a non-DEFERRED one. */
|
inherited DEFERRED binding is overridden by a non-DEFERRED one. */
|
|
|
static gfc_try
|
static gfc_try
|
ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
|
ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
|
{
|
{
|
if (!st)
|
if (!st)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
|
if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
|
if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (st->n.tb && st->n.tb->deferred)
|
if (st->n.tb && st->n.tb->deferred)
|
{
|
{
|
gfc_symtree* overriding;
|
gfc_symtree* overriding;
|
overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
|
overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
|
if (!overriding)
|
if (!overriding)
|
return FAILURE;
|
return FAILURE;
|
gcc_assert (overriding->n.tb);
|
gcc_assert (overriding->n.tb);
|
if (overriding->n.tb->deferred)
|
if (overriding->n.tb->deferred)
|
{
|
{
|
gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
|
gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
|
" '%s' is DEFERRED and not overridden",
|
" '%s' is DEFERRED and not overridden",
|
sub->name, &sub->declared_at, st->name);
|
sub->name, &sub->declared_at, st->name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
static gfc_try
|
static gfc_try
|
ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
|
ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
|
{
|
{
|
/* The algorithm used here is to recursively travel up the ancestry of sub
|
/* The algorithm used here is to recursively travel up the ancestry of sub
|
and for each ancestor-type, check all bindings. If any of them is
|
and for each ancestor-type, check all bindings. If any of them is
|
DEFERRED, look it up starting from sub and see if the found (overriding)
|
DEFERRED, look it up starting from sub and see if the found (overriding)
|
binding is not DEFERRED.
|
binding is not DEFERRED.
|
This is not the most efficient way to do this, but it should be ok and is
|
This is not the most efficient way to do this, but it should be ok and is
|
clearer than something sophisticated. */
|
clearer than something sophisticated. */
|
|
|
gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
|
gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
|
|
|
/* Walk bindings of this ancestor. */
|
/* Walk bindings of this ancestor. */
|
if (ancestor->f2k_derived)
|
if (ancestor->f2k_derived)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
|
t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
|
if (t == FAILURE)
|
if (t == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Find next ancestor type and recurse on it. */
|
/* Find next ancestor type and recurse on it. */
|
ancestor = gfc_get_derived_super_type (ancestor);
|
ancestor = gfc_get_derived_super_type (ancestor);
|
if (ancestor)
|
if (ancestor)
|
return ensure_not_abstract (sub, ancestor);
|
return ensure_not_abstract (sub, ancestor);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static void resolve_symbol (gfc_symbol *sym);
|
static void resolve_symbol (gfc_symbol *sym);
|
|
|
|
|
/* Resolve the components of a derived type. */
|
/* Resolve the components of a derived type. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_fl_derived (gfc_symbol *sym)
|
resolve_fl_derived (gfc_symbol *sym)
|
{
|
{
|
gfc_symbol* super_type;
|
gfc_symbol* super_type;
|
gfc_component *c;
|
gfc_component *c;
|
int i;
|
int i;
|
|
|
super_type = gfc_get_derived_super_type (sym);
|
super_type = gfc_get_derived_super_type (sym);
|
|
|
/* Ensure the extended type gets resolved before we do. */
|
/* Ensure the extended type gets resolved before we do. */
|
if (super_type && resolve_fl_derived (super_type) == FAILURE)
|
if (super_type && resolve_fl_derived (super_type) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* An ABSTRACT type must be extensible. */
|
/* An ABSTRACT type must be extensible. */
|
if (sym->attr.abstract && !gfc_type_is_extensible (sym))
|
if (sym->attr.abstract && !gfc_type_is_extensible (sym))
|
{
|
{
|
gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
|
gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
for (c = sym->components; c != NULL; c = c->next)
|
for (c = sym->components; c != NULL; c = c->next)
|
{
|
{
|
if (c->attr.proc_pointer && c->ts.interface)
|
if (c->attr.proc_pointer && c->ts.interface)
|
{
|
{
|
if (c->ts.interface->attr.procedure)
|
if (c->ts.interface->attr.procedure)
|
gfc_error ("Interface '%s', used by procedure pointer component "
|
gfc_error ("Interface '%s', used by procedure pointer component "
|
"'%s' at %L, is declared in a later PROCEDURE statement",
|
"'%s' at %L, is declared in a later PROCEDURE statement",
|
c->ts.interface->name, c->name, &c->loc);
|
c->ts.interface->name, c->name, &c->loc);
|
|
|
/* Get the attributes from the interface (now resolved). */
|
/* Get the attributes from the interface (now resolved). */
|
if (c->ts.interface->attr.if_source
|
if (c->ts.interface->attr.if_source
|
|| c->ts.interface->attr.intrinsic)
|
|| c->ts.interface->attr.intrinsic)
|
{
|
{
|
gfc_symbol *ifc = c->ts.interface;
|
gfc_symbol *ifc = c->ts.interface;
|
|
|
if (ifc->formal && !ifc->formal_ns)
|
if (ifc->formal && !ifc->formal_ns)
|
resolve_symbol (ifc);
|
resolve_symbol (ifc);
|
|
|
if (ifc->attr.intrinsic)
|
if (ifc->attr.intrinsic)
|
resolve_intrinsic (ifc, &ifc->declared_at);
|
resolve_intrinsic (ifc, &ifc->declared_at);
|
|
|
if (ifc->result)
|
if (ifc->result)
|
{
|
{
|
c->ts = ifc->result->ts;
|
c->ts = ifc->result->ts;
|
c->attr.allocatable = ifc->result->attr.allocatable;
|
c->attr.allocatable = ifc->result->attr.allocatable;
|
c->attr.pointer = ifc->result->attr.pointer;
|
c->attr.pointer = ifc->result->attr.pointer;
|
c->attr.dimension = ifc->result->attr.dimension;
|
c->attr.dimension = ifc->result->attr.dimension;
|
c->as = gfc_copy_array_spec (ifc->result->as);
|
c->as = gfc_copy_array_spec (ifc->result->as);
|
}
|
}
|
else
|
else
|
{
|
{
|
c->ts = ifc->ts;
|
c->ts = ifc->ts;
|
c->attr.allocatable = ifc->attr.allocatable;
|
c->attr.allocatable = ifc->attr.allocatable;
|
c->attr.pointer = ifc->attr.pointer;
|
c->attr.pointer = ifc->attr.pointer;
|
c->attr.dimension = ifc->attr.dimension;
|
c->attr.dimension = ifc->attr.dimension;
|
c->as = gfc_copy_array_spec (ifc->as);
|
c->as = gfc_copy_array_spec (ifc->as);
|
}
|
}
|
c->ts.interface = ifc;
|
c->ts.interface = ifc;
|
c->attr.function = ifc->attr.function;
|
c->attr.function = ifc->attr.function;
|
c->attr.subroutine = ifc->attr.subroutine;
|
c->attr.subroutine = ifc->attr.subroutine;
|
gfc_copy_formal_args_ppc (c, ifc);
|
gfc_copy_formal_args_ppc (c, ifc);
|
|
|
c->attr.pure = ifc->attr.pure;
|
c->attr.pure = ifc->attr.pure;
|
c->attr.elemental = ifc->attr.elemental;
|
c->attr.elemental = ifc->attr.elemental;
|
c->attr.recursive = ifc->attr.recursive;
|
c->attr.recursive = ifc->attr.recursive;
|
c->attr.always_explicit = ifc->attr.always_explicit;
|
c->attr.always_explicit = ifc->attr.always_explicit;
|
c->attr.ext_attr |= ifc->attr.ext_attr;
|
c->attr.ext_attr |= ifc->attr.ext_attr;
|
/* Replace symbols in array spec. */
|
/* Replace symbols in array spec. */
|
if (c->as)
|
if (c->as)
|
{
|
{
|
int i;
|
int i;
|
for (i = 0; i < c->as->rank; i++)
|
for (i = 0; i < c->as->rank; i++)
|
{
|
{
|
gfc_expr_replace_comp (c->as->lower[i], c);
|
gfc_expr_replace_comp (c->as->lower[i], c);
|
gfc_expr_replace_comp (c->as->upper[i], c);
|
gfc_expr_replace_comp (c->as->upper[i], c);
|
}
|
}
|
}
|
}
|
/* Copy char length. */
|
/* Copy char length. */
|
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
|
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
|
{
|
{
|
gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
|
gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
|
gfc_expr_replace_comp (cl->length, c);
|
gfc_expr_replace_comp (cl->length, c);
|
if (cl->length && !cl->resolved
|
if (cl->length && !cl->resolved
|
&& gfc_resolve_expr (cl->length) == FAILURE)
|
&& gfc_resolve_expr (cl->length) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
c->ts.u.cl = cl;
|
c->ts.u.cl = cl;
|
}
|
}
|
}
|
}
|
else if (c->ts.interface->name[0] != '\0')
|
else if (c->ts.interface->name[0] != '\0')
|
{
|
{
|
gfc_error ("Interface '%s' of procedure pointer component "
|
gfc_error ("Interface '%s' of procedure pointer component "
|
"'%s' at %L must be explicit", c->ts.interface->name,
|
"'%s' at %L must be explicit", c->ts.interface->name,
|
c->name, &c->loc);
|
c->name, &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
|
else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
|
{
|
{
|
/* Since PPCs are not implicitly typed, a PPC without an explicit
|
/* Since PPCs are not implicitly typed, a PPC without an explicit
|
interface must be a subroutine. */
|
interface must be a subroutine. */
|
gfc_add_subroutine (&c->attr, c->name, &c->loc);
|
gfc_add_subroutine (&c->attr, c->name, &c->loc);
|
}
|
}
|
|
|
/* Procedure pointer components: Check PASS arg. */
|
/* Procedure pointer components: Check PASS arg. */
|
if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
|
if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
|
{
|
{
|
gfc_symbol* me_arg;
|
gfc_symbol* me_arg;
|
|
|
if (c->tb->pass_arg)
|
if (c->tb->pass_arg)
|
{
|
{
|
gfc_formal_arglist* i;
|
gfc_formal_arglist* i;
|
|
|
/* If an explicit passing argument name is given, walk the arg-list
|
/* If an explicit passing argument name is given, walk the arg-list
|
and look for it. */
|
and look for it. */
|
|
|
me_arg = NULL;
|
me_arg = NULL;
|
c->tb->pass_arg_num = 1;
|
c->tb->pass_arg_num = 1;
|
for (i = c->formal; i; i = i->next)
|
for (i = c->formal; i; i = i->next)
|
{
|
{
|
if (!strcmp (i->sym->name, c->tb->pass_arg))
|
if (!strcmp (i->sym->name, c->tb->pass_arg))
|
{
|
{
|
me_arg = i->sym;
|
me_arg = i->sym;
|
break;
|
break;
|
}
|
}
|
c->tb->pass_arg_num++;
|
c->tb->pass_arg_num++;
|
}
|
}
|
|
|
if (!me_arg)
|
if (!me_arg)
|
{
|
{
|
gfc_error ("Procedure pointer component '%s' with PASS(%s) "
|
gfc_error ("Procedure pointer component '%s' with PASS(%s) "
|
"at %L has no argument '%s'", c->name,
|
"at %L has no argument '%s'", c->name,
|
c->tb->pass_arg, &c->loc, c->tb->pass_arg);
|
c->tb->pass_arg, &c->loc, c->tb->pass_arg);
|
c->tb->error = 1;
|
c->tb->error = 1;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Otherwise, take the first one; there should in fact be at least
|
/* Otherwise, take the first one; there should in fact be at least
|
one. */
|
one. */
|
c->tb->pass_arg_num = 1;
|
c->tb->pass_arg_num = 1;
|
if (!c->formal)
|
if (!c->formal)
|
{
|
{
|
gfc_error ("Procedure pointer component '%s' with PASS at %L "
|
gfc_error ("Procedure pointer component '%s' with PASS at %L "
|
"must have at least one argument",
|
"must have at least one argument",
|
c->name, &c->loc);
|
c->name, &c->loc);
|
c->tb->error = 1;
|
c->tb->error = 1;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
me_arg = c->formal->sym;
|
me_arg = c->formal->sym;
|
}
|
}
|
|
|
/* Now check that the argument-type matches. */
|
/* Now check that the argument-type matches. */
|
gcc_assert (me_arg);
|
gcc_assert (me_arg);
|
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
|
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
|
|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
|
|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
|
|| (me_arg->ts.type == BT_CLASS
|
|| (me_arg->ts.type == BT_CLASS
|
&& me_arg->ts.u.derived->components->ts.u.derived != sym))
|
&& me_arg->ts.u.derived->components->ts.u.derived != sym))
|
{
|
{
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
|
" the derived type '%s'", me_arg->name, c->name,
|
" the derived type '%s'", me_arg->name, c->name,
|
me_arg->name, &c->loc, sym->name);
|
me_arg->name, &c->loc, sym->name);
|
c->tb->error = 1;
|
c->tb->error = 1;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Check for C453. */
|
/* Check for C453. */
|
if (me_arg->attr.dimension)
|
if (me_arg->attr.dimension)
|
{
|
{
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
|
"must be scalar", me_arg->name, c->name, me_arg->name,
|
"must be scalar", me_arg->name, c->name, me_arg->name,
|
&c->loc);
|
&c->loc);
|
c->tb->error = 1;
|
c->tb->error = 1;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (me_arg->attr.pointer)
|
if (me_arg->attr.pointer)
|
{
|
{
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
|
"may not have the POINTER attribute", me_arg->name,
|
"may not have the POINTER attribute", me_arg->name,
|
c->name, me_arg->name, &c->loc);
|
c->name, me_arg->name, &c->loc);
|
c->tb->error = 1;
|
c->tb->error = 1;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (me_arg->attr.allocatable)
|
if (me_arg->attr.allocatable)
|
{
|
{
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
|
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
|
"may not be ALLOCATABLE", me_arg->name, c->name,
|
"may not be ALLOCATABLE", me_arg->name, c->name,
|
me_arg->name, &c->loc);
|
me_arg->name, &c->loc);
|
c->tb->error = 1;
|
c->tb->error = 1;
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
|
if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
|
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
|
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
|
" at %L", c->name, &c->loc);
|
" at %L", c->name, &c->loc);
|
|
|
}
|
}
|
|
|
/* Check type-spec if this is not the parent-type component. */
|
/* Check type-spec if this is not the parent-type component. */
|
if ((!sym->attr.extension || c != sym->components)
|
if ((!sym->attr.extension || c != sym->components)
|
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
|
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* If this type is an extension, set the accessibility of the parent
|
/* If this type is an extension, set the accessibility of the parent
|
component. */
|
component. */
|
if (super_type && c == sym->components
|
if (super_type && c == sym->components
|
&& strcmp (super_type->name, c->name) == 0)
|
&& strcmp (super_type->name, c->name) == 0)
|
c->attr.access = super_type->attr.access;
|
c->attr.access = super_type->attr.access;
|
|
|
/* If this type is an extension, see if this component has the same name
|
/* If this type is an extension, see if this component has the same name
|
as an inherited type-bound procedure. */
|
as an inherited type-bound procedure. */
|
if (super_type
|
if (super_type
|
&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
|
&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
|
{
|
{
|
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
|
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
|
" inherited type-bound procedure",
|
" inherited type-bound procedure",
|
c->name, sym->name, &c->loc);
|
c->name, sym->name, &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
|
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
|
{
|
{
|
if (c->ts.u.cl->length == NULL
|
if (c->ts.u.cl->length == NULL
|
|| (resolve_charlen (c->ts.u.cl) == FAILURE)
|
|| (resolve_charlen (c->ts.u.cl) == FAILURE)
|
|| !gfc_is_constant_expr (c->ts.u.cl->length))
|
|| !gfc_is_constant_expr (c->ts.u.cl->length))
|
{
|
{
|
gfc_error ("Character length of component '%s' needs to "
|
gfc_error ("Character length of component '%s' needs to "
|
"be a constant specification expression at %L",
|
"be a constant specification expression at %L",
|
c->name,
|
c->name,
|
c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
|
c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
if (c->ts.type == BT_DERIVED
|
if (c->ts.type == BT_DERIVED
|
&& sym->component_access != ACCESS_PRIVATE
|
&& sym->component_access != ACCESS_PRIVATE
|
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
|
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
|
&& !is_sym_host_assoc (c->ts.u.derived, sym->ns)
|
&& !is_sym_host_assoc (c->ts.u.derived, sym->ns)
|
&& !c->ts.u.derived->attr.use_assoc
|
&& !c->ts.u.derived->attr.use_assoc
|
&& !gfc_check_access (c->ts.u.derived->attr.access,
|
&& !gfc_check_access (c->ts.u.derived->attr.access,
|
c->ts.u.derived->ns->default_access)
|
c->ts.u.derived->ns->default_access)
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
|
"is a PRIVATE type and cannot be a component of "
|
"is a PRIVATE type and cannot be a component of "
|
"'%s', which is PUBLIC at %L", c->name,
|
"'%s', which is PUBLIC at %L", c->name,
|
sym->name, &sym->declared_at) == FAILURE)
|
sym->name, &sym->declared_at) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (sym->attr.sequence)
|
if (sym->attr.sequence)
|
{
|
{
|
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
|
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
|
{
|
{
|
gfc_error ("Component %s of SEQUENCE type declared at %L does "
|
gfc_error ("Component %s of SEQUENCE type declared at %L does "
|
"not have the SEQUENCE attribute",
|
"not have the SEQUENCE attribute",
|
c->ts.u.derived->name, &sym->declared_at);
|
c->ts.u.derived->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
if (c->ts.type == BT_DERIVED && c->attr.pointer
|
if (c->ts.type == BT_DERIVED && c->attr.pointer
|
&& c->ts.u.derived->components == NULL
|
&& c->ts.u.derived->components == NULL
|
&& !c->ts.u.derived->attr.zero_comp)
|
&& !c->ts.u.derived->attr.zero_comp)
|
{
|
{
|
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
|
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
|
"that has not been declared", c->name, sym->name,
|
"that has not been declared", c->name, sym->name,
|
&c->loc);
|
&c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* C437. */
|
/* C437. */
|
if (c->ts.type == BT_CLASS
|
if (c->ts.type == BT_CLASS
|
&& !(c->ts.u.derived->components->attr.pointer
|
&& !(c->ts.u.derived->components->attr.pointer
|
|| c->ts.u.derived->components->attr.allocatable))
|
|| c->ts.u.derived->components->attr.allocatable))
|
{
|
{
|
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
|
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
|
"or pointer", c->name, &c->loc);
|
"or pointer", c->name, &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Ensure that all the derived type components are put on the
|
/* Ensure that all the derived type components are put on the
|
derived type list; even in formal namespaces, where derived type
|
derived type list; even in formal namespaces, where derived type
|
pointer components might not have been declared. */
|
pointer components might not have been declared. */
|
if (c->ts.type == BT_DERIVED
|
if (c->ts.type == BT_DERIVED
|
&& c->ts.u.derived
|
&& c->ts.u.derived
|
&& c->ts.u.derived->components
|
&& c->ts.u.derived->components
|
&& c->attr.pointer
|
&& c->attr.pointer
|
&& sym != c->ts.u.derived)
|
&& sym != c->ts.u.derived)
|
add_dt_to_dt_list (c->ts.u.derived);
|
add_dt_to_dt_list (c->ts.u.derived);
|
|
|
if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
|
if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
|
|| c->as == NULL)
|
|| c->as == NULL)
|
continue;
|
continue;
|
|
|
for (i = 0; i < c->as->rank; i++)
|
for (i = 0; i < c->as->rank; i++)
|
{
|
{
|
if (c->as->lower[i] == NULL
|
if (c->as->lower[i] == NULL
|
|| (resolve_index_expr (c->as->lower[i]) == FAILURE)
|
|| (resolve_index_expr (c->as->lower[i]) == FAILURE)
|
|| !gfc_is_constant_expr (c->as->lower[i])
|
|| !gfc_is_constant_expr (c->as->lower[i])
|
|| c->as->upper[i] == NULL
|
|| c->as->upper[i] == NULL
|
|| (resolve_index_expr (c->as->upper[i]) == FAILURE)
|
|| (resolve_index_expr (c->as->upper[i]) == FAILURE)
|
|| !gfc_is_constant_expr (c->as->upper[i]))
|
|| !gfc_is_constant_expr (c->as->upper[i]))
|
{
|
{
|
gfc_error ("Component '%s' of '%s' at %L must have "
|
gfc_error ("Component '%s' of '%s' at %L must have "
|
"constant array bounds",
|
"constant array bounds",
|
c->name, sym->name, &c->loc);
|
c->name, sym->name, &c->loc);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* Resolve the type-bound procedures. */
|
/* Resolve the type-bound procedures. */
|
if (resolve_typebound_procedures (sym) == FAILURE)
|
if (resolve_typebound_procedures (sym) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Resolve the finalizer procedures. */
|
/* Resolve the finalizer procedures. */
|
if (gfc_resolve_finalizers (sym) == FAILURE)
|
if (gfc_resolve_finalizers (sym) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
|
/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
|
all DEFERRED bindings are overridden. */
|
all DEFERRED bindings are overridden. */
|
if (super_type && super_type->attr.abstract && !sym->attr.abstract
|
if (super_type && super_type->attr.abstract && !sym->attr.abstract
|
&& ensure_not_abstract (sym, super_type) == FAILURE)
|
&& ensure_not_abstract (sym, super_type) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Add derived type to the derived type list. */
|
/* Add derived type to the derived type list. */
|
add_dt_to_dt_list (sym);
|
add_dt_to_dt_list (sym);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
resolve_fl_namelist (gfc_symbol *sym)
|
resolve_fl_namelist (gfc_symbol *sym)
|
{
|
{
|
gfc_namelist *nl;
|
gfc_namelist *nl;
|
gfc_symbol *nlsym;
|
gfc_symbol *nlsym;
|
|
|
/* Reject PRIVATE objects in a PUBLIC namelist. */
|
/* Reject PRIVATE objects in a PUBLIC namelist. */
|
if (gfc_check_access(sym->attr.access, sym->ns->default_access))
|
if (gfc_check_access(sym->attr.access, sym->ns->default_access))
|
{
|
{
|
for (nl = sym->namelist; nl; nl = nl->next)
|
for (nl = sym->namelist; nl; nl = nl->next)
|
{
|
{
|
if (!nl->sym->attr.use_assoc
|
if (!nl->sym->attr.use_assoc
|
&& !is_sym_host_assoc (nl->sym, sym->ns)
|
&& !is_sym_host_assoc (nl->sym, sym->ns)
|
&& !gfc_check_access(nl->sym->attr.access,
|
&& !gfc_check_access(nl->sym->attr.access,
|
nl->sym->ns->default_access))
|
nl->sym->ns->default_access))
|
{
|
{
|
gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
|
gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
|
"cannot be member of PUBLIC namelist '%s' at %L",
|
"cannot be member of PUBLIC namelist '%s' at %L",
|
nl->sym->name, sym->name, &sym->declared_at);
|
nl->sym->name, sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Types with private components that came here by USE-association. */
|
/* Types with private components that came here by USE-association. */
|
if (nl->sym->ts.type == BT_DERIVED
|
if (nl->sym->ts.type == BT_DERIVED
|
&& derived_inaccessible (nl->sym->ts.u.derived))
|
&& derived_inaccessible (nl->sym->ts.u.derived))
|
{
|
{
|
gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
|
gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
|
"components and cannot be member of namelist '%s' at %L",
|
"components and cannot be member of namelist '%s' at %L",
|
nl->sym->name, sym->name, &sym->declared_at);
|
nl->sym->name, sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Types with private components that are defined in the same module. */
|
/* Types with private components that are defined in the same module. */
|
if (nl->sym->ts.type == BT_DERIVED
|
if (nl->sym->ts.type == BT_DERIVED
|
&& !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
|
&& !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
|
&& !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
|
&& !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
|
? ACCESS_PRIVATE : ACCESS_UNKNOWN,
|
? ACCESS_PRIVATE : ACCESS_UNKNOWN,
|
nl->sym->ns->default_access))
|
nl->sym->ns->default_access))
|
{
|
{
|
gfc_error ("NAMELIST object '%s' has PRIVATE components and "
|
gfc_error ("NAMELIST object '%s' has PRIVATE components and "
|
"cannot be a member of PUBLIC namelist '%s' at %L",
|
"cannot be a member of PUBLIC namelist '%s' at %L",
|
nl->sym->name, sym->name, &sym->declared_at);
|
nl->sym->name, sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
for (nl = sym->namelist; nl; nl = nl->next)
|
for (nl = sym->namelist; nl; nl = nl->next)
|
{
|
{
|
/* Reject namelist arrays of assumed shape. */
|
/* Reject namelist arrays of assumed shape. */
|
if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
|
if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
|
&& gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
|
&& gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
|
"must not have assumed shape in namelist "
|
"must not have assumed shape in namelist "
|
"'%s' at %L", nl->sym->name, sym->name,
|
"'%s' at %L", nl->sym->name, sym->name,
|
&sym->declared_at) == FAILURE)
|
&sym->declared_at) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Reject namelist arrays that are not constant shape. */
|
/* Reject namelist arrays that are not constant shape. */
|
if (is_non_constant_shape_array (nl->sym))
|
if (is_non_constant_shape_array (nl->sym))
|
{
|
{
|
gfc_error ("NAMELIST array object '%s' must have constant "
|
gfc_error ("NAMELIST array object '%s' must have constant "
|
"shape in namelist '%s' at %L", nl->sym->name,
|
"shape in namelist '%s' at %L", nl->sym->name,
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Namelist objects cannot have allocatable or pointer components. */
|
/* Namelist objects cannot have allocatable or pointer components. */
|
if (nl->sym->ts.type != BT_DERIVED)
|
if (nl->sym->ts.type != BT_DERIVED)
|
continue;
|
continue;
|
|
|
if (nl->sym->ts.u.derived->attr.alloc_comp)
|
if (nl->sym->ts.u.derived->attr.alloc_comp)
|
{
|
{
|
gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
|
gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
|
"have ALLOCATABLE components",
|
"have ALLOCATABLE components",
|
nl->sym->name, sym->name, &sym->declared_at);
|
nl->sym->name, sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (nl->sym->ts.u.derived->attr.pointer_comp)
|
if (nl->sym->ts.u.derived->attr.pointer_comp)
|
{
|
{
|
gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
|
gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
|
"have POINTER components",
|
"have POINTER components",
|
nl->sym->name, sym->name, &sym->declared_at);
|
nl->sym->name, sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* 14.1.2 A module or internal procedure represent local entities
|
/* 14.1.2 A module or internal procedure represent local entities
|
of the same type as a namelist member and so are not allowed. */
|
of the same type as a namelist member and so are not allowed. */
|
for (nl = sym->namelist; nl; nl = nl->next)
|
for (nl = sym->namelist; nl; nl = nl->next)
|
{
|
{
|
if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
|
if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
|
continue;
|
continue;
|
|
|
if (nl->sym->attr.function && nl->sym == nl->sym->result)
|
if (nl->sym->attr.function && nl->sym == nl->sym->result)
|
if ((nl->sym == sym->ns->proc_name)
|
if ((nl->sym == sym->ns->proc_name)
|
||
|
||
|
(sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
|
(sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
|
continue;
|
continue;
|
|
|
nlsym = NULL;
|
nlsym = NULL;
|
if (nl->sym && nl->sym->name)
|
if (nl->sym && nl->sym->name)
|
gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
|
gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
|
if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
|
if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
|
{
|
{
|
gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
|
gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
|
"attribute in '%s' at %L", nlsym->name,
|
"attribute in '%s' at %L", nlsym->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
resolve_fl_parameter (gfc_symbol *sym)
|
resolve_fl_parameter (gfc_symbol *sym)
|
{
|
{
|
/* A parameter array's shape needs to be constant. */
|
/* A parameter array's shape needs to be constant. */
|
if (sym->as != NULL
|
if (sym->as != NULL
|
&& (sym->as->type == AS_DEFERRED
|
&& (sym->as->type == AS_DEFERRED
|
|| is_non_constant_shape_array (sym)))
|
|| is_non_constant_shape_array (sym)))
|
{
|
{
|
gfc_error ("Parameter array '%s' at %L cannot be automatic "
|
gfc_error ("Parameter array '%s' at %L cannot be automatic "
|
"or of deferred shape", sym->name, &sym->declared_at);
|
"or of deferred shape", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Make sure a parameter that has been implicitly typed still
|
/* Make sure a parameter that has been implicitly typed still
|
matches the implicit type, since PARAMETER statements can precede
|
matches the implicit type, since PARAMETER statements can precede
|
IMPLICIT statements. */
|
IMPLICIT statements. */
|
if (sym->attr.implicit_type
|
if (sym->attr.implicit_type
|
&& !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
|
&& !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
|
sym->ns)))
|
sym->ns)))
|
{
|
{
|
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
|
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
|
"later IMPLICIT type", sym->name, &sym->declared_at);
|
"later IMPLICIT type", sym->name, &sym->declared_at);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Make sure the types of derived parameters are consistent. This
|
/* Make sure the types of derived parameters are consistent. This
|
type checking is deferred until resolution because the type may
|
type checking is deferred until resolution because the type may
|
refer to a derived type from the host. */
|
refer to a derived type from the host. */
|
if (sym->ts.type == BT_DERIVED
|
if (sym->ts.type == BT_DERIVED
|
&& !gfc_compare_types (&sym->ts, &sym->value->ts))
|
&& !gfc_compare_types (&sym->ts, &sym->value->ts))
|
{
|
{
|
gfc_error ("Incompatible derived type in PARAMETER at %L",
|
gfc_error ("Incompatible derived type in PARAMETER at %L",
|
&sym->value->where);
|
&sym->value->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Do anything necessary to resolve a symbol. Right now, we just
|
/* Do anything necessary to resolve a symbol. Right now, we just
|
assume that an otherwise unknown symbol is a variable. This sort
|
assume that an otherwise unknown symbol is a variable. This sort
|
of thing commonly happens for symbols in module. */
|
of thing commonly happens for symbols in module. */
|
|
|
static void
|
static void
|
resolve_symbol (gfc_symbol *sym)
|
resolve_symbol (gfc_symbol *sym)
|
{
|
{
|
int check_constant, mp_flag;
|
int check_constant, mp_flag;
|
gfc_symtree *symtree;
|
gfc_symtree *symtree;
|
gfc_symtree *this_symtree;
|
gfc_symtree *this_symtree;
|
gfc_namespace *ns;
|
gfc_namespace *ns;
|
gfc_component *c;
|
gfc_component *c;
|
|
|
if (sym->attr.flavor == FL_UNKNOWN)
|
if (sym->attr.flavor == FL_UNKNOWN)
|
{
|
{
|
|
|
/* If we find that a flavorless symbol is an interface in one of the
|
/* If we find that a flavorless symbol is an interface in one of the
|
parent namespaces, find its symtree in this namespace, free the
|
parent namespaces, find its symtree in this namespace, free the
|
symbol and set the symtree to point to the interface symbol. */
|
symbol and set the symtree to point to the interface symbol. */
|
for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
|
for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
|
{
|
{
|
symtree = gfc_find_symtree (ns->sym_root, sym->name);
|
symtree = gfc_find_symtree (ns->sym_root, sym->name);
|
if (symtree && symtree->n.sym->generic)
|
if (symtree && symtree->n.sym->generic)
|
{
|
{
|
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
|
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
|
sym->name);
|
sym->name);
|
sym->refs--;
|
sym->refs--;
|
if (!sym->refs)
|
if (!sym->refs)
|
gfc_free_symbol (sym);
|
gfc_free_symbol (sym);
|
symtree->n.sym->refs++;
|
symtree->n.sym->refs++;
|
this_symtree->n.sym = symtree->n.sym;
|
this_symtree->n.sym = symtree->n.sym;
|
return;
|
return;
|
}
|
}
|
}
|
}
|
|
|
/* Otherwise give it a flavor according to such attributes as
|
/* Otherwise give it a flavor according to such attributes as
|
it has. */
|
it has. */
|
if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
|
if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
|
sym->attr.flavor = FL_VARIABLE;
|
sym->attr.flavor = FL_VARIABLE;
|
else
|
else
|
{
|
{
|
sym->attr.flavor = FL_PROCEDURE;
|
sym->attr.flavor = FL_PROCEDURE;
|
if (sym->attr.dimension)
|
if (sym->attr.dimension)
|
sym->attr.function = 1;
|
sym->attr.function = 1;
|
}
|
}
|
}
|
}
|
|
|
if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
|
if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
|
gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
|
gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
|
|
|
if (sym->attr.procedure && sym->ts.interface
|
if (sym->attr.procedure && sym->ts.interface
|
&& sym->attr.if_source != IFSRC_DECL)
|
&& sym->attr.if_source != IFSRC_DECL)
|
{
|
{
|
if (sym->ts.interface == sym)
|
if (sym->ts.interface == sym)
|
{
|
{
|
gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
|
gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
|
"interface", sym->name, &sym->declared_at);
|
"interface", sym->name, &sym->declared_at);
|
return;
|
return;
|
}
|
}
|
if (sym->ts.interface->attr.procedure)
|
if (sym->ts.interface->attr.procedure)
|
{
|
{
|
gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
|
gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
|
" in a later PROCEDURE statement", sym->ts.interface->name,
|
" in a later PROCEDURE statement", sym->ts.interface->name,
|
sym->name,&sym->declared_at);
|
sym->name,&sym->declared_at);
|
return;
|
return;
|
}
|
}
|
|
|
/* Get the attributes from the interface (now resolved). */
|
/* Get the attributes from the interface (now resolved). */
|
if (sym->ts.interface->attr.if_source
|
if (sym->ts.interface->attr.if_source
|
|| sym->ts.interface->attr.intrinsic)
|
|| sym->ts.interface->attr.intrinsic)
|
{
|
{
|
gfc_symbol *ifc = sym->ts.interface;
|
gfc_symbol *ifc = sym->ts.interface;
|
resolve_symbol (ifc);
|
resolve_symbol (ifc);
|
|
|
if (ifc->attr.intrinsic)
|
if (ifc->attr.intrinsic)
|
resolve_intrinsic (ifc, &ifc->declared_at);
|
resolve_intrinsic (ifc, &ifc->declared_at);
|
|
|
if (ifc->result)
|
if (ifc->result)
|
sym->ts = ifc->result->ts;
|
sym->ts = ifc->result->ts;
|
else
|
else
|
sym->ts = ifc->ts;
|
sym->ts = ifc->ts;
|
sym->ts.interface = ifc;
|
sym->ts.interface = ifc;
|
sym->attr.function = ifc->attr.function;
|
sym->attr.function = ifc->attr.function;
|
sym->attr.subroutine = ifc->attr.subroutine;
|
sym->attr.subroutine = ifc->attr.subroutine;
|
gfc_copy_formal_args (sym, ifc);
|
gfc_copy_formal_args (sym, ifc);
|
|
|
sym->attr.allocatable = ifc->attr.allocatable;
|
sym->attr.allocatable = ifc->attr.allocatable;
|
sym->attr.pointer = ifc->attr.pointer;
|
sym->attr.pointer = ifc->attr.pointer;
|
sym->attr.pure = ifc->attr.pure;
|
sym->attr.pure = ifc->attr.pure;
|
sym->attr.elemental = ifc->attr.elemental;
|
sym->attr.elemental = ifc->attr.elemental;
|
sym->attr.dimension = ifc->attr.dimension;
|
sym->attr.dimension = ifc->attr.dimension;
|
sym->attr.recursive = ifc->attr.recursive;
|
sym->attr.recursive = ifc->attr.recursive;
|
sym->attr.always_explicit = ifc->attr.always_explicit;
|
sym->attr.always_explicit = ifc->attr.always_explicit;
|
sym->attr.ext_attr |= ifc->attr.ext_attr;
|
sym->attr.ext_attr |= ifc->attr.ext_attr;
|
/* Copy array spec. */
|
/* Copy array spec. */
|
sym->as = gfc_copy_array_spec (ifc->as);
|
sym->as = gfc_copy_array_spec (ifc->as);
|
if (sym->as)
|
if (sym->as)
|
{
|
{
|
int i;
|
int i;
|
for (i = 0; i < sym->as->rank; i++)
|
for (i = 0; i < sym->as->rank; i++)
|
{
|
{
|
gfc_expr_replace_symbols (sym->as->lower[i], sym);
|
gfc_expr_replace_symbols (sym->as->lower[i], sym);
|
gfc_expr_replace_symbols (sym->as->upper[i], sym);
|
gfc_expr_replace_symbols (sym->as->upper[i], sym);
|
}
|
}
|
}
|
}
|
/* Copy char length. */
|
/* Copy char length. */
|
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
|
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
|
{
|
{
|
sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
|
sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
|
gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
|
gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
|
if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
|
if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
|
&& gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
|
&& gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
|
return;
|
return;
|
}
|
}
|
}
|
}
|
else if (sym->ts.interface->name[0] != '\0')
|
else if (sym->ts.interface->name[0] != '\0')
|
{
|
{
|
gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
|
gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
|
sym->ts.interface->name, sym->name, &sym->declared_at);
|
sym->ts.interface->name, sym->name, &sym->declared_at);
|
return;
|
return;
|
}
|
}
|
}
|
}
|
|
|
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
|
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
|
return;
|
return;
|
|
|
/* Symbols that are module procedures with results (functions) have
|
/* Symbols that are module procedures with results (functions) have
|
the types and array specification copied for type checking in
|
the types and array specification copied for type checking in
|
procedures that call them, as well as for saving to a module
|
procedures that call them, as well as for saving to a module
|
file. These symbols can't stand the scrutiny that their results
|
file. These symbols can't stand the scrutiny that their results
|
can. */
|
can. */
|
mp_flag = (sym->result != NULL && sym->result != sym);
|
mp_flag = (sym->result != NULL && sym->result != sym);
|
|
|
|
|
/* Make sure that the intrinsic is consistent with its internal
|
/* Make sure that the intrinsic is consistent with its internal
|
representation. This needs to be done before assigning a default
|
representation. This needs to be done before assigning a default
|
type to avoid spurious warnings. */
|
type to avoid spurious warnings. */
|
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
|
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
|
&& resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
|
&& resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
|
return;
|
return;
|
|
|
/* Assign default type to symbols that need one and don't have one. */
|
/* Assign default type to symbols that need one and don't have one. */
|
if (sym->ts.type == BT_UNKNOWN)
|
if (sym->ts.type == BT_UNKNOWN)
|
{
|
{
|
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
|
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
|
gfc_set_default_type (sym, 1, NULL);
|
gfc_set_default_type (sym, 1, NULL);
|
|
|
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
|
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
|
&& !sym->attr.function && !sym->attr.subroutine
|
&& !sym->attr.function && !sym->attr.subroutine
|
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
|
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
|
gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
|
gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
|
|
|
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
|
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
|
{
|
{
|
/* The specific case of an external procedure should emit an error
|
/* The specific case of an external procedure should emit an error
|
in the case that there is no implicit type. */
|
in the case that there is no implicit type. */
|
if (!mp_flag)
|
if (!mp_flag)
|
gfc_set_default_type (sym, sym->attr.external, NULL);
|
gfc_set_default_type (sym, sym->attr.external, NULL);
|
else
|
else
|
{
|
{
|
/* Result may be in another namespace. */
|
/* Result may be in another namespace. */
|
resolve_symbol (sym->result);
|
resolve_symbol (sym->result);
|
|
|
if (!sym->result->attr.proc_pointer)
|
if (!sym->result->attr.proc_pointer)
|
{
|
{
|
sym->ts = sym->result->ts;
|
sym->ts = sym->result->ts;
|
sym->as = gfc_copy_array_spec (sym->result->as);
|
sym->as = gfc_copy_array_spec (sym->result->as);
|
sym->attr.dimension = sym->result->attr.dimension;
|
sym->attr.dimension = sym->result->attr.dimension;
|
sym->attr.pointer = sym->result->attr.pointer;
|
sym->attr.pointer = sym->result->attr.pointer;
|
sym->attr.allocatable = sym->result->attr.allocatable;
|
sym->attr.allocatable = sym->result->attr.allocatable;
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/* Assumed size arrays and assumed shape arrays must be dummy
|
/* Assumed size arrays and assumed shape arrays must be dummy
|
arguments. */
|
arguments. */
|
|
|
if (sym->as != NULL
|
if (sym->as != NULL
|
&& ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
|
&& ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
|
|| sym->as->type == AS_ASSUMED_SHAPE)
|
|| sym->as->type == AS_ASSUMED_SHAPE)
|
&& sym->attr.dummy == 0)
|
&& sym->attr.dummy == 0)
|
{
|
{
|
if (sym->as->type == AS_ASSUMED_SIZE)
|
if (sym->as->type == AS_ASSUMED_SIZE)
|
gfc_error ("Assumed size array at %L must be a dummy argument",
|
gfc_error ("Assumed size array at %L must be a dummy argument",
|
&sym->declared_at);
|
&sym->declared_at);
|
else
|
else
|
gfc_error ("Assumed shape array at %L must be a dummy argument",
|
gfc_error ("Assumed shape array at %L must be a dummy argument",
|
&sym->declared_at);
|
&sym->declared_at);
|
return;
|
return;
|
}
|
}
|
|
|
/* Make sure symbols with known intent or optional are really dummy
|
/* Make sure symbols with known intent or optional are really dummy
|
variable. Because of ENTRY statement, this has to be deferred
|
variable. Because of ENTRY statement, this has to be deferred
|
until resolution time. */
|
until resolution time. */
|
|
|
if (!sym->attr.dummy
|
if (!sym->attr.dummy
|
&& (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
|
&& (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
|
{
|
{
|
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
|
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
|
return;
|
return;
|
}
|
}
|
|
|
if (sym->attr.value && !sym->attr.dummy)
|
if (sym->attr.value && !sym->attr.dummy)
|
{
|
{
|
gfc_error ("'%s' at %L cannot have the VALUE attribute because "
|
gfc_error ("'%s' at %L cannot have the VALUE attribute because "
|
"it is not a dummy argument", sym->name, &sym->declared_at);
|
"it is not a dummy argument", sym->name, &sym->declared_at);
|
return;
|
return;
|
}
|
}
|
|
|
if (sym->attr.value && sym->ts.type == BT_CHARACTER)
|
if (sym->attr.value && sym->ts.type == BT_CHARACTER)
|
{
|
{
|
gfc_charlen *cl = sym->ts.u.cl;
|
gfc_charlen *cl = sym->ts.u.cl;
|
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
|
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("Character dummy variable '%s' at %L with VALUE "
|
gfc_error ("Character dummy variable '%s' at %L with VALUE "
|
"attribute must have constant length",
|
"attribute must have constant length",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return;
|
return;
|
}
|
}
|
|
|
if (sym->ts.is_c_interop
|
if (sym->ts.is_c_interop
|
&& mpz_cmp_si (cl->length->value.integer, 1) != 0)
|
&& mpz_cmp_si (cl->length->value.integer, 1) != 0)
|
{
|
{
|
gfc_error ("C interoperable character dummy variable '%s' at %L "
|
gfc_error ("C interoperable character dummy variable '%s' at %L "
|
"with VALUE attribute must have length one",
|
"with VALUE attribute must have length one",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return;
|
return;
|
}
|
}
|
}
|
}
|
|
|
/* If the symbol is marked as bind(c), verify it's type and kind. Do not
|
/* If the symbol is marked as bind(c), verify it's type and kind. Do not
|
do this for something that was implicitly typed because that is handled
|
do this for something that was implicitly typed because that is handled
|
in gfc_set_default_type. Handle dummy arguments and procedure
|
in gfc_set_default_type. Handle dummy arguments and procedure
|
definitions separately. Also, anything that is use associated is not
|
definitions separately. Also, anything that is use associated is not
|
handled here but instead is handled in the module it is declared in.
|
handled here but instead is handled in the module it is declared in.
|
Finally, derived type definitions are allowed to be BIND(C) since that
|
Finally, derived type definitions are allowed to be BIND(C) since that
|
only implies that they're interoperable, and they are checked fully for
|
only implies that they're interoperable, and they are checked fully for
|
interoperability when a variable is declared of that type. */
|
interoperability when a variable is declared of that type. */
|
if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
|
if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
|
sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
|
sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
|
sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
|
sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
|
{
|
{
|
gfc_try t = SUCCESS;
|
gfc_try t = SUCCESS;
|
|
|
/* First, make sure the variable is declared at the
|
/* First, make sure the variable is declared at the
|
module-level scope (J3/04-007, Section 15.3). */
|
module-level scope (J3/04-007, Section 15.3). */
|
if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
|
if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
|
sym->attr.in_common == 0)
|
sym->attr.in_common == 0)
|
{
|
{
|
gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
|
gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
|
"is neither a COMMON block nor declared at the "
|
"is neither a COMMON block nor declared at the "
|
"module level scope", sym->name, &(sym->declared_at));
|
"module level scope", sym->name, &(sym->declared_at));
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
else if (sym->common_head != NULL)
|
else if (sym->common_head != NULL)
|
{
|
{
|
t = verify_com_block_vars_c_interop (sym->common_head);
|
t = verify_com_block_vars_c_interop (sym->common_head);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* If type() declaration, we need to verify that the components
|
/* If type() declaration, we need to verify that the components
|
of the given type are all C interoperable, etc. */
|
of the given type are all C interoperable, etc. */
|
if (sym->ts.type == BT_DERIVED &&
|
if (sym->ts.type == BT_DERIVED &&
|
sym->ts.u.derived->attr.is_c_interop != 1)
|
sym->ts.u.derived->attr.is_c_interop != 1)
|
{
|
{
|
/* Make sure the user marked the derived type as BIND(C). If
|
/* Make sure the user marked the derived type as BIND(C). If
|
not, call the verify routine. This could print an error
|
not, call the verify routine. This could print an error
|
for the derived type more than once if multiple variables
|
for the derived type more than once if multiple variables
|
of that type are declared. */
|
of that type are declared. */
|
if (sym->ts.u.derived->attr.is_bind_c != 1)
|
if (sym->ts.u.derived->attr.is_bind_c != 1)
|
verify_bind_c_derived_type (sym->ts.u.derived);
|
verify_bind_c_derived_type (sym->ts.u.derived);
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
|
|
/* Verify the variable itself as C interoperable if it
|
/* Verify the variable itself as C interoperable if it
|
is BIND(C). It is not possible for this to succeed if
|
is BIND(C). It is not possible for this to succeed if
|
the verify_bind_c_derived_type failed, so don't have to handle
|
the verify_bind_c_derived_type failed, so don't have to handle
|
any error returned by verify_bind_c_derived_type. */
|
any error returned by verify_bind_c_derived_type. */
|
t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
|
t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
|
sym->common_block);
|
sym->common_block);
|
}
|
}
|
|
|
if (t == FAILURE)
|
if (t == FAILURE)
|
{
|
{
|
/* clear the is_bind_c flag to prevent reporting errors more than
|
/* clear the is_bind_c flag to prevent reporting errors more than
|
once if something failed. */
|
once if something failed. */
|
sym->attr.is_bind_c = 0;
|
sym->attr.is_bind_c = 0;
|
return;
|
return;
|
}
|
}
|
}
|
}
|
|
|
/* If a derived type symbol has reached this point, without its
|
/* If a derived type symbol has reached this point, without its
|
type being declared, we have an error. Notice that most
|
type being declared, we have an error. Notice that most
|
conditions that produce undefined derived types have already
|
conditions that produce undefined derived types have already
|
been dealt with. However, the likes of:
|
been dealt with. However, the likes of:
|
implicit type(t) (t) ..... call foo (t) will get us here if
|
implicit type(t) (t) ..... call foo (t) will get us here if
|
the type is not declared in the scope of the implicit
|
the type is not declared in the scope of the implicit
|
statement. Change the type to BT_UNKNOWN, both because it is so
|
statement. Change the type to BT_UNKNOWN, both because it is so
|
and to prevent an ICE. */
|
and to prevent an ICE. */
|
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
|
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
|
&& !sym->ts.u.derived->attr.zero_comp)
|
&& !sym->ts.u.derived->attr.zero_comp)
|
{
|
{
|
gfc_error ("The derived type '%s' at %L is of type '%s', "
|
gfc_error ("The derived type '%s' at %L is of type '%s', "
|
"which has not been defined", sym->name,
|
"which has not been defined", sym->name,
|
&sym->declared_at, sym->ts.u.derived->name);
|
&sym->declared_at, sym->ts.u.derived->name);
|
sym->ts.type = BT_UNKNOWN;
|
sym->ts.type = BT_UNKNOWN;
|
return;
|
return;
|
}
|
}
|
|
|
/* Make sure that the derived type has been resolved and that the
|
/* Make sure that the derived type has been resolved and that the
|
derived type is visible in the symbol's namespace, if it is a
|
derived type is visible in the symbol's namespace, if it is a
|
module function and is not PRIVATE. */
|
module function and is not PRIVATE. */
|
if (sym->ts.type == BT_DERIVED
|
if (sym->ts.type == BT_DERIVED
|
&& sym->ts.u.derived->attr.use_assoc
|
&& sym->ts.u.derived->attr.use_assoc
|
&& sym->ns->proc_name
|
&& sym->ns->proc_name
|
&& sym->ns->proc_name->attr.flavor == FL_MODULE)
|
&& sym->ns->proc_name->attr.flavor == FL_MODULE)
|
{
|
{
|
gfc_symbol *ds;
|
gfc_symbol *ds;
|
|
|
if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
|
if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
|
return;
|
return;
|
|
|
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
|
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
|
if (!ds && sym->attr.function
|
if (!ds && sym->attr.function
|
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
|
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
|
{
|
{
|
symtree = gfc_new_symtree (&sym->ns->sym_root,
|
symtree = gfc_new_symtree (&sym->ns->sym_root,
|
sym->ts.u.derived->name);
|
sym->ts.u.derived->name);
|
symtree->n.sym = sym->ts.u.derived;
|
symtree->n.sym = sym->ts.u.derived;
|
sym->ts.u.derived->refs++;
|
sym->ts.u.derived->refs++;
|
}
|
}
|
}
|
}
|
|
|
/* Unless the derived-type declaration is use associated, Fortran 95
|
/* Unless the derived-type declaration is use associated, Fortran 95
|
does not allow public entries of private derived types.
|
does not allow public entries of private derived types.
|
See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
|
See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
|
161 in 95-006r3. */
|
161 in 95-006r3. */
|
if (sym->ts.type == BT_DERIVED
|
if (sym->ts.type == BT_DERIVED
|
&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
|
&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
|
&& !sym->ts.u.derived->attr.use_assoc
|
&& !sym->ts.u.derived->attr.use_assoc
|
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
|
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
|
&& !gfc_check_access (sym->ts.u.derived->attr.access,
|
&& !gfc_check_access (sym->ts.u.derived->attr.access,
|
sym->ts.u.derived->ns->default_access)
|
sym->ts.u.derived->ns->default_access)
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
|
"of PRIVATE derived type '%s'",
|
"of PRIVATE derived type '%s'",
|
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
|
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
|
: "variable", sym->name, &sym->declared_at,
|
: "variable", sym->name, &sym->declared_at,
|
sym->ts.u.derived->name) == FAILURE)
|
sym->ts.u.derived->name) == FAILURE)
|
return;
|
return;
|
|
|
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
|
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
|
default initialization is defined (5.1.2.4.4). */
|
default initialization is defined (5.1.2.4.4). */
|
if (sym->ts.type == BT_DERIVED
|
if (sym->ts.type == BT_DERIVED
|
&& sym->attr.dummy
|
&& sym->attr.dummy
|
&& sym->attr.intent == INTENT_OUT
|
&& sym->attr.intent == INTENT_OUT
|
&& sym->as
|
&& sym->as
|
&& sym->as->type == AS_ASSUMED_SIZE)
|
&& sym->as->type == AS_ASSUMED_SIZE)
|
{
|
{
|
for (c = sym->ts.u.derived->components; c; c = c->next)
|
for (c = sym->ts.u.derived->components; c; c = c->next)
|
{
|
{
|
if (c->initializer)
|
if (c->initializer)
|
{
|
{
|
gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
|
gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
|
"ASSUMED SIZE and so cannot have a default initializer",
|
"ASSUMED SIZE and so cannot have a default initializer",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
return;
|
return;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
switch (sym->attr.flavor)
|
switch (sym->attr.flavor)
|
{
|
{
|
case FL_VARIABLE:
|
case FL_VARIABLE:
|
if (resolve_fl_variable (sym, mp_flag) == FAILURE)
|
if (resolve_fl_variable (sym, mp_flag) == FAILURE)
|
return;
|
return;
|
break;
|
break;
|
|
|
case FL_PROCEDURE:
|
case FL_PROCEDURE:
|
if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
|
if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
|
return;
|
return;
|
break;
|
break;
|
|
|
case FL_NAMELIST:
|
case FL_NAMELIST:
|
if (resolve_fl_namelist (sym) == FAILURE)
|
if (resolve_fl_namelist (sym) == FAILURE)
|
return;
|
return;
|
break;
|
break;
|
|
|
case FL_PARAMETER:
|
case FL_PARAMETER:
|
if (resolve_fl_parameter (sym) == FAILURE)
|
if (resolve_fl_parameter (sym) == FAILURE)
|
return;
|
return;
|
break;
|
break;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
|
|
/* Resolve array specifier. Check as well some constraints
|
/* Resolve array specifier. Check as well some constraints
|
on COMMON blocks. */
|
on COMMON blocks. */
|
|
|
check_constant = sym->attr.in_common && !sym->attr.pointer;
|
check_constant = sym->attr.in_common && !sym->attr.pointer;
|
|
|
/* Set the formal_arg_flag so that check_conflict will not throw
|
/* Set the formal_arg_flag so that check_conflict will not throw
|
an error for host associated variables in the specification
|
an error for host associated variables in the specification
|
expression for an array_valued function. */
|
expression for an array_valued function. */
|
if (sym->attr.function && sym->as)
|
if (sym->attr.function && sym->as)
|
formal_arg_flag = 1;
|
formal_arg_flag = 1;
|
|
|
gfc_resolve_array_spec (sym->as, check_constant);
|
gfc_resolve_array_spec (sym->as, check_constant);
|
|
|
formal_arg_flag = 0;
|
formal_arg_flag = 0;
|
|
|
/* Resolve formal namespaces. */
|
/* Resolve formal namespaces. */
|
if (sym->formal_ns && sym->formal_ns != gfc_current_ns
|
if (sym->formal_ns && sym->formal_ns != gfc_current_ns
|
&& !sym->attr.contained && !sym->attr.intrinsic)
|
&& !sym->attr.contained && !sym->attr.intrinsic)
|
gfc_resolve (sym->formal_ns);
|
gfc_resolve (sym->formal_ns);
|
|
|
/* Make sure the formal namespace is present. */
|
/* Make sure the formal namespace is present. */
|
if (sym->formal && !sym->formal_ns)
|
if (sym->formal && !sym->formal_ns)
|
{
|
{
|
gfc_formal_arglist *formal = sym->formal;
|
gfc_formal_arglist *formal = sym->formal;
|
while (formal && !formal->sym)
|
while (formal && !formal->sym)
|
formal = formal->next;
|
formal = formal->next;
|
|
|
if (formal)
|
if (formal)
|
{
|
{
|
sym->formal_ns = formal->sym->ns;
|
sym->formal_ns = formal->sym->ns;
|
sym->formal_ns->refs++;
|
sym->formal_ns->refs++;
|
}
|
}
|
}
|
}
|
|
|
/* Check threadprivate restrictions. */
|
/* Check threadprivate restrictions. */
|
if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
|
if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
|
&& (!sym->attr.in_common
|
&& (!sym->attr.in_common
|
&& sym->module == NULL
|
&& sym->module == NULL
|
&& (sym->ns->proc_name == NULL
|
&& (sym->ns->proc_name == NULL
|
|| sym->ns->proc_name->attr.flavor != FL_MODULE)))
|
|| sym->ns->proc_name->attr.flavor != FL_MODULE)))
|
gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
|
gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
|
|
|
/* If we have come this far we can apply default-initializers, as
|
/* If we have come this far we can apply default-initializers, as
|
described in 14.7.5, to those variables that have not already
|
described in 14.7.5, to those variables that have not already
|
been assigned one. */
|
been assigned one. */
|
if (sym->ts.type == BT_DERIVED
|
if (sym->ts.type == BT_DERIVED
|
&& sym->attr.referenced
|
&& sym->attr.referenced
|
&& sym->ns == gfc_current_ns
|
&& sym->ns == gfc_current_ns
|
&& !sym->value
|
&& !sym->value
|
&& !sym->attr.allocatable
|
&& !sym->attr.allocatable
|
&& !sym->attr.alloc_comp)
|
&& !sym->attr.alloc_comp)
|
{
|
{
|
symbol_attribute *a = &sym->attr;
|
symbol_attribute *a = &sym->attr;
|
|
|
if ((!a->save && !a->dummy && !a->pointer
|
if ((!a->save && !a->dummy && !a->pointer
|
&& !a->in_common && !a->use_assoc
|
&& !a->in_common && !a->use_assoc
|
&& !(a->function && sym != sym->result))
|
&& !(a->function && sym != sym->result))
|
|| (a->dummy && a->intent == INTENT_OUT && !a->pointer))
|
|| (a->dummy && a->intent == INTENT_OUT && !a->pointer))
|
apply_default_init (sym);
|
apply_default_init (sym);
|
}
|
}
|
|
|
/* If this symbol has a type-spec, check it. */
|
/* If this symbol has a type-spec, check it. */
|
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
|
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
|
|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
|
|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
|
if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
|
if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
|
== FAILURE)
|
== FAILURE)
|
return;
|
return;
|
}
|
}
|
|
|
|
|
/************* Resolve DATA statements *************/
|
/************* Resolve DATA statements *************/
|
|
|
static struct
|
static struct
|
{
|
{
|
gfc_data_value *vnode;
|
gfc_data_value *vnode;
|
mpz_t left;
|
mpz_t left;
|
}
|
}
|
values;
|
values;
|
|
|
|
|
/* Advance the values structure to point to the next value in the data list. */
|
/* Advance the values structure to point to the next value in the data list. */
|
|
|
static gfc_try
|
static gfc_try
|
next_data_value (void)
|
next_data_value (void)
|
{
|
{
|
while (mpz_cmp_ui (values.left, 0) == 0)
|
while (mpz_cmp_ui (values.left, 0) == 0)
|
{
|
{
|
|
|
if (values.vnode->next == NULL)
|
if (values.vnode->next == NULL)
|
return FAILURE;
|
return FAILURE;
|
|
|
values.vnode = values.vnode->next;
|
values.vnode = values.vnode->next;
|
mpz_set (values.left, values.vnode->repeat);
|
mpz_set (values.left, values.vnode->repeat);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
check_data_variable (gfc_data_variable *var, locus *where)
|
check_data_variable (gfc_data_variable *var, locus *where)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
mpz_t size;
|
mpz_t size;
|
mpz_t offset;
|
mpz_t offset;
|
gfc_try t;
|
gfc_try t;
|
ar_type mark = AR_UNKNOWN;
|
ar_type mark = AR_UNKNOWN;
|
int i;
|
int i;
|
mpz_t section_index[GFC_MAX_DIMENSIONS];
|
mpz_t section_index[GFC_MAX_DIMENSIONS];
|
gfc_ref *ref;
|
gfc_ref *ref;
|
gfc_array_ref *ar;
|
gfc_array_ref *ar;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
int has_pointer;
|
int has_pointer;
|
|
|
if (gfc_resolve_expr (var->expr) == FAILURE)
|
if (gfc_resolve_expr (var->expr) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
ar = NULL;
|
ar = NULL;
|
mpz_init_set_si (offset, 0);
|
mpz_init_set_si (offset, 0);
|
e = var->expr;
|
e = var->expr;
|
|
|
if (e->expr_type != EXPR_VARIABLE)
|
if (e->expr_type != EXPR_VARIABLE)
|
gfc_internal_error ("check_data_variable(): Bad expression");
|
gfc_internal_error ("check_data_variable(): Bad expression");
|
|
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
|
|
if (sym->ns->is_block_data && !sym->attr.in_common)
|
if (sym->ns->is_block_data && !sym->attr.in_common)
|
{
|
{
|
gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
|
gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
}
|
}
|
|
|
if (e->ref == NULL && sym->as)
|
if (e->ref == NULL && sym->as)
|
{
|
{
|
gfc_error ("DATA array '%s' at %L must be specified in a previous"
|
gfc_error ("DATA array '%s' at %L must be specified in a previous"
|
" declaration", sym->name, where);
|
" declaration", sym->name, where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
has_pointer = sym->attr.pointer;
|
has_pointer = sym->attr.pointer;
|
|
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
{
|
{
|
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
|
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
|
has_pointer = 1;
|
has_pointer = 1;
|
|
|
if (has_pointer
|
if (has_pointer
|
&& ref->type == REF_ARRAY
|
&& ref->type == REF_ARRAY
|
&& ref->u.ar.type != AR_FULL)
|
&& ref->u.ar.type != AR_FULL)
|
{
|
{
|
gfc_error ("DATA element '%s' at %L is a pointer and so must "
|
gfc_error ("DATA element '%s' at %L is a pointer and so must "
|
"be a full array", sym->name, where);
|
"be a full array", sym->name, where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
if (e->rank == 0 || has_pointer)
|
if (e->rank == 0 || has_pointer)
|
{
|
{
|
mpz_init_set_ui (size, 1);
|
mpz_init_set_ui (size, 1);
|
ref = NULL;
|
ref = NULL;
|
}
|
}
|
else
|
else
|
{
|
{
|
ref = e->ref;
|
ref = e->ref;
|
|
|
/* Find the array section reference. */
|
/* Find the array section reference. */
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
{
|
{
|
if (ref->type != REF_ARRAY)
|
if (ref->type != REF_ARRAY)
|
continue;
|
continue;
|
if (ref->u.ar.type == AR_ELEMENT)
|
if (ref->u.ar.type == AR_ELEMENT)
|
continue;
|
continue;
|
break;
|
break;
|
}
|
}
|
gcc_assert (ref);
|
gcc_assert (ref);
|
|
|
/* Set marks according to the reference pattern. */
|
/* Set marks according to the reference pattern. */
|
switch (ref->u.ar.type)
|
switch (ref->u.ar.type)
|
{
|
{
|
case AR_FULL:
|
case AR_FULL:
|
mark = AR_FULL;
|
mark = AR_FULL;
|
break;
|
break;
|
|
|
case AR_SECTION:
|
case AR_SECTION:
|
ar = &ref->u.ar;
|
ar = &ref->u.ar;
|
/* Get the start position of array section. */
|
/* Get the start position of array section. */
|
gfc_get_section_index (ar, section_index, &offset);
|
gfc_get_section_index (ar, section_index, &offset);
|
mark = AR_SECTION;
|
mark = AR_SECTION;
|
break;
|
break;
|
|
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
if (gfc_array_size (e, &size) == FAILURE)
|
if (gfc_array_size (e, &size) == FAILURE)
|
{
|
{
|
gfc_error ("Nonconstant array section at %L in DATA statement",
|
gfc_error ("Nonconstant array section at %L in DATA statement",
|
&e->where);
|
&e->where);
|
mpz_clear (offset);
|
mpz_clear (offset);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
|
|
while (mpz_cmp_ui (size, 0) > 0)
|
while (mpz_cmp_ui (size, 0) > 0)
|
{
|
{
|
if (next_data_value () == FAILURE)
|
if (next_data_value () == FAILURE)
|
{
|
{
|
gfc_error ("DATA statement at %L has more variables than values",
|
gfc_error ("DATA statement at %L has more variables than values",
|
where);
|
where);
|
t = FAILURE;
|
t = FAILURE;
|
break;
|
break;
|
}
|
}
|
|
|
t = gfc_check_assign (var->expr, values.vnode->expr, 0);
|
t = gfc_check_assign (var->expr, values.vnode->expr, 0);
|
if (t == FAILURE)
|
if (t == FAILURE)
|
break;
|
break;
|
|
|
/* If we have more than one element left in the repeat count,
|
/* If we have more than one element left in the repeat count,
|
and we have more than one element left in the target variable,
|
and we have more than one element left in the target variable,
|
then create a range assignment. */
|
then create a range assignment. */
|
/* FIXME: Only done for full arrays for now, since array sections
|
/* FIXME: Only done for full arrays for now, since array sections
|
seem tricky. */
|
seem tricky. */
|
if (mark == AR_FULL && ref && ref->next == NULL
|
if (mark == AR_FULL && ref && ref->next == NULL
|
&& mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
|
&& mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
|
{
|
{
|
mpz_t range;
|
mpz_t range;
|
|
|
if (mpz_cmp (size, values.left) >= 0)
|
if (mpz_cmp (size, values.left) >= 0)
|
{
|
{
|
mpz_init_set (range, values.left);
|
mpz_init_set (range, values.left);
|
mpz_sub (size, size, values.left);
|
mpz_sub (size, size, values.left);
|
mpz_set_ui (values.left, 0);
|
mpz_set_ui (values.left, 0);
|
}
|
}
|
else
|
else
|
{
|
{
|
mpz_init_set (range, size);
|
mpz_init_set (range, size);
|
mpz_sub (values.left, values.left, size);
|
mpz_sub (values.left, values.left, size);
|
mpz_set_ui (size, 0);
|
mpz_set_ui (size, 0);
|
}
|
}
|
|
|
gfc_assign_data_value_range (var->expr, values.vnode->expr,
|
gfc_assign_data_value_range (var->expr, values.vnode->expr,
|
offset, range);
|
offset, range);
|
|
|
mpz_add (offset, offset, range);
|
mpz_add (offset, offset, range);
|
mpz_clear (range);
|
mpz_clear (range);
|
}
|
}
|
|
|
/* Assign initial value to symbol. */
|
/* Assign initial value to symbol. */
|
else
|
else
|
{
|
{
|
mpz_sub_ui (values.left, values.left, 1);
|
mpz_sub_ui (values.left, values.left, 1);
|
mpz_sub_ui (size, size, 1);
|
mpz_sub_ui (size, size, 1);
|
|
|
t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
|
t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
|
if (t == FAILURE)
|
if (t == FAILURE)
|
break;
|
break;
|
|
|
if (mark == AR_FULL)
|
if (mark == AR_FULL)
|
mpz_add_ui (offset, offset, 1);
|
mpz_add_ui (offset, offset, 1);
|
|
|
/* Modify the array section indexes and recalculate the offset
|
/* Modify the array section indexes and recalculate the offset
|
for next element. */
|
for next element. */
|
else if (mark == AR_SECTION)
|
else if (mark == AR_SECTION)
|
gfc_advance_section (section_index, ar, &offset);
|
gfc_advance_section (section_index, ar, &offset);
|
}
|
}
|
}
|
}
|
|
|
if (mark == AR_SECTION)
|
if (mark == AR_SECTION)
|
{
|
{
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
mpz_clear (section_index[i]);
|
mpz_clear (section_index[i]);
|
}
|
}
|
|
|
mpz_clear (size);
|
mpz_clear (size);
|
mpz_clear (offset);
|
mpz_clear (offset);
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
static gfc_try traverse_data_var (gfc_data_variable *, locus *);
|
static gfc_try traverse_data_var (gfc_data_variable *, locus *);
|
|
|
/* Iterate over a list of elements in a DATA statement. */
|
/* Iterate over a list of elements in a DATA statement. */
|
|
|
static gfc_try
|
static gfc_try
|
traverse_data_list (gfc_data_variable *var, locus *where)
|
traverse_data_list (gfc_data_variable *var, locus *where)
|
{
|
{
|
mpz_t trip;
|
mpz_t trip;
|
iterator_stack frame;
|
iterator_stack frame;
|
gfc_expr *e, *start, *end, *step;
|
gfc_expr *e, *start, *end, *step;
|
gfc_try retval = SUCCESS;
|
gfc_try retval = SUCCESS;
|
|
|
mpz_init (frame.value);
|
mpz_init (frame.value);
|
|
|
start = gfc_copy_expr (var->iter.start);
|
start = gfc_copy_expr (var->iter.start);
|
end = gfc_copy_expr (var->iter.end);
|
end = gfc_copy_expr (var->iter.end);
|
step = gfc_copy_expr (var->iter.step);
|
step = gfc_copy_expr (var->iter.step);
|
|
|
if (gfc_simplify_expr (start, 1) == FAILURE
|
if (gfc_simplify_expr (start, 1) == FAILURE
|
|| start->expr_type != EXPR_CONSTANT)
|
|| start->expr_type != EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("iterator start at %L does not simplify", &start->where);
|
gfc_error ("iterator start at %L does not simplify", &start->where);
|
retval = FAILURE;
|
retval = FAILURE;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
if (gfc_simplify_expr (end, 1) == FAILURE
|
if (gfc_simplify_expr (end, 1) == FAILURE
|
|| end->expr_type != EXPR_CONSTANT)
|
|| end->expr_type != EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("iterator end at %L does not simplify", &end->where);
|
gfc_error ("iterator end at %L does not simplify", &end->where);
|
retval = FAILURE;
|
retval = FAILURE;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
if (gfc_simplify_expr (step, 1) == FAILURE
|
if (gfc_simplify_expr (step, 1) == FAILURE
|
|| step->expr_type != EXPR_CONSTANT)
|
|| step->expr_type != EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("iterator step at %L does not simplify", &step->where);
|
gfc_error ("iterator step at %L does not simplify", &step->where);
|
retval = FAILURE;
|
retval = FAILURE;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
mpz_init_set (trip, end->value.integer);
|
mpz_init_set (trip, end->value.integer);
|
mpz_sub (trip, trip, start->value.integer);
|
mpz_sub (trip, trip, start->value.integer);
|
mpz_add (trip, trip, step->value.integer);
|
mpz_add (trip, trip, step->value.integer);
|
|
|
mpz_div (trip, trip, step->value.integer);
|
mpz_div (trip, trip, step->value.integer);
|
|
|
mpz_set (frame.value, start->value.integer);
|
mpz_set (frame.value, start->value.integer);
|
|
|
frame.prev = iter_stack;
|
frame.prev = iter_stack;
|
frame.variable = var->iter.var->symtree;
|
frame.variable = var->iter.var->symtree;
|
iter_stack = &frame;
|
iter_stack = &frame;
|
|
|
while (mpz_cmp_ui (trip, 0) > 0)
|
while (mpz_cmp_ui (trip, 0) > 0)
|
{
|
{
|
if (traverse_data_var (var->list, where) == FAILURE)
|
if (traverse_data_var (var->list, where) == FAILURE)
|
{
|
{
|
mpz_clear (trip);
|
mpz_clear (trip);
|
retval = FAILURE;
|
retval = FAILURE;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
e = gfc_copy_expr (var->expr);
|
e = gfc_copy_expr (var->expr);
|
if (gfc_simplify_expr (e, 1) == FAILURE)
|
if (gfc_simplify_expr (e, 1) == FAILURE)
|
{
|
{
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
mpz_clear (trip);
|
mpz_clear (trip);
|
retval = FAILURE;
|
retval = FAILURE;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
mpz_add (frame.value, frame.value, step->value.integer);
|
mpz_add (frame.value, frame.value, step->value.integer);
|
|
|
mpz_sub_ui (trip, trip, 1);
|
mpz_sub_ui (trip, trip, 1);
|
}
|
}
|
|
|
mpz_clear (trip);
|
mpz_clear (trip);
|
cleanup:
|
cleanup:
|
mpz_clear (frame.value);
|
mpz_clear (frame.value);
|
|
|
gfc_free_expr (start);
|
gfc_free_expr (start);
|
gfc_free_expr (end);
|
gfc_free_expr (end);
|
gfc_free_expr (step);
|
gfc_free_expr (step);
|
|
|
iter_stack = frame.prev;
|
iter_stack = frame.prev;
|
return retval;
|
return retval;
|
}
|
}
|
|
|
|
|
/* Type resolve variables in the variable list of a DATA statement. */
|
/* Type resolve variables in the variable list of a DATA statement. */
|
|
|
static gfc_try
|
static gfc_try
|
traverse_data_var (gfc_data_variable *var, locus *where)
|
traverse_data_var (gfc_data_variable *var, locus *where)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
|
|
for (; var; var = var->next)
|
for (; var; var = var->next)
|
{
|
{
|
if (var->expr == NULL)
|
if (var->expr == NULL)
|
t = traverse_data_list (var, where);
|
t = traverse_data_list (var, where);
|
else
|
else
|
t = check_data_variable (var, where);
|
t = check_data_variable (var, where);
|
|
|
if (t == FAILURE)
|
if (t == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve the expressions and iterators associated with a data statement.
|
/* Resolve the expressions and iterators associated with a data statement.
|
This is separate from the assignment checking because data lists should
|
This is separate from the assignment checking because data lists should
|
only be resolved once. */
|
only be resolved once. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_data_variables (gfc_data_variable *d)
|
resolve_data_variables (gfc_data_variable *d)
|
{
|
{
|
for (; d; d = d->next)
|
for (; d; d = d->next)
|
{
|
{
|
if (d->list == NULL)
|
if (d->list == NULL)
|
{
|
{
|
if (gfc_resolve_expr (d->expr) == FAILURE)
|
if (gfc_resolve_expr (d->expr) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else
|
else
|
{
|
{
|
if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
|
if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (resolve_data_variables (d->list) == FAILURE)
|
if (resolve_data_variables (d->list) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve a single DATA statement. We implement this by storing a pointer to
|
/* Resolve a single DATA statement. We implement this by storing a pointer to
|
the value list into static variables, and then recursively traversing the
|
the value list into static variables, and then recursively traversing the
|
variables list, expanding iterators and such. */
|
variables list, expanding iterators and such. */
|
|
|
static void
|
static void
|
resolve_data (gfc_data *d)
|
resolve_data (gfc_data *d)
|
{
|
{
|
|
|
if (resolve_data_variables (d->var) == FAILURE)
|
if (resolve_data_variables (d->var) == FAILURE)
|
return;
|
return;
|
|
|
values.vnode = d->value;
|
values.vnode = d->value;
|
if (d->value == NULL)
|
if (d->value == NULL)
|
mpz_set_ui (values.left, 0);
|
mpz_set_ui (values.left, 0);
|
else
|
else
|
mpz_set (values.left, d->value->repeat);
|
mpz_set (values.left, d->value->repeat);
|
|
|
if (traverse_data_var (d->var, &d->where) == FAILURE)
|
if (traverse_data_var (d->var, &d->where) == FAILURE)
|
return;
|
return;
|
|
|
/* At this point, we better not have any values left. */
|
/* At this point, we better not have any values left. */
|
|
|
if (next_data_value () == SUCCESS)
|
if (next_data_value () == SUCCESS)
|
gfc_error ("DATA statement at %L has more values than variables",
|
gfc_error ("DATA statement at %L has more values than variables",
|
&d->where);
|
&d->where);
|
}
|
}
|
|
|
|
|
/* 12.6 Constraint: In a pure subprogram any variable which is in common or
|
/* 12.6 Constraint: In a pure subprogram any variable which is in common or
|
accessed by host or use association, is a dummy argument to a pure function,
|
accessed by host or use association, is a dummy argument to a pure function,
|
is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
|
is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
|
is storage associated with any such variable, shall not be used in the
|
is storage associated with any such variable, shall not be used in the
|
following contexts: (clients of this function). */
|
following contexts: (clients of this function). */
|
|
|
/* Determines if a variable is not 'pure', i.e., not assignable within a pure
|
/* Determines if a variable is not 'pure', i.e., not assignable within a pure
|
procedure. Returns zero if assignment is OK, nonzero if there is a
|
procedure. Returns zero if assignment is OK, nonzero if there is a
|
problem. */
|
problem. */
|
int
|
int
|
gfc_impure_variable (gfc_symbol *sym)
|
gfc_impure_variable (gfc_symbol *sym)
|
{
|
{
|
gfc_symbol *proc;
|
gfc_symbol *proc;
|
gfc_namespace *ns;
|
gfc_namespace *ns;
|
|
|
if (sym->attr.use_assoc || sym->attr.in_common)
|
if (sym->attr.use_assoc || sym->attr.in_common)
|
return 1;
|
return 1;
|
|
|
/* Check if the symbol's ns is inside the pure procedure. */
|
/* Check if the symbol's ns is inside the pure procedure. */
|
for (ns = gfc_current_ns; ns; ns = ns->parent)
|
for (ns = gfc_current_ns; ns; ns = ns->parent)
|
{
|
{
|
if (ns == sym->ns)
|
if (ns == sym->ns)
|
break;
|
break;
|
if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
|
if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
|
return 1;
|
return 1;
|
}
|
}
|
|
|
proc = sym->ns->proc_name;
|
proc = sym->ns->proc_name;
|
if (sym->attr.dummy && gfc_pure (proc)
|
if (sym->attr.dummy && gfc_pure (proc)
|
&& ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
|
&& ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
|
||
|
||
|
proc->attr.function))
|
proc->attr.function))
|
return 1;
|
return 1;
|
|
|
/* TODO: Sort out what can be storage associated, if anything, and include
|
/* TODO: Sort out what can be storage associated, if anything, and include
|
it here. In principle equivalences should be scanned but it does not
|
it here. In principle equivalences should be scanned but it does not
|
seem to be possible to storage associate an impure variable this way. */
|
seem to be possible to storage associate an impure variable this way. */
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/* Test whether a symbol is pure or not. For a NULL pointer, checks if the
|
/* Test whether a symbol is pure or not. For a NULL pointer, checks if the
|
current namespace is inside a pure procedure. */
|
current namespace is inside a pure procedure. */
|
|
|
int
|
int
|
gfc_pure (gfc_symbol *sym)
|
gfc_pure (gfc_symbol *sym)
|
{
|
{
|
symbol_attribute attr;
|
symbol_attribute attr;
|
gfc_namespace *ns;
|
gfc_namespace *ns;
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
{
|
{
|
/* Check if the current namespace or one of its parents
|
/* Check if the current namespace or one of its parents
|
belongs to a pure procedure. */
|
belongs to a pure procedure. */
|
for (ns = gfc_current_ns; ns; ns = ns->parent)
|
for (ns = gfc_current_ns; ns; ns = ns->parent)
|
{
|
{
|
sym = ns->proc_name;
|
sym = ns->proc_name;
|
if (sym == NULL)
|
if (sym == NULL)
|
return 0;
|
return 0;
|
attr = sym->attr;
|
attr = sym->attr;
|
if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
|
if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
|
return 1;
|
return 1;
|
}
|
}
|
return 0;
|
return 0;
|
}
|
}
|
|
|
attr = sym->attr;
|
attr = sym->attr;
|
|
|
return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
|
return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
|
}
|
}
|
|
|
|
|
/* Test whether the current procedure is elemental or not. */
|
/* Test whether the current procedure is elemental or not. */
|
|
|
int
|
int
|
gfc_elemental (gfc_symbol *sym)
|
gfc_elemental (gfc_symbol *sym)
|
{
|
{
|
symbol_attribute attr;
|
symbol_attribute attr;
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
sym = gfc_current_ns->proc_name;
|
sym = gfc_current_ns->proc_name;
|
if (sym == NULL)
|
if (sym == NULL)
|
return 0;
|
return 0;
|
attr = sym->attr;
|
attr = sym->attr;
|
|
|
return attr.flavor == FL_PROCEDURE && attr.elemental;
|
return attr.flavor == FL_PROCEDURE && attr.elemental;
|
}
|
}
|
|
|
|
|
/* Warn about unused labels. */
|
/* Warn about unused labels. */
|
|
|
static void
|
static void
|
warn_unused_fortran_label (gfc_st_label *label)
|
warn_unused_fortran_label (gfc_st_label *label)
|
{
|
{
|
if (label == NULL)
|
if (label == NULL)
|
return;
|
return;
|
|
|
warn_unused_fortran_label (label->left);
|
warn_unused_fortran_label (label->left);
|
|
|
if (label->defined == ST_LABEL_UNKNOWN)
|
if (label->defined == ST_LABEL_UNKNOWN)
|
return;
|
return;
|
|
|
switch (label->referenced)
|
switch (label->referenced)
|
{
|
{
|
case ST_LABEL_UNKNOWN:
|
case ST_LABEL_UNKNOWN:
|
gfc_warning ("Label %d at %L defined but not used", label->value,
|
gfc_warning ("Label %d at %L defined but not used", label->value,
|
&label->where);
|
&label->where);
|
break;
|
break;
|
|
|
case ST_LABEL_BAD_TARGET:
|
case ST_LABEL_BAD_TARGET:
|
gfc_warning ("Label %d at %L defined but cannot be used",
|
gfc_warning ("Label %d at %L defined but cannot be used",
|
label->value, &label->where);
|
label->value, &label->where);
|
break;
|
break;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
|
|
warn_unused_fortran_label (label->right);
|
warn_unused_fortran_label (label->right);
|
}
|
}
|
|
|
|
|
/* Returns the sequence type of a symbol or sequence. */
|
/* Returns the sequence type of a symbol or sequence. */
|
|
|
static seq_type
|
static seq_type
|
sequence_type (gfc_typespec ts)
|
sequence_type (gfc_typespec ts)
|
{
|
{
|
seq_type result;
|
seq_type result;
|
gfc_component *c;
|
gfc_component *c;
|
|
|
switch (ts.type)
|
switch (ts.type)
|
{
|
{
|
case BT_DERIVED:
|
case BT_DERIVED:
|
|
|
if (ts.u.derived->components == NULL)
|
if (ts.u.derived->components == NULL)
|
return SEQ_NONDEFAULT;
|
return SEQ_NONDEFAULT;
|
|
|
result = sequence_type (ts.u.derived->components->ts);
|
result = sequence_type (ts.u.derived->components->ts);
|
for (c = ts.u.derived->components->next; c; c = c->next)
|
for (c = ts.u.derived->components->next; c; c = c->next)
|
if (sequence_type (c->ts) != result)
|
if (sequence_type (c->ts) != result)
|
return SEQ_MIXED;
|
return SEQ_MIXED;
|
|
|
return result;
|
return result;
|
|
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
if (ts.kind != gfc_default_character_kind)
|
if (ts.kind != gfc_default_character_kind)
|
return SEQ_NONDEFAULT;
|
return SEQ_NONDEFAULT;
|
|
|
return SEQ_CHARACTER;
|
return SEQ_CHARACTER;
|
|
|
case BT_INTEGER:
|
case BT_INTEGER:
|
if (ts.kind != gfc_default_integer_kind)
|
if (ts.kind != gfc_default_integer_kind)
|
return SEQ_NONDEFAULT;
|
return SEQ_NONDEFAULT;
|
|
|
return SEQ_NUMERIC;
|
return SEQ_NUMERIC;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
if (!(ts.kind == gfc_default_real_kind
|
if (!(ts.kind == gfc_default_real_kind
|
|| ts.kind == gfc_default_double_kind))
|
|| ts.kind == gfc_default_double_kind))
|
return SEQ_NONDEFAULT;
|
return SEQ_NONDEFAULT;
|
|
|
return SEQ_NUMERIC;
|
return SEQ_NUMERIC;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
if (ts.kind != gfc_default_complex_kind)
|
if (ts.kind != gfc_default_complex_kind)
|
return SEQ_NONDEFAULT;
|
return SEQ_NONDEFAULT;
|
|
|
return SEQ_NUMERIC;
|
return SEQ_NUMERIC;
|
|
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
if (ts.kind != gfc_default_logical_kind)
|
if (ts.kind != gfc_default_logical_kind)
|
return SEQ_NONDEFAULT;
|
return SEQ_NONDEFAULT;
|
|
|
return SEQ_NUMERIC;
|
return SEQ_NUMERIC;
|
|
|
default:
|
default:
|
return SEQ_NONDEFAULT;
|
return SEQ_NONDEFAULT;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve derived type EQUIVALENCE object. */
|
/* Resolve derived type EQUIVALENCE object. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
|
resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
|
{
|
{
|
gfc_component *c = derived->components;
|
gfc_component *c = derived->components;
|
|
|
if (!derived)
|
if (!derived)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* Shall not be an object of nonsequence derived type. */
|
/* Shall not be an object of nonsequence derived type. */
|
if (!derived->attr.sequence)
|
if (!derived->attr.sequence)
|
{
|
{
|
gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
|
gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
|
"attribute to be an EQUIVALENCE object", sym->name,
|
"attribute to be an EQUIVALENCE object", sym->name,
|
&e->where);
|
&e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Shall not have allocatable components. */
|
/* Shall not have allocatable components. */
|
if (derived->attr.alloc_comp)
|
if (derived->attr.alloc_comp)
|
{
|
{
|
gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
|
gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
|
"components to be an EQUIVALENCE object",sym->name,
|
"components to be an EQUIVALENCE object",sym->name,
|
&e->where);
|
&e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived))
|
if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived))
|
{
|
{
|
gfc_error ("Derived type variable '%s' at %L with default "
|
gfc_error ("Derived type variable '%s' at %L with default "
|
"initialization cannot be in EQUIVALENCE with a variable "
|
"initialization cannot be in EQUIVALENCE with a variable "
|
"in COMMON", sym->name, &e->where);
|
"in COMMON", sym->name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
for (; c ; c = c->next)
|
for (; c ; c = c->next)
|
{
|
{
|
if (c->ts.type == BT_DERIVED
|
if (c->ts.type == BT_DERIVED
|
&& (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
|
&& (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Shall not be an object of sequence derived type containing a pointer
|
/* Shall not be an object of sequence derived type containing a pointer
|
in the structure. */
|
in the structure. */
|
if (c->attr.pointer)
|
if (c->attr.pointer)
|
{
|
{
|
gfc_error ("Derived type variable '%s' at %L with pointer "
|
gfc_error ("Derived type variable '%s' at %L with pointer "
|
"component(s) cannot be an EQUIVALENCE object",
|
"component(s) cannot be an EQUIVALENCE object",
|
sym->name, &e->where);
|
sym->name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve equivalence object.
|
/* Resolve equivalence object.
|
An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
|
An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
|
an allocatable array, an object of nonsequence derived type, an object of
|
an allocatable array, an object of nonsequence derived type, an object of
|
sequence derived type containing a pointer at any level of component
|
sequence derived type containing a pointer at any level of component
|
selection, an automatic object, a function name, an entry name, a result
|
selection, an automatic object, a function name, an entry name, a result
|
name, a named constant, a structure component, or a subobject of any of
|
name, a named constant, a structure component, or a subobject of any of
|
the preceding objects. A substring shall not have length zero. A
|
the preceding objects. A substring shall not have length zero. A
|
derived type shall not have components with default initialization nor
|
derived type shall not have components with default initialization nor
|
shall two objects of an equivalence group be initialized.
|
shall two objects of an equivalence group be initialized.
|
Either all or none of the objects shall have an protected attribute.
|
Either all or none of the objects shall have an protected attribute.
|
The simple constraints are done in symbol.c(check_conflict) and the rest
|
The simple constraints are done in symbol.c(check_conflict) and the rest
|
are implemented here. */
|
are implemented here. */
|
|
|
static void
|
static void
|
resolve_equivalence (gfc_equiv *eq)
|
resolve_equivalence (gfc_equiv *eq)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_symbol *first_sym;
|
gfc_symbol *first_sym;
|
gfc_expr *e;
|
gfc_expr *e;
|
gfc_ref *r;
|
gfc_ref *r;
|
locus *last_where = NULL;
|
locus *last_where = NULL;
|
seq_type eq_type, last_eq_type;
|
seq_type eq_type, last_eq_type;
|
gfc_typespec *last_ts;
|
gfc_typespec *last_ts;
|
int object, cnt_protected;
|
int object, cnt_protected;
|
const char *msg;
|
const char *msg;
|
|
|
last_ts = &eq->expr->symtree->n.sym->ts;
|
last_ts = &eq->expr->symtree->n.sym->ts;
|
|
|
first_sym = eq->expr->symtree->n.sym;
|
first_sym = eq->expr->symtree->n.sym;
|
|
|
cnt_protected = 0;
|
cnt_protected = 0;
|
|
|
for (object = 1; eq; eq = eq->eq, object++)
|
for (object = 1; eq; eq = eq->eq, object++)
|
{
|
{
|
e = eq->expr;
|
e = eq->expr;
|
|
|
e->ts = e->symtree->n.sym->ts;
|
e->ts = e->symtree->n.sym->ts;
|
/* match_varspec might not know yet if it is seeing
|
/* match_varspec might not know yet if it is seeing
|
array reference or substring reference, as it doesn't
|
array reference or substring reference, as it doesn't
|
know the types. */
|
know the types. */
|
if (e->ref && e->ref->type == REF_ARRAY)
|
if (e->ref && e->ref->type == REF_ARRAY)
|
{
|
{
|
gfc_ref *ref = e->ref;
|
gfc_ref *ref = e->ref;
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
|
|
if (sym->attr.dimension)
|
if (sym->attr.dimension)
|
{
|
{
|
ref->u.ar.as = sym->as;
|
ref->u.ar.as = sym->as;
|
ref = ref->next;
|
ref = ref->next;
|
}
|
}
|
|
|
/* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
|
/* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
|
if (e->ts.type == BT_CHARACTER
|
if (e->ts.type == BT_CHARACTER
|
&& ref
|
&& ref
|
&& ref->type == REF_ARRAY
|
&& ref->type == REF_ARRAY
|
&& ref->u.ar.dimen == 1
|
&& ref->u.ar.dimen == 1
|
&& ref->u.ar.dimen_type[0] == DIMEN_RANGE
|
&& ref->u.ar.dimen_type[0] == DIMEN_RANGE
|
&& ref->u.ar.stride[0] == NULL)
|
&& ref->u.ar.stride[0] == NULL)
|
{
|
{
|
gfc_expr *start = ref->u.ar.start[0];
|
gfc_expr *start = ref->u.ar.start[0];
|
gfc_expr *end = ref->u.ar.end[0];
|
gfc_expr *end = ref->u.ar.end[0];
|
void *mem = NULL;
|
void *mem = NULL;
|
|
|
/* Optimize away the (:) reference. */
|
/* Optimize away the (:) reference. */
|
if (start == NULL && end == NULL)
|
if (start == NULL && end == NULL)
|
{
|
{
|
if (e->ref == ref)
|
if (e->ref == ref)
|
e->ref = ref->next;
|
e->ref = ref->next;
|
else
|
else
|
e->ref->next = ref->next;
|
e->ref->next = ref->next;
|
mem = ref;
|
mem = ref;
|
}
|
}
|
else
|
else
|
{
|
{
|
ref->type = REF_SUBSTRING;
|
ref->type = REF_SUBSTRING;
|
if (start == NULL)
|
if (start == NULL)
|
start = gfc_int_expr (1);
|
start = gfc_int_expr (1);
|
ref->u.ss.start = start;
|
ref->u.ss.start = start;
|
if (end == NULL && e->ts.u.cl)
|
if (end == NULL && e->ts.u.cl)
|
end = gfc_copy_expr (e->ts.u.cl->length);
|
end = gfc_copy_expr (e->ts.u.cl->length);
|
ref->u.ss.end = end;
|
ref->u.ss.end = end;
|
ref->u.ss.length = e->ts.u.cl;
|
ref->u.ss.length = e->ts.u.cl;
|
e->ts.u.cl = NULL;
|
e->ts.u.cl = NULL;
|
}
|
}
|
ref = ref->next;
|
ref = ref->next;
|
gfc_free (mem);
|
gfc_free (mem);
|
}
|
}
|
|
|
/* Any further ref is an error. */
|
/* Any further ref is an error. */
|
if (ref)
|
if (ref)
|
{
|
{
|
gcc_assert (ref->type == REF_ARRAY);
|
gcc_assert (ref->type == REF_ARRAY);
|
gfc_error ("Syntax error in EQUIVALENCE statement at %L",
|
gfc_error ("Syntax error in EQUIVALENCE statement at %L",
|
&ref->u.ar.where);
|
&ref->u.ar.where);
|
continue;
|
continue;
|
}
|
}
|
}
|
}
|
|
|
if (gfc_resolve_expr (e) == FAILURE)
|
if (gfc_resolve_expr (e) == FAILURE)
|
continue;
|
continue;
|
|
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
|
|
if (sym->attr.is_protected)
|
if (sym->attr.is_protected)
|
cnt_protected++;
|
cnt_protected++;
|
if (cnt_protected > 0 && cnt_protected != object)
|
if (cnt_protected > 0 && cnt_protected != object)
|
{
|
{
|
gfc_error ("Either all or none of the objects in the "
|
gfc_error ("Either all or none of the objects in the "
|
"EQUIVALENCE set at %L shall have the "
|
"EQUIVALENCE set at %L shall have the "
|
"PROTECTED attribute",
|
"PROTECTED attribute",
|
&e->where);
|
&e->where);
|
break;
|
break;
|
}
|
}
|
|
|
/* Shall not equivalence common block variables in a PURE procedure. */
|
/* Shall not equivalence common block variables in a PURE procedure. */
|
if (sym->ns->proc_name
|
if (sym->ns->proc_name
|
&& sym->ns->proc_name->attr.pure
|
&& sym->ns->proc_name->attr.pure
|
&& sym->attr.in_common)
|
&& sym->attr.in_common)
|
{
|
{
|
gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
|
gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
|
"object in the pure procedure '%s'",
|
"object in the pure procedure '%s'",
|
sym->name, &e->where, sym->ns->proc_name->name);
|
sym->name, &e->where, sym->ns->proc_name->name);
|
break;
|
break;
|
}
|
}
|
|
|
/* Shall not be a named constant. */
|
/* Shall not be a named constant. */
|
if (e->expr_type == EXPR_CONSTANT)
|
if (e->expr_type == EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
|
gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
|
"object", sym->name, &e->where);
|
"object", sym->name, &e->where);
|
continue;
|
continue;
|
}
|
}
|
|
|
if (e->ts.type == BT_DERIVED
|
if (e->ts.type == BT_DERIVED
|
&& resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
|
&& resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
|
continue;
|
continue;
|
|
|
/* Check that the types correspond correctly:
|
/* Check that the types correspond correctly:
|
Note 5.28:
|
Note 5.28:
|
A numeric sequence structure may be equivalenced to another sequence
|
A numeric sequence structure may be equivalenced to another sequence
|
structure, an object of default integer type, default real type, double
|
structure, an object of default integer type, default real type, double
|
precision real type, default logical type such that components of the
|
precision real type, default logical type such that components of the
|
structure ultimately only become associated to objects of the same
|
structure ultimately only become associated to objects of the same
|
kind. A character sequence structure may be equivalenced to an object
|
kind. A character sequence structure may be equivalenced to an object
|
of default character kind or another character sequence structure.
|
of default character kind or another character sequence structure.
|
Other objects may be equivalenced only to objects of the same type and
|
Other objects may be equivalenced only to objects of the same type and
|
kind parameters. */
|
kind parameters. */
|
|
|
/* Identical types are unconditionally OK. */
|
/* Identical types are unconditionally OK. */
|
if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
|
if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
|
goto identical_types;
|
goto identical_types;
|
|
|
last_eq_type = sequence_type (*last_ts);
|
last_eq_type = sequence_type (*last_ts);
|
eq_type = sequence_type (sym->ts);
|
eq_type = sequence_type (sym->ts);
|
|
|
/* Since the pair of objects is not of the same type, mixed or
|
/* Since the pair of objects is not of the same type, mixed or
|
non-default sequences can be rejected. */
|
non-default sequences can be rejected. */
|
|
|
msg = "Sequence %s with mixed components in EQUIVALENCE "
|
msg = "Sequence %s with mixed components in EQUIVALENCE "
|
"statement at %L with different type objects";
|
"statement at %L with different type objects";
|
if ((object ==2
|
if ((object ==2
|
&& last_eq_type == SEQ_MIXED
|
&& last_eq_type == SEQ_MIXED
|
&& gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
|
&& gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
|
== FAILURE)
|
== FAILURE)
|
|| (eq_type == SEQ_MIXED
|
|| (eq_type == SEQ_MIXED
|
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
|
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
|
&e->where) == FAILURE))
|
&e->where) == FAILURE))
|
continue;
|
continue;
|
|
|
msg = "Non-default type object or sequence %s in EQUIVALENCE "
|
msg = "Non-default type object or sequence %s in EQUIVALENCE "
|
"statement at %L with objects of different type";
|
"statement at %L with objects of different type";
|
if ((object ==2
|
if ((object ==2
|
&& last_eq_type == SEQ_NONDEFAULT
|
&& last_eq_type == SEQ_NONDEFAULT
|
&& gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
|
&& gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
|
last_where) == FAILURE)
|
last_where) == FAILURE)
|
|| (eq_type == SEQ_NONDEFAULT
|
|| (eq_type == SEQ_NONDEFAULT
|
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
|
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
|
&e->where) == FAILURE))
|
&e->where) == FAILURE))
|
continue;
|
continue;
|
|
|
msg ="Non-CHARACTER object '%s' in default CHARACTER "
|
msg ="Non-CHARACTER object '%s' in default CHARACTER "
|
"EQUIVALENCE statement at %L";
|
"EQUIVALENCE statement at %L";
|
if (last_eq_type == SEQ_CHARACTER
|
if (last_eq_type == SEQ_CHARACTER
|
&& eq_type != SEQ_CHARACTER
|
&& eq_type != SEQ_CHARACTER
|
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
|
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
|
&e->where) == FAILURE)
|
&e->where) == FAILURE)
|
continue;
|
continue;
|
|
|
msg ="Non-NUMERIC object '%s' in default NUMERIC "
|
msg ="Non-NUMERIC object '%s' in default NUMERIC "
|
"EQUIVALENCE statement at %L";
|
"EQUIVALENCE statement at %L";
|
if (last_eq_type == SEQ_NUMERIC
|
if (last_eq_type == SEQ_NUMERIC
|
&& eq_type != SEQ_NUMERIC
|
&& eq_type != SEQ_NUMERIC
|
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
|
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
|
&e->where) == FAILURE)
|
&e->where) == FAILURE)
|
continue;
|
continue;
|
|
|
identical_types:
|
identical_types:
|
last_ts =&sym->ts;
|
last_ts =&sym->ts;
|
last_where = &e->where;
|
last_where = &e->where;
|
|
|
if (!e->ref)
|
if (!e->ref)
|
continue;
|
continue;
|
|
|
/* Shall not be an automatic array. */
|
/* Shall not be an automatic array. */
|
if (e->ref->type == REF_ARRAY
|
if (e->ref->type == REF_ARRAY
|
&& gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
|
&& gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
|
{
|
{
|
gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
|
gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
|
"an EQUIVALENCE object", sym->name, &e->where);
|
"an EQUIVALENCE object", sym->name, &e->where);
|
continue;
|
continue;
|
}
|
}
|
|
|
r = e->ref;
|
r = e->ref;
|
while (r)
|
while (r)
|
{
|
{
|
/* Shall not be a structure component. */
|
/* Shall not be a structure component. */
|
if (r->type == REF_COMPONENT)
|
if (r->type == REF_COMPONENT)
|
{
|
{
|
gfc_error ("Structure component '%s' at %L cannot be an "
|
gfc_error ("Structure component '%s' at %L cannot be an "
|
"EQUIVALENCE object",
|
"EQUIVALENCE object",
|
r->u.c.component->name, &e->where);
|
r->u.c.component->name, &e->where);
|
break;
|
break;
|
}
|
}
|
|
|
/* A substring shall not have length zero. */
|
/* A substring shall not have length zero. */
|
if (r->type == REF_SUBSTRING)
|
if (r->type == REF_SUBSTRING)
|
{
|
{
|
if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
|
if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
|
{
|
{
|
gfc_error ("Substring at %L has length zero",
|
gfc_error ("Substring at %L has length zero",
|
&r->u.ss.start->where);
|
&r->u.ss.start->where);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
r = r->next;
|
r = r->next;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve function and ENTRY types, issue diagnostics if needed. */
|
/* Resolve function and ENTRY types, issue diagnostics if needed. */
|
|
|
static void
|
static void
|
resolve_fntype (gfc_namespace *ns)
|
resolve_fntype (gfc_namespace *ns)
|
{
|
{
|
gfc_entry_list *el;
|
gfc_entry_list *el;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
|
|
if (ns->proc_name == NULL || !ns->proc_name->attr.function)
|
if (ns->proc_name == NULL || !ns->proc_name->attr.function)
|
return;
|
return;
|
|
|
/* If there are any entries, ns->proc_name is the entry master
|
/* If there are any entries, ns->proc_name is the entry master
|
synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
|
synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
|
if (ns->entries)
|
if (ns->entries)
|
sym = ns->entries->sym;
|
sym = ns->entries->sym;
|
else
|
else
|
sym = ns->proc_name;
|
sym = ns->proc_name;
|
if (sym->result == sym
|
if (sym->result == sym
|
&& sym->ts.type == BT_UNKNOWN
|
&& sym->ts.type == BT_UNKNOWN
|
&& gfc_set_default_type (sym, 0, NULL) == FAILURE
|
&& gfc_set_default_type (sym, 0, NULL) == FAILURE
|
&& !sym->attr.untyped)
|
&& !sym->attr.untyped)
|
{
|
{
|
gfc_error ("Function '%s' at %L has no IMPLICIT type",
|
gfc_error ("Function '%s' at %L has no IMPLICIT type",
|
sym->name, &sym->declared_at);
|
sym->name, &sym->declared_at);
|
sym->attr.untyped = 1;
|
sym->attr.untyped = 1;
|
}
|
}
|
|
|
if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
|
if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
|
&& !sym->attr.contained
|
&& !sym->attr.contained
|
&& !gfc_check_access (sym->ts.u.derived->attr.access,
|
&& !gfc_check_access (sym->ts.u.derived->attr.access,
|
sym->ts.u.derived->ns->default_access)
|
sym->ts.u.derived->ns->default_access)
|
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
|
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
|
{
|
{
|
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
|
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
|
"%L of PRIVATE type '%s'", sym->name,
|
"%L of PRIVATE type '%s'", sym->name,
|
&sym->declared_at, sym->ts.u.derived->name);
|
&sym->declared_at, sym->ts.u.derived->name);
|
}
|
}
|
|
|
if (ns->entries)
|
if (ns->entries)
|
for (el = ns->entries->next; el; el = el->next)
|
for (el = ns->entries->next; el; el = el->next)
|
{
|
{
|
if (el->sym->result == el->sym
|
if (el->sym->result == el->sym
|
&& el->sym->ts.type == BT_UNKNOWN
|
&& el->sym->ts.type == BT_UNKNOWN
|
&& gfc_set_default_type (el->sym, 0, NULL) == FAILURE
|
&& gfc_set_default_type (el->sym, 0, NULL) == FAILURE
|
&& !el->sym->attr.untyped)
|
&& !el->sym->attr.untyped)
|
{
|
{
|
gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
|
gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
|
el->sym->name, &el->sym->declared_at);
|
el->sym->name, &el->sym->declared_at);
|
el->sym->attr.untyped = 1;
|
el->sym->attr.untyped = 1;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/* 12.3.2.1.1 Defined operators. */
|
/* 12.3.2.1.1 Defined operators. */
|
|
|
static gfc_try
|
static gfc_try
|
check_uop_procedure (gfc_symbol *sym, locus where)
|
check_uop_procedure (gfc_symbol *sym, locus where)
|
{
|
{
|
gfc_formal_arglist *formal;
|
gfc_formal_arglist *formal;
|
|
|
if (!sym->attr.function)
|
if (!sym->attr.function)
|
{
|
{
|
gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
|
gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
|
sym->name, &where);
|
sym->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (sym->ts.type == BT_CHARACTER
|
if (sym->ts.type == BT_CHARACTER
|
&& !(sym->ts.u.cl && sym->ts.u.cl->length)
|
&& !(sym->ts.u.cl && sym->ts.u.cl->length)
|
&& !(sym->result && sym->result->ts.u.cl
|
&& !(sym->result && sym->result->ts.u.cl
|
&& sym->result->ts.u.cl->length))
|
&& sym->result->ts.u.cl->length))
|
{
|
{
|
gfc_error ("User operator procedure '%s' at %L cannot be assumed "
|
gfc_error ("User operator procedure '%s' at %L cannot be assumed "
|
"character length", sym->name, &where);
|
"character length", sym->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
formal = sym->formal;
|
formal = sym->formal;
|
if (!formal || !formal->sym)
|
if (!formal || !formal->sym)
|
{
|
{
|
gfc_error ("User operator procedure '%s' at %L must have at least "
|
gfc_error ("User operator procedure '%s' at %L must have at least "
|
"one argument", sym->name, &where);
|
"one argument", sym->name, &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (formal->sym->attr.intent != INTENT_IN)
|
if (formal->sym->attr.intent != INTENT_IN)
|
{
|
{
|
gfc_error ("First argument of operator interface at %L must be "
|
gfc_error ("First argument of operator interface at %L must be "
|
"INTENT(IN)", &where);
|
"INTENT(IN)", &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (formal->sym->attr.optional)
|
if (formal->sym->attr.optional)
|
{
|
{
|
gfc_error ("First argument of operator interface at %L cannot be "
|
gfc_error ("First argument of operator interface at %L cannot be "
|
"optional", &where);
|
"optional", &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
formal = formal->next;
|
formal = formal->next;
|
if (!formal || !formal->sym)
|
if (!formal || !formal->sym)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (formal->sym->attr.intent != INTENT_IN)
|
if (formal->sym->attr.intent != INTENT_IN)
|
{
|
{
|
gfc_error ("Second argument of operator interface at %L must be "
|
gfc_error ("Second argument of operator interface at %L must be "
|
"INTENT(IN)", &where);
|
"INTENT(IN)", &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (formal->sym->attr.optional)
|
if (formal->sym->attr.optional)
|
{
|
{
|
gfc_error ("Second argument of operator interface at %L cannot be "
|
gfc_error ("Second argument of operator interface at %L cannot be "
|
"optional", &where);
|
"optional", &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (formal->next)
|
if (formal->next)
|
{
|
{
|
gfc_error ("Operator interface at %L must have, at most, two "
|
gfc_error ("Operator interface at %L must have, at most, two "
|
"arguments", &where);
|
"arguments", &where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
static void
|
static void
|
gfc_resolve_uops (gfc_symtree *symtree)
|
gfc_resolve_uops (gfc_symtree *symtree)
|
{
|
{
|
gfc_interface *itr;
|
gfc_interface *itr;
|
|
|
if (symtree == NULL)
|
if (symtree == NULL)
|
return;
|
return;
|
|
|
gfc_resolve_uops (symtree->left);
|
gfc_resolve_uops (symtree->left);
|
gfc_resolve_uops (symtree->right);
|
gfc_resolve_uops (symtree->right);
|
|
|
for (itr = symtree->n.uop->op; itr; itr = itr->next)
|
for (itr = symtree->n.uop->op; itr; itr = itr->next)
|
check_uop_procedure (itr->sym, itr->sym->declared_at);
|
check_uop_procedure (itr->sym, itr->sym->declared_at);
|
}
|
}
|
|
|
|
|
/* Examine all of the expressions associated with a program unit,
|
/* Examine all of the expressions associated with a program unit,
|
assign types to all intermediate expressions, make sure that all
|
assign types to all intermediate expressions, make sure that all
|
assignments are to compatible types and figure out which names
|
assignments are to compatible types and figure out which names
|
refer to which functions or subroutines. It doesn't check code
|
refer to which functions or subroutines. It doesn't check code
|
block, which is handled by resolve_code. */
|
block, which is handled by resolve_code. */
|
|
|
static void
|
static void
|
resolve_types (gfc_namespace *ns)
|
resolve_types (gfc_namespace *ns)
|
{
|
{
|
gfc_namespace *n;
|
gfc_namespace *n;
|
gfc_charlen *cl;
|
gfc_charlen *cl;
|
gfc_data *d;
|
gfc_data *d;
|
gfc_equiv *eq;
|
gfc_equiv *eq;
|
gfc_namespace* old_ns = gfc_current_ns;
|
gfc_namespace* old_ns = gfc_current_ns;
|
|
|
/* Check that all IMPLICIT types are ok. */
|
/* Check that all IMPLICIT types are ok. */
|
if (!ns->seen_implicit_none)
|
if (!ns->seen_implicit_none)
|
{
|
{
|
unsigned letter;
|
unsigned letter;
|
for (letter = 0; letter != GFC_LETTERS; ++letter)
|
for (letter = 0; letter != GFC_LETTERS; ++letter)
|
if (ns->set_flag[letter]
|
if (ns->set_flag[letter]
|
&& resolve_typespec_used (&ns->default_type[letter],
|
&& resolve_typespec_used (&ns->default_type[letter],
|
&ns->implicit_loc[letter],
|
&ns->implicit_loc[letter],
|
NULL) == FAILURE)
|
NULL) == FAILURE)
|
return;
|
return;
|
}
|
}
|
|
|
gfc_current_ns = ns;
|
gfc_current_ns = ns;
|
|
|
resolve_entries (ns);
|
resolve_entries (ns);
|
|
|
resolve_common_vars (ns->blank_common.head, false);
|
resolve_common_vars (ns->blank_common.head, false);
|
resolve_common_blocks (ns->common_root);
|
resolve_common_blocks (ns->common_root);
|
|
|
resolve_contained_functions (ns);
|
resolve_contained_functions (ns);
|
|
|
gfc_traverse_ns (ns, resolve_bind_c_derived_types);
|
gfc_traverse_ns (ns, resolve_bind_c_derived_types);
|
|
|
for (cl = ns->cl_list; cl; cl = cl->next)
|
for (cl = ns->cl_list; cl; cl = cl->next)
|
resolve_charlen (cl);
|
resolve_charlen (cl);
|
|
|
gfc_traverse_ns (ns, resolve_symbol);
|
gfc_traverse_ns (ns, resolve_symbol);
|
|
|
resolve_fntype (ns);
|
resolve_fntype (ns);
|
|
|
for (n = ns->contained; n; n = n->sibling)
|
for (n = ns->contained; n; n = n->sibling)
|
{
|
{
|
if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
|
if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
|
gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
|
gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
|
"also be PURE", n->proc_name->name,
|
"also be PURE", n->proc_name->name,
|
&n->proc_name->declared_at);
|
&n->proc_name->declared_at);
|
|
|
resolve_types (n);
|
resolve_types (n);
|
}
|
}
|
|
|
forall_flag = 0;
|
forall_flag = 0;
|
gfc_check_interfaces (ns);
|
gfc_check_interfaces (ns);
|
|
|
gfc_traverse_ns (ns, resolve_values);
|
gfc_traverse_ns (ns, resolve_values);
|
|
|
if (ns->save_all)
|
if (ns->save_all)
|
gfc_save_all (ns);
|
gfc_save_all (ns);
|
|
|
iter_stack = NULL;
|
iter_stack = NULL;
|
for (d = ns->data; d; d = d->next)
|
for (d = ns->data; d; d = d->next)
|
resolve_data (d);
|
resolve_data (d);
|
|
|
iter_stack = NULL;
|
iter_stack = NULL;
|
gfc_traverse_ns (ns, gfc_formalize_init_value);
|
gfc_traverse_ns (ns, gfc_formalize_init_value);
|
|
|
gfc_traverse_ns (ns, gfc_verify_binding_labels);
|
gfc_traverse_ns (ns, gfc_verify_binding_labels);
|
|
|
if (ns->common_root != NULL)
|
if (ns->common_root != NULL)
|
gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
|
gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
|
|
|
for (eq = ns->equiv; eq; eq = eq->next)
|
for (eq = ns->equiv; eq; eq = eq->next)
|
resolve_equivalence (eq);
|
resolve_equivalence (eq);
|
|
|
/* Warn about unused labels. */
|
/* Warn about unused labels. */
|
if (warn_unused_label)
|
if (warn_unused_label)
|
warn_unused_fortran_label (ns->st_labels);
|
warn_unused_fortran_label (ns->st_labels);
|
|
|
gfc_resolve_uops (ns->uop_root);
|
gfc_resolve_uops (ns->uop_root);
|
|
|
gfc_current_ns = old_ns;
|
gfc_current_ns = old_ns;
|
}
|
}
|
|
|
|
|
/* Call resolve_code recursively. */
|
/* Call resolve_code recursively. */
|
|
|
static void
|
static void
|
resolve_codes (gfc_namespace *ns)
|
resolve_codes (gfc_namespace *ns)
|
{
|
{
|
gfc_namespace *n;
|
gfc_namespace *n;
|
bitmap_obstack old_obstack;
|
bitmap_obstack old_obstack;
|
|
|
for (n = ns->contained; n; n = n->sibling)
|
for (n = ns->contained; n; n = n->sibling)
|
resolve_codes (n);
|
resolve_codes (n);
|
|
|
gfc_current_ns = ns;
|
gfc_current_ns = ns;
|
|
|
/* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
|
/* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
|
if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
|
if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
|
cs_base = NULL;
|
cs_base = NULL;
|
|
|
/* Set to an out of range value. */
|
/* Set to an out of range value. */
|
current_entry_id = -1;
|
current_entry_id = -1;
|
|
|
old_obstack = labels_obstack;
|
old_obstack = labels_obstack;
|
bitmap_obstack_initialize (&labels_obstack);
|
bitmap_obstack_initialize (&labels_obstack);
|
|
|
resolve_code (ns->code, ns);
|
resolve_code (ns->code, ns);
|
|
|
bitmap_obstack_release (&labels_obstack);
|
bitmap_obstack_release (&labels_obstack);
|
labels_obstack = old_obstack;
|
labels_obstack = old_obstack;
|
}
|
}
|
|
|
|
|
/* This function is called after a complete program unit has been compiled.
|
/* This function is called after a complete program unit has been compiled.
|
Its purpose is to examine all of the expressions associated with a program
|
Its purpose is to examine all of the expressions associated with a program
|
unit, assign types to all intermediate expressions, make sure that all
|
unit, assign types to all intermediate expressions, make sure that all
|
assignments are to compatible types and figure out which names refer to
|
assignments are to compatible types and figure out which names refer to
|
which functions or subroutines. */
|
which functions or subroutines. */
|
|
|
void
|
void
|
gfc_resolve (gfc_namespace *ns)
|
gfc_resolve (gfc_namespace *ns)
|
{
|
{
|
gfc_namespace *old_ns;
|
gfc_namespace *old_ns;
|
code_stack *old_cs_base;
|
code_stack *old_cs_base;
|
|
|
if (ns->resolved)
|
if (ns->resolved)
|
return;
|
return;
|
|
|
ns->resolved = -1;
|
ns->resolved = -1;
|
old_ns = gfc_current_ns;
|
old_ns = gfc_current_ns;
|
old_cs_base = cs_base;
|
old_cs_base = cs_base;
|
|
|
resolve_types (ns);
|
resolve_types (ns);
|
resolve_codes (ns);
|
resolve_codes (ns);
|
|
|
gfc_current_ns = old_ns;
|
gfc_current_ns = old_ns;
|
cs_base = old_cs_base;
|
cs_base = old_cs_base;
|
ns->resolved = 1;
|
ns->resolved = 1;
|
}
|
}
|
|
|
