/* Perform type resolution on the various structures.
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010, 2011
+ 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "config.h"
#include "system.h"
+#include "coretypes.h"
#include "flags.h"
#include "gfortran.h"
#include "obstack.h"
static code_stack *cs_base = NULL;
-/* Nonzero if we're inside a FORALL block. */
+/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
static int forall_flag;
+static int do_concurrent_flag;
+
+/* True when we are resolving an expression that is an actual argument to
+ a procedure. */
+static bool actual_arg = false;
+/* True when we are resolving an expression that is the first actual argument
+ to a procedure. */
+static bool first_actual_arg = false;
+
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
}
+static gfc_try
+check_proc_interface (gfc_symbol *ifc, locus *where)
+{
+ /* Several checks for F08:C1216. */
+ if (ifc->attr.procedure)
+ {
+ gfc_error ("Interface '%s' at %L is declared "
+ "in a later PROCEDURE statement", ifc->name, where);
+ return FAILURE;
+ }
+ if (ifc->generic)
+ {
+ /* For generic interfaces, check if there is
+ a specific procedure with the same name. */
+ gfc_interface *gen = ifc->generic;
+ while (gen && strcmp (gen->sym->name, ifc->name) != 0)
+ gen = gen->next;
+ if (!gen)
+ {
+ gfc_error ("Interface '%s' at %L may not be generic",
+ ifc->name, where);
+ return FAILURE;
+ }
+ }
+ if (ifc->attr.proc == PROC_ST_FUNCTION)
+ {
+ gfc_error ("Interface '%s' at %L may not be a statement function",
+ ifc->name, where);
+ return FAILURE;
+ }
+ if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
+ || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
+ ifc->attr.intrinsic = 1;
+ if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
+ {
+ gfc_error ("Intrinsic procedure '%s' not allowed in "
+ "PROCEDURE statement at %L", ifc->name, where);
+ return FAILURE;
+ }
+ if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
+ {
+ gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where);
+ return FAILURE;
+ }
+ return SUCCESS;
+}
+
+
static void resolve_symbol (gfc_symbol *sym);
-static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
static gfc_try
resolve_procedure_interface (gfc_symbol *sym)
{
- if (sym->ts.interface == sym)
+ gfc_symbol *ifc = sym->ts.interface;
+
+ if (!ifc)
+ return SUCCESS;
+
+ if (ifc == sym)
{
gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
sym->name, &sym->declared_at);
return FAILURE;
}
- if (sym->ts.interface->attr.procedure)
- {
- gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
- "in a later PROCEDURE statement", sym->ts.interface->name,
- sym->name, &sym->declared_at);
- return FAILURE;
- }
+ if (check_proc_interface (ifc, &sym->declared_at) == FAILURE)
+ return FAILURE;
- /* Get the attributes from the interface (now resolved). */
- if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
+ if (ifc->attr.if_source || ifc->attr.intrinsic)
{
- gfc_symbol *ifc = sym->ts.interface;
+ /* Resolve interface and copy attributes. */
resolve_symbol (ifc);
-
if (ifc->attr.intrinsic)
- resolve_intrinsic (ifc, &ifc->declared_at);
+ gfc_resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
{
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
sym->attr.subroutine = ifc->attr.subroutine;
- gfc_copy_formal_args (sym, ifc);
+ gfc_copy_formal_args (sym, ifc, IFSRC_DECL);
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
sym->attr.always_explicit = ifc->attr.always_explicit;
sym->attr.ext_attr |= ifc->attr.ext_attr;
sym->attr.is_bind_c = ifc->attr.is_bind_c;
+ sym->attr.class_ok = ifc->attr.class_ok;
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
if (sym->as)
return FAILURE;
}
}
- else if (sym->ts.interface->name[0] != '\0')
- {
- gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
- sym->ts.interface->name, sym->name, &sym->declared_at);
- return FAILURE;
- }
return SUCCESS;
}
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->rank > 0))
+ || (sym->as && sym->as->rank != 0))
{
proc->attr.always_explicit = 1;
sym->attr.always_explicit = 1;
for (f = proc->formal; f; f = f->next)
{
+ gfc_array_spec *as;
+
sym = f->sym;
if (sym == NULL)
&proc->declared_at);
continue;
}
- else if (sym->attr.procedure && sym->ts.interface
- && sym->attr.if_source != IFSRC_DECL)
- resolve_procedure_interface (sym);
+ else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
+ && resolve_procedure_interface (sym) == FAILURE)
+ return;
if (sym->attr.if_source != IFSRC_UNKNOWN)
resolve_formal_arglist (sym);
- if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
+ if (sym->attr.subroutine || sym->attr.external)
{
- if (gfc_pure (proc) && !gfc_pure (sym))
- {
- gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
- "also be PURE", sym->name, &sym->declared_at);
- continue;
- }
-
- if (proc->attr.implicit_pure && !gfc_pure(sym))
- proc->attr.implicit_pure = 0;
-
- if (gfc_elemental (proc))
- {
- gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
- "procedure", &sym->declared_at);
- continue;
- }
-
- if (sym->attr.function
- && sym->ts.type == BT_UNKNOWN
- && sym->attr.intrinsic)
- {
- gfc_intrinsic_sym *isym;
- isym = gfc_find_function (sym->name);
- if (isym == NULL || !isym->specific)
- {
- gfc_error ("Unable to find a specific INTRINSIC procedure "
- "for the reference '%s' at %L", sym->name,
- &sym->declared_at);
- }
- sym->ts = isym->ts;
- }
-
- continue;
+ if (sym->attr.flavor == FL_UNKNOWN)
+ gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
+ }
+ else
+ {
+ if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
+ && (!sym->attr.function || sym->result == sym))
+ gfc_set_default_type (sym, 1, sym->ns);
}
- if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
- && (!sym->attr.function || sym->result == sym))
- gfc_set_default_type (sym, 1, sym->ns);
+ as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+ ? CLASS_DATA (sym)->as : sym->as;
- gfc_resolve_array_spec (sym->as, 0);
+ gfc_resolve_array_spec (as, 0);
/* We can't tell if an array with dimension (:) is assumed or deferred
shape until we know if it has the pointer or allocatable attributes.
*/
- if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
- && !(sym->attr.pointer || sym->attr.allocatable)
+ if (as && as->rank > 0 && as->type == AS_DEFERRED
+ && ((sym->ts.type != BT_CLASS
+ && !(sym->attr.pointer || sym->attr.allocatable))
+ || (sym->ts.type == BT_CLASS
+ && !(CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.allocatable)))
&& sym->attr.flavor != FL_PROCEDURE)
{
- sym->as->type = AS_ASSUMED_SHAPE;
- for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ as->type = AS_ASSUMED_SHAPE;
+ for (i = 0; i < as->rank; i++)
+ as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
}
- if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+ if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
+ || (as && as->type == AS_ASSUMED_RANK)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && (CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.target))
|| sym->attr.optional)
{
proc->attr.always_explicit = 1;
if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
- if (gfc_pure (proc) && !sym->attr.pointer
- && sym->attr.flavor != FL_PROCEDURE)
+ if (gfc_pure (proc))
{
- if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ if (sym->attr.flavor == FL_PROCEDURE)
{
- if (sym->attr.value)
- gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s' "
- "of pure function '%s' at %L with VALUE "
- "attribute but without INTENT(IN)", sym->name,
- proc->name, &sym->declared_at);
- else
- gfc_error ("Argument '%s' of pure function '%s' at %L must be "
- "INTENT(IN) or VALUE", sym->name, proc->name,
- &sym->declared_at);
+ /* F08:C1279. */
+ if (!gfc_pure (sym))
+ {
+ gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
+ "also be PURE", sym->name, &sym->declared_at);
+ continue;
+ }
}
-
- if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ else if (!sym->attr.pointer)
{
- if (sym->attr.value)
- gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s' "
- "of pure subroutine '%s' at %L with VALUE "
- "attribute but without INTENT", sym->name,
- proc->name, &sym->declared_at);
- else
- gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
- "have its INTENT specified or have the VALUE "
- "attribute", sym->name, proc->name, &sym->declared_at);
+ if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ {
+ if (sym->attr.value)
+ gfc_notify_std (GFC_STD_F2008, "Argument '%s'"
+ " of pure function '%s' at %L with VALUE "
+ "attribute but without INTENT(IN)",
+ sym->name, proc->name, &sym->declared_at);
+ else
+ gfc_error ("Argument '%s' of pure function '%s' at %L must "
+ "be INTENT(IN) or VALUE", sym->name, proc->name,
+ &sym->declared_at);
+ }
+
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ {
+ if (sym->attr.value)
+ gfc_notify_std (GFC_STD_F2008, "Argument '%s'"
+ " of pure subroutine '%s' at %L with VALUE "
+ "attribute but without INTENT", sym->name,
+ proc->name, &sym->declared_at);
+ else
+ gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
+ "must have its INTENT specified or have the "
+ "VALUE attribute", sym->name, proc->name,
+ &sym->declared_at);
+ }
}
}
- if (proc->attr.implicit_pure && !sym->attr.pointer
- && sym->attr.flavor != FL_PROCEDURE)
+ if (proc->attr.implicit_pure)
{
- if (proc->attr.function && sym->attr.intent != INTENT_IN)
- proc->attr.implicit_pure = 0;
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ if (!gfc_pure(sym))
+ proc->attr.implicit_pure = 0;
+ }
+ else if (!sym->attr.pointer)
+ {
+ if (proc->attr.function && sym->attr.intent != INTENT_IN
+ && !sym->value)
+ proc->attr.implicit_pure = 0;
- if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
- proc->attr.implicit_pure = 0;
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
+ && !sym->value)
+ proc->attr.implicit_pure = 0;
+ }
}
if (gfc_elemental (proc))
{
- /* F2008, C1289. */
- if (sym->attr.codimension)
+ /* F08:C1289. */
+ if (sym->attr.codimension
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.codimension))
{
gfc_error ("Coarray dummy argument '%s' at %L to elemental "
"procedure", sym->name, &sym->declared_at);
continue;
}
- if (sym->as != NULL)
+ if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->as))
{
gfc_error ("Argument '%s' of elemental procedure at %L must "
"be scalar", sym->name, &sym->declared_at);
continue;
}
- if (sym->attr.allocatable)
+ if (sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.allocatable))
{
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
"have the ALLOCATABLE attribute", sym->name,
continue;
}
- if (sym->attr.pointer)
+ if (sym->attr.pointer
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.class_pointer))
{
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
"have the POINTER attribute", sym->name,
static void
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
+ || sym->attr.flavor == FL_DERIVED)
return;
resolve_formal_arglist (sym);
&& ts->u.cl->length->expr_type == EXPR_CONSTANT
&& mpz_cmp (ts->u.cl->length->value.integer,
fts->u.cl->length->value.integer) != 0)))
- gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
+ gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
"entries returning variables of different "
"string lengths", ns->entries->sym->name,
&ns->entries->sym->declared_at);
gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
sym->name, &common_root->n.common->where, &sym->declared_at);
+ if (sym->attr.external)
+ gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
+ sym->name, &common_root->n.common->where);
+
if (sym->attr.intrinsic)
gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
sym->name, &common_root->n.common->where);
else if (sym->attr.result
|| gfc_is_function_return_value (sym, gfc_current_ns))
- gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
+ gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L "
"that is also a function result", sym->name,
&common_root->n.common->where);
else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
&& sym->attr.proc != PROC_ST_FUNCTION)
- gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
+ gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L "
"that is also a global procedure", sym->name,
&common_root->n.common->where);
}
}
+static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
+
+
/* Resolve all of the elements of a structure constructor and make sure that
the types are correct. The 'init' flag indicates that the given
constructor is an initializer. */
t = SUCCESS;
if (expr->ts.type == BT_DERIVED)
- resolve_symbol (expr->ts.u.derived);
+ resolve_fl_derived0 (expr->ts.u.derived);
cons = gfc_constructor_first (expr->value.constructor);
- /* A constructor may have references if it is the result of substituting a
- parameter variable. In this case we just pull out the component we
- want. */
- if (expr->ref)
- comp = expr->ref->u.c.sym->components;
- else
- comp = expr->ts.u.derived->components;
/* See if the user is trying to invoke a structure constructor for one of
the iso_c_binding derived types. */
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
return SUCCESS;
+ /* A constructor may have references if it is the result of substituting a
+ parameter variable. In this case we just pull out the component we
+ want. */
+ if (expr->ref)
+ comp = expr->ref->u.c.sym->components;
+ else
+ comp = expr->ts.u.derived->components;
+
for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
int rank;
if (cons->expr->expr_type != EXPR_NULL && rank != 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 structure "
"constructor at %L does not match that of the "
"component (%d/%d)", &cons->expr->where,
cons->expr->rank, rank);
t = SUCCESS;
}
else 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 structure constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
gfc_basic_typename (cons->expr->ts.type),
&& comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
&& cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
&& cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && cons->expr->rank != 0
&& mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
comp->ts.u.cl->length->value.integer) != 0)
{
|| CLASS_DATA (comp)->attr.allocatable))))
{
t = FAILURE;
- gfc_error ("The NULL in the derived type constructor at %L is "
+ gfc_error ("The NULL in the structure constructor at %L is "
"being applied to component '%s', which is neither "
"a POINTER nor ALLOCATABLE", &cons->expr->where,
comp->name);
}
+ if (comp->attr.proc_pointer && comp->ts.interface)
+ {
+ /* Check procedure pointer interface. */
+ gfc_symbol *s2 = NULL;
+ gfc_component *c2;
+ const char *name;
+ char err[200];
+
+ c2 = gfc_get_proc_ptr_comp (cons->expr);
+ if (c2)
+ {
+ s2 = c2->ts.interface;
+ name = c2->name;
+ }
+ else if (cons->expr->expr_type == EXPR_FUNCTION)
+ {
+ s2 = cons->expr->symtree->n.sym->result;
+ name = cons->expr->symtree->n.sym->result->name;
+ }
+ else if (cons->expr->expr_type != EXPR_NULL)
+ {
+ s2 = cons->expr->symtree->n.sym;
+ name = cons->expr->symtree->n.sym->name;
+ }
+
+ if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
+ err, sizeof (err), NULL, NULL))
+ {
+ gfc_error ("Interface mismatch for procedure-pointer component "
+ "'%s' in structure constructor at %L: %s",
+ comp->name, &cons->expr->where, err);
+ return FAILURE;
+ }
+ }
+
if (!comp->attr.pointer || comp->attr.proc_pointer
|| cons->expr->expr_type == EXPR_NULL)
continue;
if (!a.pointer && !a.target)
{
t = FAILURE;
- gfc_error ("The element in the derived type constructor at %L, "
+ gfc_error ("The element in the structure constructor at %L, "
"for pointer component '%s' should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
|| gfc_is_coindexed (cons->expr)))
{
t = FAILURE;
- gfc_error ("Invalid expression in the derived type constructor for "
+ gfc_error ("Invalid expression in the structure constructor for "
"pointer component '%s' at %L in PURE procedure",
comp->name, &cons->expr->where);
}
/* 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 RECURSIVE declaration. This means that either sym is the current
context itself, or sym is the parent of a contained procedure calling its
non-RECURSIVE containing procedure.
This also works if sym is an ENTRY. */
gfc_symbol* context_proc;
gfc_namespace* real_context;
- if (sym->attr.flavor == FL_PROGRAM)
+ if (sym->attr.flavor == FL_PROGRAM
+ || sym->attr.flavor == FL_DERIVED)
return false;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
its typespec and formal argument list. */
-static gfc_try
-resolve_intrinsic (gfc_symbol *sym, locus *loc)
+gfc_try
+gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
{
gfc_intrinsic_sym* isym = NULL;
const char* symstd;
if (sym->intmod_sym_id)
isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
- else
+ else if (!sym->attr.subroutine)
isym = gfc_find_function (sym->name);
if (isym)
sym = expr->symtree->n.sym;
if (sym->attr.intrinsic)
- resolve_intrinsic (sym, &expr->where);
+ gfc_resolve_intrinsic (sym, &expr->where);
if (sym->attr.flavor != FL_PROCEDURE
|| (sym->attr.function && sym->result == sym))
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
+ gfc_try return_value = FAILURE;
+ bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
+
+ actual_arg = true;
+ first_actual_arg = true;
for (; arg; arg = arg->next)
{
{
gfc_error ("Label %d referenced at %L is never defined",
arg->label->value, &arg->label->where);
- return FAILURE;
+ goto cleanup;
}
}
+ first_actual_arg = false;
continue;
}
&& e->symtree->n.sym->attr.generic
&& no_formal_args
&& count_specific_procs (e) != 1)
- return FAILURE;
+ goto cleanup;
if (e->ts.type != BT_PROCEDURE)
{
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
- return FAILURE;
+ goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
goto argument_list;
}
/* If a procedure is not already determined to be something else
check if it is intrinsic. */
- if (!sym->attr.intrinsic
- && !(sym->attr.external || sym->attr.use_assoc
- || sym->attr.if_source == IFSRC_IFBODY)
- && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
+ if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
{
if (gfc_notify_std (GFC_STD_F2008,
- "Fortran 2008: Internal procedure '%s' is"
+ "Internal procedure '%s' is"
" used as actual argument at %L",
sym->name, &e->where) == FAILURE)
- return FAILURE;
+ goto cleanup;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
/* Check if a generic interface has a specific procedure
with the same name before emitting an error. */
if (sym->attr.generic && count_specific_procs (e) != 1)
- return FAILURE;
-
+ goto cleanup;
+
/* Just in case a specific was found for the expression. */
sym = e->symtree->n.sym;
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
&e->where);
- return FAILURE;
+ goto cleanup;
}
sym->ts = isym->ts;
sym->attr.intrinsic = 1;
}
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto cleanup;
goto argument_list;
}
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);
- return FAILURE;
+ goto cleanup;
}
if (parent_st == NULL)
|| sym->attr.external)
{
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto cleanup;
goto argument_list;
}
got_variable:
e->expr_type = EXPR_VARIABLE;
e->ts = sym->ts;
- if (sym->as != NULL)
+ if ((sym->as != NULL && sym->ts.type != BT_CLASS)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as))
{
- e->rank = sym->as->rank;
+ e->rank = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as->rank : sym->as->rank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
- e->ref->u.ar.as = sym->as;
+ e->ref->u.ar.as = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as : sym->as;
}
/* Expressions are assigned a default ts.type of BT_PROCEDURE in
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
- return FAILURE;
+ goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
argument_list:
{
gfc_error ("By-value argument at %L is not of numeric "
"type", &e->where);
- return FAILURE;
+ goto cleanup;
}
if (e->rank)
{
gfc_error ("By-value argument at %L cannot be an array or "
"an array section", &e->where);
- return FAILURE;
+ goto cleanup;
}
/* Intrinsics are still PROC_UNKNOWN here. However,
{
gfc_error ("By-value argument at %L is not allowed "
"in this context", &e->where);
- return FAILURE;
+ goto cleanup;
}
}
{
gfc_error ("Passing internal procedure at %L by location "
"not allowed", &e->where);
- return FAILURE;
+ goto cleanup;
}
}
}
/* Fortran 2008, C1237. */
if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
- && gfc_has_ultimate_pointer (e))
- {
- gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+ && gfc_has_ultimate_pointer (e))
+ {
+ gfc_error ("Coindexed actual argument at %L with ultimate pointer "
"component", &e->where);
- return FAILURE;
- }
+ goto cleanup;
+ }
+
+ first_actual_arg = false;
}
- return SUCCESS;
+ return_value = SUCCESS;
+
+cleanup:
+ actual_arg = actual_arg_sav;
+ first_actual_arg = first_actual_arg_sav;
+
+ return return_value;
}
/* The rank of an elemental is the rank of its array argument(s). */
for (arg = arg0; arg; arg = arg->next)
{
- if (arg->expr != NULL && arg->expr->rank > 0)
+ if (arg->expr != NULL && arg->expr->rank != 0)
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
"ELEMENTAL procedure unless there is a non-optional "
"argument with the same rank (12.4.1.5)",
arg->expr->symtree->n.sym->name, &arg->expr->where);
- return FAILURE;
}
}
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* TS 29113, 6.2. */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_RANK)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
/* F2008, 12.4.2.2 (2c) */
else if (arg->sym->attr.codimension)
{
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* As assumed-type is unlimited polymorphic (cf. above).
+ See also TS 29113, Note 6.1. */
+ else if (arg->sym->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-type dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
}
if (def_sym->attr.function)
{
gfc_symbol *sym;
match m;
+ gfc_interface *intr = NULL;
sym = expr->symtree->n.sym;
return FAILURE;
generic:
+ if (!intr)
+ for (intr = sym->generic; intr; intr = intr->next)
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ break;
+
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
/* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */
- if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
+ if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
{
- gfc_error ("There is no specific function for the generic '%s' at %L",
- expr->symtree->n.sym->name, &expr->where);
+ gfc_error ("There is no specific function for the generic '%s' "
+ "at %L", expr->symtree->n.sym->name, &expr->where);
return FAILURE;
}
+ if (intr)
+ {
+ if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
+ false) != SUCCESS)
+ return FAILURE;
+ return resolve_structure_cons (expr, 0);
+ }
+
m = gfc_intrinsic_func_interface (expr, 0);
if (m == MATCH_YES)
return SUCCESS;
+
if (m == MATCH_NO)
gfc_error ("Generic function '%s' at %L is not consistent with a "
"specific intrinsic interface", expr->symtree->n.sym->name,
is_external_proc (gfc_symbol *sym)
{
if (!sym->attr.dummy && !sym->attr.contained
- && !(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_pointer
&& !sym->attr.use_assoc
gfc_symbol **new_sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
int optional_arg = 0;
gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
{
/* two args. */
sprintf (name, "%s_2", sym->name);
- sprintf (binding_label, "%s_2", sym->binding_label);
optional_arg = 1;
}
else
{
/* one arg. */
sprintf (name, "%s_1", sym->name);
- sprintf (binding_label, "%s_1", sym->binding_label);
optional_arg = 0;
}
/* Get a new symbol for the version of c_associated that
will get called. */
- *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
+ *new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
sprintf (name, "%s", sym->name);
- sprintf (binding_label, "%s", sym->binding_label);
/* Error check the call. */
if (args->next != NULL)
&(args->expr->where));
/* See if we have interoperable type and type param. */
- if (verify_c_interop (arg_ts) == SUCCESS
+ if (gfc_verify_c_interop (arg_ts) == SUCCESS
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
{
if (args_sym->attr.target == 1)
{
/* TODO: Update this error message to allow for procedure
pointers once they are implemented. */
- gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+ gfc_error_now ("Argument '%s' to '%s' at %L must be a "
"procedure",
args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
- else if (args_sym->attr.is_bind_c != 1)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must be "
- "BIND(C)",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
+ else if (args_sym->attr.is_bind_c != 1
+ && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
+ "argument '%s' to '%s' at %L",
+ args_sym->name, sym->name,
+ &(args->expr->where)) == FAILURE)
+ retval = FAILURE;
}
/* for c_loc/c_funloc, the new symbol is the same as the old one */
sym = expr->symtree->n.sym;
/* 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))
return SUCCESS;
-
+
if (sym && sym->attr.intrinsic
- && resolve_intrinsic (sym, &expr->where) == FAILURE)
+ && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE)
return FAILURE;
if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
{
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_flag == 2 ? "mask" : "block");
t = FAILURE;
}
+ else if (do_concurrent_flag)
+ {
+ gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+ "DO CONCURRENT %s", name, &expr->where,
+ do_concurrent_flag == 2 ? "mask" : "block");
+ t = FAILURE;
+ }
else if (gfc_pure (NULL))
{
gfc_error ("Function reference to '%s' at %L is to a non-PURE "
"procedure within a PURE procedure", name, &expr->where);
t = FAILURE;
}
- }
- if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ }
/* Functions without the RECURSIVE attribution are not allowed to
* call themselves. */
if (forall_flag)
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
sym->name, &c->loc);
+ else if (do_concurrent_flag)
+ gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
+ "PURE", sym->name, &c->loc);
else if (gfc_pure (NULL))
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
&c->loc);
+
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
}
static void
set_name_and_label (gfc_code *c, gfc_symbol *sym,
- char *name, char *binding_label)
+ char *name, const char **binding_label)
{
gfc_expr *arg = NULL;
char type;
sprintf (name, "%s_%c%d", sym->name, type, kind);
/* Set up the binding label as the given symbol's label plus
the type and kind. */
- sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
+ *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
+ kind);
}
else
{
was, cause it should at least be found, and the missing
arg error will be caught by compare_parameters(). */
sprintf (name, "%s", sym->name);
- sprintf (binding_label, "%s", sym->binding_label);
+ *binding_label = sym->binding_label;
}
return;
gfc_symbol *new_sym;
/* this is fine, since we know the names won't use the max */
char name[GFC_MAX_SYMBOL_LEN + 1];
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ const char* binding_label;
/* default to success; will override if find error */
match m = MATCH_YES;
/* Make sure the actual arguments are in the necessary order (based on the
formal args) before resolving. */
- gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
+ if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
+ {
+ c->resolved_sym = sym;
+ return MATCH_ERROR;
+ }
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
(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 (c->ext.actual != NULL && c->ext.actual->next != NULL)
{
+ if (c->ext.actual->expr->ts.type != BT_DERIVED
+ || c->ext.actual->expr->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR)
+ {
+ gfc_error ("Argument at %L to C_F_POINTER shall have the type"
+ " C_PTR", &c->ext.actual->expr->where);
+ m = MATCH_ERROR;
+ }
+
/* 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
correct since we short-circuit this check in
}
}
}
-
+ else /* ISOCBINDING_F_PROCPOINTER. */
+ {
+ if (c->ext.actual
+ && (c->ext.actual->expr->ts.type != BT_DERIVED
+ || c->ext.actual->expr->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_FUNPTR))
+ {
+ gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
+ "C_FUNPTR", &c->ext.actual->expr->where);
+ m = MATCH_ERROR;
+ }
+ if (c->ext.actual && c->ext.actual->next
+ && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c
+ && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
+ "procedure-pointer at %L to C_F_FUNPOINTER",
+ &c->ext.actual->next->expr->where)
+ == FAILURE)
+ m = MATCH_ERROR;
+ }
+
if (m != MATCH_ERROR)
{
/* the 1 means to add the optional arg to formal list */
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_default_logical_kind;
+
+ if (gfc_option.warn_compare_reals)
+ {
+ gfc_intrinsic_op op = e->value.op.op;
+
+ /* Type conversion has made sure that the types of op1 and op2
+ agree, so it is only necessary to check the first one. */
+ if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
+ && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
+ || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
+ {
+ const char *msg;
+
+ if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
+ msg = "Equality comparison for %s at %L";
+ else
+ msg = "Inequality comparison for %s at %L";
+
+ gfc_warning (msg, gfc_typename (&op1->ts), &op1->where);
+ }
+ }
+
break;
}
bad_op:
{
- bool real_error;
- if (gfc_extend_expr (e, &real_error) == SUCCESS)
+ match m = gfc_extend_expr (e);
+ if (m == MATCH_YES)
return SUCCESS;
-
- if (real_error)
+ if (m == MATCH_ERROR)
return FAILURE;
}
return FAILURE;
}
- if (as->corank && ar->codimen == 0)
- {
- int n;
- ar->codimen = as->corank;
- for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
- ar->dimen_type[n] = DIMEN_THIS_IMAGE;
- }
-
return SUCCESS;
}
}
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, "REAL array index at %L",
&index->where) == FAILURE)
return FAILURE;
{
gfc_array_spec *as;
gfc_component *c;
- gfc_symbol *derived;
gfc_ref *ref;
if (e->symtree->n.sym->ts.type == BT_CLASS)
as = CLASS_DATA (e->symtree->n.sym)->as;
else
as = e->symtree->n.sym->as;
- derived = NULL;
for (ref = e->ref; ref; ref = ref->next)
switch (ref->type)
break;
case REF_COMPONENT:
- if (derived == NULL)
- derived = e->symtree->n.sym->ts.u.derived;
-
- if (derived->attr.is_class)
- derived = derived->components->ts.u.derived;
-
- c = derived->components;
-
- for (; c; c = c->next)
- if (c == ref->u.c.component)
- {
- /* Track the sequence of component references. */
- if (c->ts.type == BT_DERIVED)
- derived = c->ts.u.derived;
- break;
- }
-
- if (c == NULL)
- gfc_internal_error ("find_array_spec(): Component not found");
-
+ c = ref->u.c.component;
if (c->attr.dimension)
{
if (as != NULL)
/* Fill in the upper bound, which may be lower than the
specified one for something like a(2:10:5), which is
identical to a(2:7:5). Only relevant for strides not equal
- to one. */
+ to one. Don't try a division by zero. */
if (ar->dimen_type[i] == DIMEN_RANGE
&& ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
+ && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
+ && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
{
mpz_t size, end;
}
}
- if (ar->type == AR_FULL && ar->as->rank == 0)
- ar->type = AR_ELEMENT;
+ if (ar->type == AR_FULL)
+ {
+ if (ar->as->rank == 0)
+ ar->type = AR_ELEMENT;
+
+ /* Make sure array is the same as array(:,:), this way
+ we don't need to special case all the time. */
+ ar->dimen = ar->as->rank;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ ar->dimen_type[i] = DIMEN_RANGE;
+
+ gcc_assert (ar->start[i] == NULL);
+ gcc_assert (ar->end[i] == NULL);
+ gcc_assert (ar->stride[i] == NULL);
+ }
+ }
/* If the reference type is unknown, figure out what kind it is. */
if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
return FAILURE;
+ if (ar->as->corank && ar->codimen == 0)
+ {
+ int n;
+ ar->codimen = ar->as->corank;
+ for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
+ ar->dimen_type[n] = DIMEN_THIS_IMAGE;
+ }
+
return SUCCESS;
}
break;
case REF_SUBSTRING:
- resolve_substring (ref);
+ if (resolve_substring (ref) == FAILURE)
+ return FAILURE;
break;
}
{
/* F03:C614. */
if (ref->u.c.component->attr.pointer
- || ref->u.c.component->attr.proc_pointer)
+ || ref->u.c.component->attr.proc_pointer
+ || (ref->u.c.component->ts.type == BT_CLASS
+ && CLASS_DATA (ref->u.c.component)->attr.pointer))
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the POINTER "
"attribute at %L", &expr->where);
return FAILURE;
}
- else if (ref->u.c.component->attr.allocatable)
+ else if (ref->u.c.component->attr.allocatable
+ || (ref->u.c.component->ts.type == BT_CLASS
+ && CLASS_DATA (ref->u.c.component)->attr.allocatable))
+
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the ALLOCATABLE "
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
- if (e->rank == 0 || e->shape != NULL)
+ if (e->rank <= 0 || e->shape != NULL)
return;
for (i = 0; i < e->rank; i++)
return FAILURE;
sym = e->symtree->n.sym;
- /* If this is an associate-name, it may be parsed with an array reference
- in error even though the target is scalar. Fail directly in this case. */
- if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
- return FAILURE;
-
- /* On the other hand, the parser may not have known this is an array;
- in this case, we have to add a FULL reference. */
- if (sym->assoc && sym->attr.dimension && !e->ref)
+ /* TS 29113, 407b. */
+ if (e->ts.type == BT_ASSUMED)
{
- e->ref = gfc_get_ref ();
- e->ref->type = REF_ARRAY;
+ if (!actual_arg)
+ {
+ gfc_error ("Assumed-type variable %s at %L may only be used "
+ "as actual argument", sym->name, &e->where);
+ return FAILURE;
+ }
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is
+ that the function-name resolution happens too late in that
+ function. */
+ gfc_error ("Assumed-type variable %s at %L as actual argument to "
+ "an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
+ }
+
+ /* TS 29113, C535b. */
+ if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ {
+ if (!actual_arg)
+ {
+ gfc_error ("Assumed-rank variable %s at %L may only be used as "
+ "actual argument", sym->name, &e->where);
+ return FAILURE;
+ }
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is
+ that the function-name resolution happens too late in that
+ function. */
+ gfc_error ("Assumed-rank variable %s at %L as actual argument "
+ "to an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
+ }
+
+ /* TS 29113, 407b. */
+ if (e->ts.type == BT_ASSUMED && e->ref
+ && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+ && e->ref->next == NULL))
+ {
+ gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
+ "reference", sym->name, &e->ref->u.ar.where);
+ return FAILURE;
+ }
+
+ /* TS 29113, C535b. */
+ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && e->ref
+ && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+ && e->ref->next == NULL))
+ {
+ gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
+ "reference", sym->name, &e->ref->u.ar.where);
+ return FAILURE;
+ }
+
+
+ /* If this is an associate-name, it may be parsed with an array reference
+ in error even though the target is scalar. Fail directly in this case.
+ TODO Understand why class scalar expressions must be excluded. */
+ if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
+ {
+ if (sym->ts.type == BT_CLASS)
+ gfc_fix_class_refs (e);
+ if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
+ return FAILURE;
+ }
+
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
+ sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
+
+ /* On the other hand, the parser may not have known this is an array;
+ in this case, we have to add a FULL reference. */
+ if (sym->assoc && sym->attr.dimension && !e->ref)
+ {
+ e->ref = gfc_get_ref ();
+ e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
e->ref->u.ar.dimen = 0;
}
if (check_assumed_size_reference (sym, e))
return FAILURE;
+ /* If a PRIVATE variable is used in the specification expression of the
+ result variable, it might be accessed from outside the module and can
+ thus not be TREE_PUBLIC() = 0.
+ TODO: sym->attr.public_used only has to be set for the result variable's
+ type-parameter expression and not for dummies or automatic variables.
+ Additionally, it only has to be set if the function is either PUBLIC or
+ used in a generic interface or TBP; unfortunately,
+ proc_name->attr.public_used can get set at a later stage. */
+ if (specification_expr && sym->attr.access == ACCESS_PRIVATE
+ && !sym->attr.function && !sym->attr.use_assoc
+ && gfc_current_ns->proc_name && gfc_current_ns->proc_name->attr.function)
+ sym->attr.public_used = 1;
+
/* Deal with forward references to entries during resolve_code, to
satisfy, at least partially, 12.5.2.5. */
if (gfc_current_ns->entries
&& sym->attr.contained)
{
/* Clear the shape, since it might not be valid. */
- if (e->shape != NULL)
- {
- for (n = 0; n < e->rank; n++)
- mpz_clear (e->shape[n]);
-
- free (e->shape);
- }
+ gfc_free_shape (&e->shape, e->rank);
/* Give the expression the right symtree! */
gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
{
/* Original was variable so convert array references into
an actual arglist. This does not need any checking now
- since gfc_resolve_function will take care of it. */
+ since resolve_function will take care of it. */
e->value.function.actual = NULL;
e->expr_type = EXPR_FUNCTION;
e->symtree = st;
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
if (!e1 || !e2)
- return;
+ {
+ gfc_free_expr (e1);
+ gfc_free_expr (e2);
+
+ return;
+ }
e->ts.u.cl->length = gfc_add (e1, e2);
e->ts.u.cl->length->ts.type = BT_INTEGER;
gfc_component *ppc;
gfc_typebound_proc* tb;
- if (!gfc_is_proc_ptr_comp (e, &ppc))
+ ppc = gfc_get_proc_ptr_comp (e);
+ if (!ppc)
return FAILURE;
tb = ppc->tb;
return FAILURE;
/* F08:R739. */
- if (po->rank > 0)
+ if (po->rank != 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+ if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
+ return FAILURE;
+
/* F08:C611. */
if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
{
/* F08:C1230. 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"
" be scalar", &e->where);
goto cleanup;
}
- /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
- if (base->rank > 0)
- {
- gfc_error ("Non-scalar base object at %L currently not implemented",
- &e->where);
- goto cleanup;
- }
-
return_value = SUCCESS;
cleanup:
e->ref = NULL;
e->value.compcall.actual = NULL;
+ /* If we find a deferred typebound procedure, check for derived types
+ that an overriding typebound procedure has not been missed. */
+ if (e->value.compcall.name
+ && !e->value.compcall.tbp->non_overridable
+ && e->value.compcall.base_object
+ && e->value.compcall.base_object->ts.type == BT_DERIVED)
+ {
+ gfc_symtree *st;
+ gfc_symbol *derived;
+
+ /* Use the derived type of the base_object. */
+ derived = e->value.compcall.base_object->ts.u.derived;
+ st = NULL;
+
+ /* If necessary, go through the inheritance chain. */
+ while (!st && derived)
+ {
+ /* Look for the typebound procedure 'name'. */
+ if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
+ st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
+ e->value.compcall.name);
+ if (!st)
+ derived = gfc_get_derived_super_type (derived);
+ }
+
+ /* Now find the specific name in the derived type namespace. */
+ if (st && st->n.tb && st->n.tb->u.specific)
+ gfc_find_sym_tree (st->n.tb->u.specific->name,
+ derived->ns, 1, &st);
+ if (st)
+ *target = st;
+ }
return SUCCESS;
}
/* Get the ultimate declared type from an expression. In addition,
return the last class/derived type reference and the copy of the
- reference list. */
+ reference list. If check_types is set true, derived types are
+ identified as well as class references. */
static gfc_symbol*
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
- gfc_expr *e)
+ gfc_expr *e, bool check_types)
{
gfc_symbol *declared;
gfc_ref *ref;
if (ref->type != REF_COMPONENT)
continue;
- if (ref->u.c.component->ts.type == BT_CLASS
- || ref->u.c.component->ts.type == BT_DERIVED)
+ if ((ref->u.c.component->ts.type == BT_CLASS
+ || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
+ && ref->u.c.component->attr.flavor != FL_PROCEDURE)
{
declared = ref->u.c.component->ts.u.derived;
if (class_ref)
success:
/* Make sure that we have the right specific instance for the name. */
- derived = get_declared_from_expr (NULL, NULL, e);
+ derived = get_declared_from_expr (NULL, NULL, e, true);
st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
const char *name;
gfc_typespec ts;
gfc_expr *expr;
+ bool overridable;
st = e->symtree;
/* Deal with typebound operators for CLASS objects. */
expr = e->value.compcall.base_object;
+ overridable = !e->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
+ /* If the base_object is not a variable, the corresponding actual
+ argument expression must be stored in e->base_expression so
+ that the corresponding tree temporary can be used as the base
+ object in gfc_conv_procedure_call. */
+ if (expr->expr_type != EXPR_VARIABLE)
+ {
+ gfc_actual_arglist *args;
+
+ for (args= e->value.function.actual; args; args = args->next)
+ {
+ if (expr == args->expr)
+ expr = args->expr;
+ }
+ }
+
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
name = name ? name : e->value.function.esym->name;
e->symtree = expr->symtree;
e->ref = gfc_copy_ref (expr->ref);
+ get_declared_from_expr (&class_ref, NULL, e, false);
+
+ /* Trim away the extraneous references that emerge from nested
+ use of interface.c (extend_expr). */
+ if (class_ref && class_ref->next)
+ {
+ gfc_free_ref_list (class_ref->next);
+ class_ref->next = NULL;
+ }
+ else if (e->ref && !class_ref)
+ {
+ gfc_free_ref_list (e->ref);
+ e->ref = NULL;
+ }
+
gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
e->value.function.esym = NULL;
+ if (expr->expr_type != EXPR_VARIABLE)
+ e->base_expr = expr;
return SUCCESS;
}
return FAILURE;
/* 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, true);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
return FAILURE;
ts = e->ts;
- /* Then convert the expression to a procedure pointer component call. */
- e->value.function.esym = NULL;
- e->symtree = st;
+ if (overridable)
+ {
+ /* Convert the expression to a procedure pointer component call. */
+ e->value.function.esym = NULL;
+ e->symtree = st;
+
+ if (new_ref)
+ e->ref = new_ref;
- if (new_ref)
- e->ref = new_ref;
+ /* '_vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_vptr_component (e);
+ gfc_add_component_ref (e, name);
- /* '_vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_vptr_component (e);
- gfc_add_component_ref (e, name);
+ /* Recover the typespec for the expression. This is really only
+ necessary for generic procedures, where the additional call
+ to gfc_add_component_ref seems to throw the collection of the
+ correct typespec. */
+ e->ts = ts;
+ }
- /* Recover the typespec for the expression. This is really only
- necessary for generic procedures, where the additional call
- to gfc_add_component_ref seems to throw the collection of the
- correct typespec. */
- e->ts = ts;
return SUCCESS;
}
const char *name;
gfc_typespec ts;
gfc_expr *expr;
+ bool overridable;
st = code->expr1->symtree;
/* Deal with typebound operators for CLASS objects. */
expr = code->expr1->value.compcall.base_object;
+ overridable = !code->expr1->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
{
+ /* If the base_object is not a variable, the corresponding actual
+ argument expression must be stored in e->base_expression so
+ that the corresponding tree temporary can be used as the base
+ object in gfc_conv_procedure_call. */
+ if (expr->expr_type != EXPR_VARIABLE)
+ {
+ gfc_actual_arglist *args;
+
+ args= code->expr1->value.function.actual;
+ for (; args; args = args->next)
+ if (expr == args->expr)
+ expr = args->expr;
+ }
+
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
name = name ? name : code->expr1->value.function.esym->name;
code->expr1->symtree = expr->symtree;
code->expr1->ref = gfc_copy_ref (expr->ref);
+
+ /* Trim away the extraneous references that emerge from nested
+ use of interface.c (extend_expr). */
+ get_declared_from_expr (&class_ref, NULL, code->expr1, false);
+ if (class_ref && class_ref->next)
+ {
+ gfc_free_ref_list (class_ref->next);
+ class_ref->next = NULL;
+ }
+ else if (code->expr1->ref && !class_ref)
+ {
+ gfc_free_ref_list (code->expr1->ref);
+ code->expr1->ref = NULL;
+ }
+
+ /* Now use the procedure in the vtable. */
gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
code->expr1->value.function.esym = NULL;
+ if (expr->expr_type != EXPR_VARIABLE)
+ code->expr1->base_expr = expr;
return SUCCESS;
}
return FAILURE;
/* Get the CLASS declared type. */
- get_declared_from_expr (&class_ref, &new_ref, code->expr1);
+ get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
return FAILURE;
ts = code->expr1->ts;
- /* Then convert the expression to a procedure pointer component call. */
- code->expr1->value.function.esym = NULL;
- code->expr1->symtree = st;
+ if (overridable)
+ {
+ /* Convert the expression to a procedure pointer component call. */
+ code->expr1->value.function.esym = NULL;
+ code->expr1->symtree = st;
- if (new_ref)
- code->expr1->ref = new_ref;
+ if (new_ref)
+ code->expr1->ref = new_ref;
- /* '_vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_vptr_component (code->expr1);
- gfc_add_component_ref (code->expr1, name);
+ /* '_vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_vptr_component (code->expr1);
+ gfc_add_component_ref (code->expr1, name);
+
+ /* Recover the typespec for the expression. This is really only
+ necessary for generic procedures, where the additional call
+ to gfc_add_component_ref seems to throw the collection of the
+ correct typespec. */
+ code->expr1->ts = ts;
+ }
- /* Recover the typespec for the expression. This is really only
- necessary for generic procedures, where the additional call
- to gfc_add_component_ref seems to throw the collection of the
- correct typespec. */
- code->expr1->ts = ts;
return SUCCESS;
}
resolve_ppc_call (gfc_code* c)
{
gfc_component *comp;
- bool b;
- b = gfc_is_proc_ptr_comp (c->expr1, &comp);
- gcc_assert (b);
+ comp = gfc_get_proc_ptr_comp (c->expr1);
+ gcc_assert (comp != NULL);
c->resolved_sym = c->expr1->symtree->n.sym;
c->expr1->expr_type = EXPR_VARIABLE;
resolve_expr_ppc (gfc_expr* e)
{
gfc_component *comp;
- bool b;
- b = gfc_is_proc_ptr_comp (e, &comp);
- gcc_assert (b);
+ comp = gfc_get_proc_ptr_comp (e);
+ gcc_assert (comp != NULL);
/* Convert to EXPR_FUNCTION. */
e->expr_type = EXPR_FUNCTION;
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
- bool inquiry_save;
+ bool inquiry_save, actual_arg_save, first_actual_arg_save;
if (e == NULL)
return SUCCESS;
/* inquiry_argument only applies to variables. */
inquiry_save = inquiry_argument;
+ actual_arg_save = actual_arg;
+ first_actual_arg_save = first_actual_arg;
+
if (e->expr_type != EXPR_VARIABLE)
- inquiry_argument = false;
+ {
+ inquiry_argument = false;
+ actual_arg = false;
+ first_actual_arg = false;
+ }
switch (e->expr_type)
{
fixup_charlen (e);
inquiry_argument = inquiry_save;
+ actual_arg = actual_arg_save;
+ first_actual_arg = first_actual_arg_save;
return t;
}
{
if (real_ok)
return gfc_notify_std (GFC_STD_F95_DEL,
- "Deleted feature: %s at %L must be integer",
+ "%s at %L must be integer",
_(name_msgid), &expr->where);
else
{
== FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
+ if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
== FAILURE)
return FAILURE;
gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
&iter->start->where);
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, 1);
if (gfc_resolve_expr (iter->end) == SUCCESS
&& (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
&iter->end->where);
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, 1);
if (gfc_resolve_expr (iter->stride) == SUCCESS)
{
&iter->stride->where);
}
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, 1);
}
for (iter = it; iter; iter = iter->next)
switch (ref->type)
{
case REF_ARRAY:
- if (ref->u.ar.type != AR_FULL)
+ if (ref->u.ar.type != AR_FULL
+ && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
+ && ref->u.ar.codimen && gfc_ref_this_image (ref)))
allocatable = 0;
break;
}
if (pointer
- && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
+ && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
+ == FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
+ if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
+ == FAILURE)
return FAILURE;
return SUCCESS;
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;
- result->rank = ref->u.ar.dimen;
break;
}
+ gfc_free_shape (&result->shape, result->rank);
+
+ /* Recalculate rank, shape, etc. */
+ gfc_resolve_expr (result);
return result;
}
gfc_component *c;
gfc_try t;
- /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
+ /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
checking of coarrays. */
for (ref = e->ref; ref; ref = ref->next)
if (ref->next == NULL)
}
else
{
- if (sym->ts.type == BT_CLASS)
+ if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
{
allocatable = CLASS_DATA (sym)->attr.allocatable;
pointer = CLASS_DATA (sym)->attr.class_pointer;
}
}
+ /* Check for F08:C628. */
if (allocatable == 0 && pointer == 0)
{
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where, &code->expr3->where);
goto failure;
}
+
+ /* Check F2008, C642. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
+ || (code->expr3->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && code->expr3->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_LOCK_TYPE)))
+ {
+ gfc_error ("The source-expr at %L shall neither be of type "
+ "LOCK_TYPE nor have a LOCK_TYPE component if "
+ "allocate-object at %L is a coarray",
+ &code->expr3->where, &e->where);
+ goto failure;
+ }
}
/* Check F08:C629. */
goto failure;
}
+ if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
+ {
+ int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
+ code->ext.alloc.ts.u.cl->length);
+ if (cmp == 1 || cmp == -1 || cmp == -3)
+ {
+ gfc_error ("Allocating %s at %L with type-spec requires the same "
+ "character-length parameter as in the declaration",
+ sym->name, &e->where);
+ goto failure;
+ }
+ }
+
/* In the variable definition context checks, gfc_expr_attr is used
on the expression. This is fooled by the array specification
present in e, thus we have to eliminate that one temporarily. */
e2 = remove_last_array_ref (e);
t = SUCCESS;
if (t == SUCCESS && pointer)
- t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
+ t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
if (t == SUCCESS)
- t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
+ t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
gfc_free_expr (e2);
if (t == FAILURE)
goto failure;
- if (!code->expr3)
+ if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
+ && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
+ {
+ /* For class arrays, the initialization with SOURCE is done
+ using _copy and trans_call. It is convenient to exploit that
+ when the allocated type is different from the declared type but
+ no SOURCE exists by setting expr3. */
+ code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
+ }
+ else if (!code->expr3)
{
/* Set up default initializer if needed. */
gfc_typespec ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = code->ext.alloc.ts;
gfc_find_derived_vtab (ts.u.derived);
+ if (dimension)
+ e = gfc_expr_to_initialize (e);
}
- if (pointer || (dimension == 0 && codimension == 0))
+ if (dimension == 0 && codimension == 0)
goto success;
- /* Make sure the last reference node is an array specifiction. */
+ /* Make sure the last reference node is an array specification. */
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
"statement at %L", &e->where);
goto failure;
}
- break;
+ continue;
}
if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
goto failure;
}
- if (codimension && ar->as->rank == 0)
- {
- gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
- "at %L", &e->where);
- goto failure;
- }
-
success:
return SUCCESS;
/* Check the stat variable. */
if (stat)
{
- gfc_check_vardef_context (stat, false, _("STAT variable"));
+ gfc_check_vardef_context (stat, false, false, _("STAT variable"));
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
- gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
+ gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
}
}
- /* Check that an allocate-object appears only once in the statement.
- FIXME: Checking derived types is disabled. */
+ /* Check that an allocate-object appears only once in the statement. */
+
for (p = code->ext.alloc.list; p; p = p->next)
{
pe = p->expr;
{
gfc_array_ref *par = &(pr->u.ar);
gfc_array_ref *qar = &(qr->u.ar);
- if (gfc_dep_compare_expr (par->start[0],
- qar->start[0]) != 0)
- break;
+ if ((par->start[0] != NULL || qar->start[0] != NULL)
+ && gfc_dep_compare_expr (par->start[0],
+ qar->start[0]) != 0)
+ break;
}
}
else
return;
}
- if (case_expr->rank != 0)
- {
- gfc_error ("Argument of SELECT statement at %L must be a scalar "
- "expression", &case_expr->where);
-
- /* Punt. */
- return;
- }
-
-
/* Raise a warning if an INTEGER case value exceeds the range of
the case-expr. Later, all expressions will be promoted to the
largest kind of all case-labels. */
}
-/* Resolve an associate name: Resolve target and ensure the type-spec is
+/* Resolve an associate-name: Resolve target and ensure the type-spec is
correct as well as possibly the array-spec. */
static void
sym->attr.asynchronous = tsym->attr.asynchronous;
sym->attr.volatile_ = tsym->attr.volatile_;
- sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
+ sym->attr.target = tsym->attr.target
+ || gfc_expr_attr (target).pointer;
}
/* Get type if this was not already set. Note that it can be
sym->attr.dimension = 0;
return;
}
- if (target->rank > 0)
+
+ /* We cannot deal with class selectors that need temporaries. */
+ if (target->ts.type == BT_CLASS
+ && gfc_ref_needs_temporary_p (target->ref))
+ {
+ gfc_error ("CLASS selector at %L needs a temporary which is not "
+ "yet implemented", &target->where);
+ return;
+ }
+
+ if (target->ts.type != BT_CLASS && target->rank > 0)
sym->attr.dimension = 1;
+ else if (target->ts.type == BT_CLASS)
+ gfc_fix_class_refs (target);
+
+ /* The associate-name will have a correct type by now. Make absolutely
+ sure that it has not picked up a dimension attribute. */
+ if (sym->ts.type == BT_CLASS)
+ sym->attr.dimension = 0;
if (sym->attr.dimension)
{
return;
}
+ if (!code->expr1->symtree->n.sym->attr.class_ok)
+ return;
+
if (code->expr2)
{
if (code->expr1->symtree->n.sym->attr.untyped)
assoc = gfc_get_association_list ();
assoc->st = code->expr1->symtree;
assoc->target = gfc_copy_expr (code->expr2);
+ assoc->target->where = code->expr2->where;
/* assoc->variable will be set by resolve_assoc_var. */
code->ext.block.assoc = assoc;
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
+ st->n.sym->assoc->target->where = code->expr1->where;
if (c->ts.type == BT_DERIVED)
gfc_add_data_component (st->n.sym->assoc->target);
/* Chain in the new list only if it is marked as dangling. Otherwise
there is a CASE label overlap and this is already used. Just ignore,
- the error is diagonsed elsewhere. */
+ the error is diagnosed elsewhere. */
if (st->n.sym->assoc->dangling)
{
new_st->ext.block.assoc = st->n.sym->assoc;
&& exp->value.op.op == INTRINSIC_PARENTHESES)
exp = exp->value.op.op1;
+ if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
+ {
+ gfc_error ("NULL intrinsic at %L in data transfer statement requires "
+ "MOLD=", &exp->where);
+ return;
+ }
+
if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
&& exp->expr_type != EXPR_FUNCTION))
return;
code->ext.dt may be NULL if the TRANSFER is related to
an INQUIRE statement -- but in this case, we are not reading, either. */
if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
- && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
+ && gfc_check_vardef_context (exp, false, false, _("item in READ"))
+ == FAILURE)
return;
sym = exp->symtree->n.sym;
components. */
if (ts->u.derived->attr.pointer_comp)
{
- gfc_error ("Data transfer element at %L cannot have "
- "POINTER components", &code->loc);
+ gfc_error ("Data transfer element at %L cannot have POINTER "
+ "components unless it is processed by a defined "
+ "input/output procedure", &code->loc);
return;
}
if (ts->u.derived->attr.alloc_comp)
{
- gfc_error ("Data transfer element at %L cannot have "
- "ALLOCATABLE components", &code->loc);
+ gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
+ "components unless it is processed by a defined "
+ "input/output procedure", &code->loc);
return;
}
}
}
- if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
+ if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
&& 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 "
up through the code_stack. */
for (c = block; c; c = c->next)
{
- if (c->here && c->op != EXEC_END_BLOCK)
+ if (c->here && c->op != EXEC_END_NESTED_BLOCK)
bitmap_set_bit (cs_base->reachable_labels, c->here->value);
}
static void
+resolve_lock_unlock (gfc_code *code)
+{
+ if (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+ || code->expr1->rank != 0
+ || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
+ gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
+ &code->expr1->where);
+
+ /* Check STAT. */
+ if (code->expr2
+ && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+ || code->expr2->expr_type != EXPR_VARIABLE))
+ gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+ &code->expr2->where);
+
+ if (code->expr2
+ && gfc_check_vardef_context (code->expr2, false, false,
+ _("STAT variable")) == FAILURE)
+ return;
+
+ /* Check ERRMSG. */
+ if (code->expr3
+ && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+ || code->expr3->expr_type != EXPR_VARIABLE))
+ gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+ &code->expr3->where);
+
+ if (code->expr3
+ && gfc_check_vardef_context (code->expr3, false, false,
+ _("ERRMSG variable")) == FAILURE)
+ return;
+
+ /* Check ACQUIRED_LOCK. */
+ if (code->expr4
+ && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
+ || code->expr4->expr_type != EXPR_VARIABLE))
+ gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
+ "variable", &code->expr4->where);
+
+ if (code->expr4
+ && gfc_check_vardef_context (code->expr4, false, false,
+ _("ACQUIRED_LOCK variable")) == FAILURE)
+ return;
+}
+
+
+static void
resolve_sync (gfc_code *code)
{
/* Check imageset. The * case matches expr1 == NULL. */
return;
}
- if (label->defined != ST_LABEL_TARGET)
+ if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
{
gfc_error ("Statement at %L is not a valid branch target statement "
"for the branch statement at %L", &label->where, &code->loc);
whether the label is still visible outside of the CRITICAL block,
which is invalid. */
for (stack = cs_base; stack; stack = stack->prev)
- if (stack->current->op == EXEC_CRITICAL
- && bitmap_bit_p (stack->reachable_labels, label->value))
- gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
- " at %L", &code->loc, &label->where);
+ {
+ if (stack->current->op == EXEC_CRITICAL
+ && bitmap_bit_p (stack->reachable_labels, label->value))
+ gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
+ "label at %L", &code->loc, &label->where);
+ else if (stack->current->op == EXEC_DO_CONCURRENT
+ && bitmap_bit_p (stack->reachable_labels, label->value))
+ gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
+ "for label at %L", &code->loc, &label->where);
+ }
return;
}
" at %L", &code->loc, &label->where);
return;
}
+ else if (stack->current->op == EXEC_DO_CONCURRENT)
+ {
+ gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
+ "label at %L", &code->loc, &label->where);
+ return;
+ }
}
if (stack)
{
- gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
+ gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
return;
}
result = SUCCESS;
over:
- for (i--; i >= 0; i--)
- {
- mpz_clear (shape[i]);
- mpz_clear (shape2[i]);
- }
+ gfc_clear_shape (shape, i);
+ gfc_clear_shape (shape2, i);
return result;
}
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_DO_CONCURRENT:
case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
break;
rhs = code->expr2;
if (rhs->is_boz
- && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
+ && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
&code->loc) == FAILURE)
return false;
and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
if (lhs->ts.type == BT_CLASS)
{
- gfc_error ("Variable must not be polymorphic in assignment at %L",
- &lhs->where);
+ gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
+ "%L - check that there is a matching specific subroutine "
+ "for '=' operator", &lhs->where);
return false;
}
resolve_code (gfc_code *code, gfc_namespace *ns)
{
int omp_workshare_save;
- int forall_save;
+ int forall_save, do_concurrent_save;
code_stack frame;
gfc_try t;
{
frame.current = code;
forall_save = forall_flag;
+ do_concurrent_save = do_concurrent_flag;
if (code->op == EXEC_FORALL)
{
/* Blocks are handled in resolve_select_type because we have
to transform the SELECT TYPE into ASSOCIATE first. */
break;
+ case EXEC_DO_CONCURRENT:
+ do_concurrent_flag = 1;
+ gfc_resolve_blocks (code->block, ns);
+ do_concurrent_flag = 2;
+ break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
- /* FALLTHROUGH */
+ /* FALL THROUGH */
default:
gfc_resolve_blocks (code->block, ns);
break;
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
t = gfc_resolve_expr (code->expr1);
forall_flag = forall_save;
+ do_concurrent_flag = do_concurrent_save;
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
{
case EXEC_NOP:
case EXEC_END_BLOCK:
+ case EXEC_END_NESTED_BLOCK:
case EXEC_CYCLE:
case EXEC_PAUSE:
case EXEC_STOP:
resolve_sync (code);
break;
+ case EXEC_LOCK:
+ case EXEC_UNLOCK:
+ resolve_lock_unlock (code);
+ break;
+
case EXEC_ENTRY:
/* Keep track of which entry we are up to. */
current_entry_id = code->ext.entry->id;
if (t == FAILURE)
break;
- if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
- == FAILURE)
+ if (gfc_check_vardef_context (code->expr1, false, false,
+ _("assignment")) == FAILURE)
break;
if (resolve_ordinary_assign (code, ns))
array ref may be present on the LHS and fool gfc_expr_attr
used in gfc_check_vardef_context. Remove it. */
e = remove_last_array_ref (code->expr1);
- t = gfc_check_vardef_context (e, true, _("pointer assignment"));
+ t = gfc_check_vardef_context (e, true, false,
+ _("pointer assignment"));
if (t == SUCCESS)
- t = gfc_check_vardef_context (e, false, _("pointer assignment"));
+ t = gfc_check_vardef_context (e, false, false,
+ _("pointer assignment"));
gfc_free_expr (e);
if (t == FAILURE)
break;
resolve_transfer (code);
break;
+ case EXEC_DO_CONCURRENT:
case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator);
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
gfc_resolve_omp_directive (code, ns);
break;
{
gfc_gsymbol *binding_label_gsym;
gfc_gsymbol *comm_name_gsym;
+ const char * bind_label = comm_block_tree->n.common->binding_label
+ ? comm_block_tree->n.common->binding_label : "";
/* See if a global symbol exists by the common block's name. It may
be NULL if the common block is use-associated. */
if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
gfc_error ("Binding label '%s' for common block '%s' at %L collides "
"with the global entity '%s' at %L",
- comm_block_tree->n.common->binding_label,
+ bind_label,
comm_block_tree->n.common->name,
&(comm_block_tree->n.common->where),
comm_name_gsym->name, &(comm_name_gsym->where));
as expected. */
if (comm_name_gsym->binding_label == NULL)
/* No binding label for common block stored yet; save this one. */
- comm_name_gsym->binding_label =
- comm_block_tree->n.common->binding_label;
- else
- if (strcmp (comm_name_gsym->binding_label,
- comm_block_tree->n.common->binding_label) != 0)
+ comm_name_gsym->binding_label = bind_label;
+ else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
{
/* Common block names match but binding labels do not. */
gfc_error ("Binding label '%s' for common block '%s' at %L "
"does not match the binding label '%s' for common "
"block '%s' at %L",
- comm_block_tree->n.common->binding_label,
+ bind_label,
comm_block_tree->n.common->name,
&(comm_block_tree->n.common->where),
comm_name_gsym->binding_label,
/* There is no binding label (NAME="") so we have nothing further to
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)
return;
binding_label_gsym =
int has_error = 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)
{
gfc_gsymbol *bind_c_sym;
}
if (has_error != 0)
- /* Clear the binding label to prevent checking multiple times. */
- sym->binding_label[0] = '\0';
+ /* Clear the binding label to prevent checking multiple times. */
+ sym->binding_label = NULL;
}
else if (bind_c_sym == NULL)
{
cl->resolved = 1;
- specification_expr = 1;
- if (resolve_index_expr (cl->length) == FAILURE)
+ if (cl->length_from_typespec)
{
- specification_expr = 0;
- return FAILURE;
+ if (gfc_resolve_expr (cl->length) == FAILURE)
+ return FAILURE;
+
+ if (gfc_simplify_expr (cl->length, 0) == FAILURE)
+ return FAILURE;
+ }
+ else
+ {
+ specification_expr = 1;
+
+ if (resolve_index_expr (cl->length) == FAILURE)
+ {
+ specification_expr = 0;
+ return FAILURE;
+ }
}
/* "If the character length parameter value evaluates to a negative
int i;
/* These symbols should never have a default initialization. */
- if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
+ if (sym->attr.allocatable
|| sym->attr.external
|| sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.data
|| sym->module
|| sym->attr.cray_pointee
- || sym->attr.cray_pointer)
+ || sym->attr.cray_pointer
+ || sym->assoc)
return NULL;
/* Now we'll try to build an initializer expression. */
gfc_free_expr (init_expr);
init_expr = NULL;
}
+ if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+ && sym->ts.u.cl->length)
+ {
+ gfc_actual_arglist *arg;
+ init_expr = gfc_get_expr ();
+ init_expr->where = sym->declared_at;
+ init_expr->ts = sym->ts;
+ init_expr->expr_type = EXPR_FUNCTION;
+ init_expr->value.function.isym =
+ gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
+ init_expr->value.function.name = "repeat";
+ arg = gfc_get_actual_arglist ();
+ arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
+ NULL, 1);
+ arg->expr->value.character.string[0]
+ = gfc_option.flag_init_character_value;
+ arg->next = gfc_get_actual_arglist ();
+ arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
+ init_expr->value.function.actual = arg;
+ }
break;
default:
if (init == NULL)
return;
- /* For saved variables, we don't want to add an initializer at
- function entry, so we just add a static initializer. */
+ /* For saved variables, we don't want to add an initializer at function
+ entry, so we just add a static initializer. Note that automatic variables
+ are stack allocated even with -fno-automatic. */
if (sym->attr.save || sym->ns->save_all
- || gfc_option.flag_max_stack_var_size == 0)
+ || (gfc_option.flag_max_stack_var_size == 0
+ && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
{
/* Don't clobber an existing initializer! */
gcc_assert (sym->value == NULL);
static gfc_try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
+ gfc_array_spec *as;
+
/* Avoid double diagnostics for function result symbols. */
if ((sym->result || sym->attr.result) && !sym->attr.dummy
&& (sym->ns != gfc_current_ns))
return SUCCESS;
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+ as = CLASS_DATA (sym)->as;
+ else
+ as = sym->as;
+
/* Constraints on deferred shape variable. */
- if (sym->as == NULL || sym->as->type != AS_DEFERRED)
+ if (as == NULL || as->type != AS_DEFERRED)
{
- if (sym->attr.allocatable)
+ bool pointer, allocatable, dimension;
+
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
{
- if (sym->attr.dimension)
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ dimension = CLASS_DATA (sym)->attr.dimension;
+ }
+ else
+ {
+ pointer = sym->attr.pointer;
+ allocatable = sym->attr.allocatable;
+ dimension = sym->attr.dimension;
+ }
+
+ if (allocatable)
+ {
+ if (dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Allocatable array '%s' at %L must have "
- "a deferred shape", sym->name, &sym->declared_at);
+ gfc_error ("Allocatable array '%s' at %L must have a deferred "
+ "shape or assumed rank", sym->name, &sym->declared_at);
return FAILURE;
}
- else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
- "may not be ALLOCATABLE", sym->name,
- &sym->declared_at) == FAILURE)
+ else if (gfc_notify_std (GFC_STD_F2003, "Scalar object "
+ "'%s' at %L may not be ALLOCATABLE",
+ sym->name, &sym->declared_at) == FAILURE)
return FAILURE;
}
- if (sym->attr.pointer && sym->attr.dimension)
+ if (pointer && dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Array pointer '%s' at %L must have a deferred shape",
- sym->name, &sym->declared_at);
+ gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
+ "assumed rank", sym->name, &sym->declared_at);
return FAILURE;
}
}
{
gfc_symbol *s;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
+ if (s && s->attr.generic)
+ s = gfc_find_dt_in_generic (s);
if (s && s->attr.flavor != FL_DERIVED)
{
gfc_error ("The type '%s' cannot be host associated at %L "
&& !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable
&& gfc_has_default_initializer (sym->ts.u.derived)
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
+ && gfc_notify_std (GFC_STD_F2008, "Implied SAVE for "
"module variable '%s' at %L, needed due to "
"the default initialization", sym->name,
&sym->declared_at) == FAILURE)
if (!gfc_is_constant_expr (e)
&& !(e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
- && sym->ns->proc_name
- && (sym->ns->proc_name->attr.flavor == FL_MODULE
- || sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc)
- {
- gfc_error ("'%s' at %L must have constant character length "
- "in this context", sym->name, &sym->declared_at);
- return FAILURE;
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
+ {
+ if (!sym->attr.use_assoc && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program))
+ {
+ gfc_error ("'%s' at %L must have constant character length "
+ "in this context", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ if (sym->attr.in_common)
+ {
+ gfc_error ("COMMON variable '%s' at %L must have constant "
+ "character length", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
}
}
/* Also, they must not have the SAVE attribute.
SAVE_IMPLICIT is checked below. */
- if (sym->attr.save == SAVE_EXPLICIT)
+ if (sym->as && sym->attr.codimension)
+ {
+ int corank = sym->as->corank;
+ sym->as->corank = 0;
+ no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
+ sym->as->corank = corank;
+ }
+ if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
+ && gfc_notify_std (GFC_STD_F2003, "'%s' is of a "
"PRIVATE type and cannot be a dummy argument"
" of '%s', which is PUBLIC at %L",
arg->sym->name, sym->name, &sym->declared_at)
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
+ && gfc_notify_std (GFC_STD_F2003, "Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
"PRIVATE", iface->sym->name, sym->name,
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
+ && gfc_notify_std (GFC_STD_F2003, "Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
"PRIVATE", iface->sym->name, sym->name,
actual length; (ii) To declare a named constant; or (iii) External
function - but length must be declared in calling scoping unit. */
if (sym->attr.function
- && sym->ts.type == BT_CHARACTER
+ && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
&& sym->ts.u.cl && sym->ts.u.cl->length == NULL)
{
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
if (!sym->attr.contained
&& gfc_current_form != FORM_FIXED
&& !sym->ts.deferred)
- gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
+ gfc_notify_std (GFC_STD_F95_OBS,
"CHARACTER(*) function '%s' at %L",
sym->name, &sym->declared_at);
}
{
/* Skip implicitly typed dummy args here. */
if (curr_arg->sym->attr.implicit_type == 0)
- if (verify_c_interop_param (curr_arg->sym) == FAILURE)
+ if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
/* If something is found to fail, record the fact so we
can mark the symbol for the procedure as not being
BIND(C) to try and prevent multiple errors being
}
/* 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)
gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
" shape argument", &arg->declared_at);
gfc_error ("Finalization at %L is not yet implemented",
&derived->declared_at);
+ gfc_find_derived_vtab (derived);
return result;
}
-/* Check that it is ok for the typebound procedure proc to override the
- procedure old. */
+/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
static gfc_try
-check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
+check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
+ const char* generic_name, locus where)
{
- locus where;
- const gfc_symbol* proc_target;
- const gfc_symbol* old_target;
- unsigned proc_pass_arg, old_pass_arg, argpos;
- gfc_formal_arglist* proc_formal;
- gfc_formal_arglist* old_formal;
+ gfc_symbol *sym1, *sym2;
+ const char *pass1, *pass2;
- /* This procedure should only be called for non-GENERIC proc. */
- gcc_assert (!proc->n.tb->is_generic);
+ gcc_assert (t1->specific && t2->specific);
+ gcc_assert (!t1->specific->is_generic);
+ gcc_assert (!t2->specific->is_generic);
+ gcc_assert (t1->is_operator == t2->is_operator);
- /* If the overwritten procedure is GENERIC, this is an error. */
- if (old->n.tb->is_generic)
- {
- gfc_error ("Can't overwrite GENERIC '%s' at %L",
- old->name, &proc->n.tb->where);
- return FAILURE;
- }
+ sym1 = t1->specific->u.specific->n.sym;
+ sym2 = t2->specific->u.specific->n.sym;
- where = proc->n.tb->where;
- proc_target = proc->n.tb->u.specific->n.sym;
- old_target = old->n.tb->u.specific->n.sym;
-
- /* Check that overridden binding is not NON_OVERRIDABLE. */
- if (old->n.tb->non_overridable)
- {
- gfc_error ("'%s' at %L overrides a procedure binding declared"
- " NON_OVERRIDABLE", proc->name, &where);
- return FAILURE;
- }
-
- /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
- if (!old->n.tb->deferred && proc->n.tb->deferred)
- {
- gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
- " non-DEFERRED binding", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is PURE, the overriding must be, too. */
- if (old_target->attr.pure && !proc_target->attr.pure)
- {
- gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
- proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
- is not, the overriding must not be either. */
- if (old_target->attr.elemental && !proc_target->attr.elemental)
- {
- gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
- " ELEMENTAL", proc->name, &where);
- return FAILURE;
- }
- if (!old_target->attr.elemental && proc_target->attr.elemental)
- {
- gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
- " be ELEMENTAL, either", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is a SUBROUTINE, the overriding must also be a
- SUBROUTINE. */
- if (old_target->attr.subroutine && !proc_target->attr.subroutine)
- {
- gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
- " SUBROUTINE", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is a FUNCTION, the overriding must also be a
- FUNCTION and have the same characteristics. */
- if (old_target->attr.function)
- {
- if (!proc_target->attr.function)
- {
- gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
- " FUNCTION", proc->name, &where);
- return FAILURE;
- }
-
- /* FIXME: Do more comprehensive checking (including, for instance, the
- rank and array-shape). */
- gcc_assert (proc_target->result && old_target->result);
- if (!gfc_compare_types (&proc_target->result->ts,
- &old_target->result->ts))
- {
- gfc_error ("'%s' at %L and the overridden FUNCTION should have"
- " matching result types", proc->name, &where);
- return FAILURE;
- }
- }
-
- /* If the overridden binding is PUBLIC, the overriding one must not be
- PRIVATE. */
- if (old->n.tb->access == ACCESS_PUBLIC
- && proc->n.tb->access == ACCESS_PRIVATE)
- {
- gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
- " PRIVATE", proc->name, &where);
- return FAILURE;
- }
-
- /* Compare the formal argument lists of both procedures. This is also abused
- 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
- need those positions in the check below. */
- proc_pass_arg = old_pass_arg = 0;
- if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
- proc_pass_arg = 1;
- if (!old->n.tb->nopass && !old->n.tb->pass_arg)
- old_pass_arg = 1;
- argpos = 1;
- for (proc_formal = proc_target->formal, old_formal = old_target->formal;
- proc_formal && old_formal;
- proc_formal = proc_formal->next, old_formal = old_formal->next)
- {
- if (proc->n.tb->pass_arg
- && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
- proc_pass_arg = argpos;
- if (old->n.tb->pass_arg
- && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
- old_pass_arg = argpos;
-
- /* Check that the names correspond. */
- if (strcmp (proc_formal->sym->name, old_formal->sym->name))
- {
- gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
- " to match the corresponding argument of the overridden"
- " procedure", proc_formal->sym->name, proc->name, &where,
- old_formal->sym->name);
- return FAILURE;
- }
-
- /* Check that the types correspond if neither is the passed-object
- argument. */
- /* FIXME: Do more comprehensive testing here. */
- if (proc_pass_arg != argpos && old_pass_arg != argpos
- && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
- {
- gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
- "in respect to the overridden procedure",
- proc_formal->sym->name, proc->name, &where);
- return FAILURE;
- }
-
- ++argpos;
- }
- if (proc_formal || old_formal)
- {
- gfc_error ("'%s' at %L must have the same number of formal arguments as"
- " the overridden procedure", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is NOPASS, the overriding one must also be
- NOPASS. */
- if (old->n.tb->nopass && !proc->n.tb->nopass)
- {
- gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
- " NOPASS", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is PASS(x), the overriding one must also be
- PASS and the passed-object dummy arguments must correspond. */
- if (!old->n.tb->nopass)
- {
- if (proc->n.tb->nopass)
- {
- gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
- " PASS", proc->name, &where);
- return FAILURE;
- }
-
- if (proc_pass_arg != old_pass_arg)
- {
- gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
- " the same position as the passed-object dummy argument of"
- " the overridden procedure", proc->name, &where);
- return FAILURE;
- }
- }
-
- return SUCCESS;
-}
-
-
-/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
-
-static gfc_try
-check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
- const char* generic_name, locus where)
-{
- gfc_symbol* sym1;
- gfc_symbol* sym2;
-
- gcc_assert (t1->specific && t2->specific);
- gcc_assert (!t1->specific->is_generic);
- gcc_assert (!t2->specific->is_generic);
-
- sym1 = t1->specific->u.specific->n.sym;
- sym2 = t2->specific->u.specific->n.sym;
-
- if (sym1 == sym2)
- return SUCCESS;
+ if (sym1 == sym2)
+ return SUCCESS;
/* Both must be SUBROUTINEs or both must be FUNCTIONs. */
if (sym1->attr.subroutine != sym2->attr.subroutine
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
+ if (t1->specific->nopass)
+ pass1 = NULL;
+ else if (t1->specific->pass_arg)
+ pass1 = t1->specific->pass_arg;
+ else
+ pass1 = t1->specific->u.specific->n.sym->formal->sym->name;
+ if (t2->specific->nopass)
+ pass2 = NULL;
+ else if (t2->specific->pass_arg)
+ pass2 = t2->specific->pass_arg;
+ else
+ pass2 = t2->specific->u.specific->n.sym->formal->sym->name;
+ if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
+ NULL, 0, pass1, pass2))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
target_proc = target->specific->u.specific->n.sym;
gcc_assert (target_proc);
- /* All operator bindings must have a passed-object dummy argument. */
+ /* F08:C468. All operator bindings must have a passed-object dummy argument. */
if (target->specific->nopass)
{
gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
if (!gfc_check_operator_interface (target_proc, op, p->where))
goto error;
+
+ /* Add target to non-typebound operator list. */
+ if (!target->specific->deferred && !derived->attr.use_assoc
+ && p->access != ACCESS_PRIVATE)
+ {
+ gfc_interface *head, *intr;
+ if (gfc_check_new_interface (derived->ns->op[op], target_proc,
+ p->where) == FAILURE)
+ return FAILURE;
+ head = derived->ns->op[op];
+ intr = gfc_get_interface ();
+ intr->sym = target_proc;
+ intr->where = p->where;
+ intr->next = head;
+ derived->ns->op[op] = intr;
+ }
}
return SUCCESS;
gcc_assert (stree->n.tb->u.specific);
proc = stree->n.tb->u.specific->n.sym;
where = stree->n.tb->where;
+ proc->attr.public_used = 1;
/* Default access should already be resolved from the parser. */
gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
- /* It should be a module procedure or an external procedure with explicit
- interface. For DEFERRED bindings, abstract interfaces are ok as well. */
- if ((!proc->attr.subroutine && !proc->attr.function)
- || (proc->attr.proc != PROC_MODULE
- && proc->attr.if_source != IFSRC_IFBODY)
- || (proc->attr.abstract && !stree->n.tb->deferred))
+ if (stree->n.tb->deferred)
{
- gfc_error ("'%s' must be a module procedure or an external procedure with"
- " an explicit interface at %L", proc->name, &where);
- goto error;
+ if (check_proc_interface (proc, &where) == FAILURE)
+ goto error;
+ }
+ else
+ {
+ /* Check for F08:C465. */
+ if ((!proc->attr.subroutine && !proc->attr.function)
+ || (proc->attr.proc != PROC_MODULE
+ && proc->attr.if_source != IFSRC_IFBODY)
+ || proc->attr.abstract)
+ {
+ gfc_error ("'%s' must be a module procedure or an external procedure with"
+ " an explicit interface at %L", proc->name, &where);
+ goto error;
+ }
}
+
stree->n.tb->subroutine = proc->attr.subroutine;
stree->n.tb->function = proc->attr.function;
}
gcc_assert (me_arg->ts.type == BT_CLASS);
- if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
+ if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
" scalar", proc->name, &where);
overridden = gfc_find_typebound_proc (super_type, NULL,
stree->name, true, NULL);
- if (overridden && overridden->n.tb)
- stree->n.tb->overridden = overridden->n.tb;
+ if (overridden)
+ {
+ if (overridden->n.tb)
+ stree->n.tb->overridden = overridden->n.tb;
- if (overridden && check_typebound_override (stree, overridden) == FAILURE)
- goto error;
+ if (gfc_check_typebound_override (stree, overridden) == FAILURE)
+ goto error;
+ }
}
/* See if there's a name collision with a component directly in this type. */
resolve_typebound_procedures (gfc_symbol* derived)
{
int op;
+ gfc_symbol* super_type;
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
+
+ super_type = gfc_get_derived_super_type (derived);
+ if (super_type)
+ resolve_typebound_procedures (super_type);
resolve_bindings_derived = derived;
resolve_bindings_result = SUCCESS;
}
-/* Resolve the components of a derived type. */
+/* Resolve the components of a derived type. This does not have to wait until
+ resolution stage, but can be done as soon as the dt declaration has been
+ parsed. */
static gfc_try
-resolve_fl_derived (gfc_symbol *sym)
+resolve_fl_derived0 (gfc_symbol *sym)
{
gfc_symbol* super_type;
gfc_component *c;
super_type = gfc_get_derived_super_type (sym);
-
- if (sym->attr.is_class && sym->ts.u.derived == NULL)
- {
- /* Fix up incomplete CLASS symbols. */
- gfc_component *data = gfc_find_component (sym, "_data", true, true);
- gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
- if (vptr->ts.u.derived == NULL)
- {
- gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
- gcc_assert (vtab);
- vptr->ts.u.derived = vtab->ts.u.derived;
- }
- }
/* F2008, C432. */
if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
}
/* Ensure the extended type gets resolved before we do. */
- if (super_type && resolve_fl_derived (super_type) == FAILURE)
+ if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
return FAILURE;
/* An ABSTRACT type must be extensible. */
return FAILURE;
}
- for (c = sym->components; c != NULL; c = c->next)
+ c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
+ : sym->components;
+
+ for ( ; c != NULL; c = c->next)
{
+ if (c->attr.artificial)
+ continue;
+
+ /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
+ if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
+ {
+ gfc_error ("Deferred-length character component '%s' at %L is not "
+ "yet supported", c->name, &c->loc);
+ return FAILURE;
+ }
+
/* F2008, C442. */
- if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
+ if ((!sym->attr.is_class || c != sym->components)
+ && c->attr.codimension
&& (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
{
gfc_error ("Coarray component '%s' at %L must be allocatable with "
if (c->attr.proc_pointer && c->ts.interface)
{
- if (c->ts.interface->attr.procedure && !sym->attr.vtype)
- gfc_error ("Interface '%s', used by procedure pointer component "
- "'%s' at %L, is declared in a later PROCEDURE statement",
- c->ts.interface->name, c->name, &c->loc);
+ gfc_symbol *ifc = c->ts.interface;
- /* Get the attributes from the interface (now resolved). */
- if (c->ts.interface->attr.if_source
- || c->ts.interface->attr.intrinsic)
- {
- gfc_symbol *ifc = c->ts.interface;
+ if (!sym->attr.vtype
+ && check_proc_interface (ifc, &c->loc) == FAILURE)
+ return FAILURE;
+ if (ifc->attr.if_source || ifc->attr.intrinsic)
+ {
+ /* Resolve interface and copy attributes. */
if (ifc->formal && !ifc->formal_ns)
resolve_symbol (ifc);
-
if (ifc->attr.intrinsic)
- resolve_intrinsic (ifc, &ifc->declared_at);
+ gfc_resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
{
c->ts.interface = ifc;
c->attr.function = ifc->attr.function;
c->attr.subroutine = ifc->attr.subroutine;
- gfc_copy_formal_args_ppc (c, ifc);
+ gfc_copy_formal_args_ppc (c, ifc, IFSRC_DECL);
c->attr.pure = ifc->attr.pure;
c->attr.elemental = ifc->attr.elemental;
c->attr.recursive = ifc->attr.recursive;
c->attr.always_explicit = ifc->attr.always_explicit;
c->attr.ext_attr |= ifc->attr.ext_attr;
+ c->attr.class_ok = ifc->attr.class_ok;
/* Replace symbols in array spec. */
if (c->as)
{
gfc_expr_replace_comp (c->as->lower[i], c);
gfc_expr_replace_comp (c->as->upper[i], c);
}
- }
+ }
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
gfc_expr_replace_comp (cl->length, c);
if (cl->length && !cl->resolved
- && gfc_resolve_expr (cl->length) == FAILURE)
+ && gfc_resolve_expr (cl->length) == FAILURE)
return FAILURE;
c->ts.u.cl = cl;
}
}
- else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
- {
- gfc_error ("Interface '%s' of procedure pointer component "
- "'%s' at %L must be explicit", c->ts.interface->name,
- c->name, &c->loc);
- return FAILURE;
- }
}
else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
{
}
/* Check type-spec if this is not the parent-type component. */
- if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
+ if (((sym->attr.is_class
+ && (!sym->components->ts.u.derived->attr.extension
+ || c != sym->components->ts.u.derived->components))
+ || (!sym->attr.is_class
+ && (!sym->attr.extension || c != sym->components)))
+ && !sym->attr.vtype
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
return FAILURE;
/* If this type is an extension, set the accessibility of the parent
component. */
- if (super_type && c == sym->components
+ if (super_type
+ && ((sym->attr.is_class
+ && c == sym->components->ts.u.derived->components)
+ || (!sym->attr.is_class && c == sym->components))
&& strcmp (super_type->name, c->name) == 0)
c->attr.access = super_type->attr.access;
&& !is_sym_host_assoc (c->ts.u.derived, sym->ns)
&& !c->ts.u.derived->attr.use_assoc
&& !gfc_check_symbol_access (c->ts.u.derived)
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
+ && gfc_notify_std (GFC_STD_F2003, "the component '%s' "
"is a PRIVATE type and cannot be a component of "
"'%s', which is PUBLIC at %L", c->name,
sym->name, &sym->declared_at) == FAILURE)
}
}
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
+ c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
+ else if (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->ts.u.derived->attr.generic)
+ CLASS_DATA (c)->ts.u.derived
+ = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
+
if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
&& c->attr.pointer && c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp)
return FAILURE;
}
- if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
+ if (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.class_pointer
&& CLASS_DATA (c)->ts.u.derived->components == NULL
&& !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
{
}
/* C437. */
- if (c->ts.type == BT_CLASS
- && !(CLASS_DATA (c)->attr.class_pointer
- || CLASS_DATA (c)->attr.allocatable))
+ if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
+ && (!c->attr.class_ok
+ || !(CLASS_DATA (c)->attr.class_pointer
+ || CLASS_DATA (c)->attr.allocatable)))
{
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
"or pointer", c->name, &c->loc);
return FAILURE;
}
- /* Resolve the type-bound procedures. */
- if (resolve_typebound_procedures (sym) == FAILURE)
- return FAILURE;
-
- /* Resolve the finalizer procedures. */
- if (gfc_resolve_finalizers (sym) == FAILURE)
- return FAILURE;
-
/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
all DEFERRED bindings are overridden. */
if (super_type && super_type->attr.abstract && !sym->attr.abstract
}
+/* The following procedure does the full resolution of a derived type,
+ including resolution of all type-bound procedures (if present). In contrast
+ to 'resolve_fl_derived0' this can only be done after the module has been
+ parsed completely. */
+
+static gfc_try
+resolve_fl_derived (gfc_symbol *sym)
+{
+ gfc_symbol *gen_dt = NULL;
+
+ if (!sym->attr.is_class)
+ gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
+ if (gen_dt && gen_dt->generic && gen_dt->generic->next
+ && (!gen_dt->generic->sym->attr.use_assoc
+ || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
+ && gfc_notify_std (GFC_STD_F2003, "Generic name '%s' of "
+ "function '%s' at %L being the same name as derived "
+ "type at %L", sym->name,
+ gen_dt->generic->sym == sym
+ ? gen_dt->generic->next->sym->name
+ : gen_dt->generic->sym->name,
+ gen_dt->generic->sym == sym
+ ? &gen_dt->generic->next->sym->declared_at
+ : &gen_dt->generic->sym->declared_at,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* Resolve the finalizer procedures. */
+ if (gfc_resolve_finalizers (sym) == FAILURE)
+ return FAILURE;
+
+ if (sym->attr.is_class && sym->ts.u.derived == NULL)
+ {
+ /* Fix up incomplete CLASS symbols. */
+ gfc_component *data = gfc_find_component (sym, "_data", true, true);
+ gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
+ if (vptr->ts.u.derived == NULL)
+ {
+ gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
+ gcc_assert (vtab);
+ vptr->ts.u.derived = vtab->ts.u.derived;
+ }
+ }
+
+ if (resolve_fl_derived0 (sym) == FAILURE)
+ return FAILURE;
+
+ /* Resolve the type-bound procedures. */
+ if (resolve_typebound_procedures (sym) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
static gfc_try
resolve_fl_namelist (gfc_symbol *sym)
{
}
if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ && gfc_notify_std (GFC_STD_F2003, "NAMELIST array "
"object '%s' with assumed shape in namelist "
"'%s' at %L", nl->sym->name, sym->name,
&sym->declared_at) == FAILURE)
return FAILURE;
if (is_non_constant_shape_array (nl->sym)
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ && gfc_notify_std (GFC_STD_F2003, "NAMELIST array "
"object '%s' with nonconstant shape in namelist "
"'%s' at %L", nl->sym->name, sym->name,
&sym->declared_at) == FAILURE)
if (nl->sym->ts.type == BT_CHARACTER
&& (nl->sym->ts.u.cl->length == NULL
|| !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ && gfc_notify_std (GFC_STD_F2003, "NAMELIST object "
"'%s' with nonconstant character length in "
"namelist '%s' at %L", nl->sym->name, sym->name,
&sym->declared_at) == FAILURE)
&& (nl->sym->ts.u.derived->attr.alloc_comp
|| nl->sym->ts.u.derived->attr.pointer_comp))
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ if (gfc_notify_std (GFC_STD_F2003, "NAMELIST object "
"'%s' in namelist '%s' at %L with ALLOCATABLE "
"or POINTER components", nl->sym->name,
sym->name, &sym->declared_at) == FAILURE)
gfc_symtree *this_symtree;
gfc_namespace *ns;
gfc_component *c;
+ symbol_attribute class_attr;
+ gfc_array_spec *as;
- if (sym->attr.flavor == FL_UNKNOWN)
+ if (sym->attr.artificial)
+ return;
+
+ if (sym->attr.flavor == FL_UNKNOWN
+ || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
+ && !sym->attr.generic && !sym->attr.external
+ && sym->attr.if_source == IFSRC_UNKNOWN))
{
/* If we find that a flavorless symbol is an interface in one of the
/* Otherwise give it a flavor according to such attributes as
it has. */
- if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
+ if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
+ && sym->attr.intrinsic == 0)
sym->attr.flavor = FL_VARIABLE;
- else
+ else if (sym->attr.flavor == FL_UNKNOWN)
{
sym->attr.flavor = FL_PROCEDURE;
if (sym->attr.dimension)
if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
- if (sym->attr.procedure && sym->ts.interface
- && sym->attr.if_source != IFSRC_DECL
+ if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
&& resolve_procedure_interface (sym) == FAILURE)
return;
return;
}
-
- /* F2008, C530. */
- if (sym->attr.contiguous
- && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.pointer)))
- {
- gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
- "array pointer or an assumed-shape array", sym->name,
- &sym->declared_at);
- return;
- }
-
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
representation. This needs to be done before assigning a default
type to avoid spurious warnings. */
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
- && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
+ && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
return;
/* Resolve associate names. */
if (sym->ts.type == BT_UNKNOWN)
{
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
&& !sym->attr.function && !sym->attr.subroutine
}
}
}
+ else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
+ gfc_resolve_array_spec (sym->result->as, false);
+
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+ {
+ as = CLASS_DATA (sym)->as;
+ class_attr = CLASS_DATA (sym)->attr;
+ class_attr.pointer = class_attr.class_pointer;
+ }
+ else
+ {
+ class_attr = sym->attr;
+ as = sym->as;
+ }
+
+ /* F2008, C530. */
+ if (sym->attr.contiguous
+ && (!class_attr.dimension
+ || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
+ && !class_attr.pointer)))
+ {
+ gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
+ "array pointer or an assumed-shape or assumed-rank array",
+ sym->name, &sym->declared_at);
+ return;
+ }
/* Assumed size arrays and assumed shape arrays must be dummy
arguments. Array-spec's of implied-shape should have been resolved to
AS_EXPLICIT already. */
- if (sym->as)
+ if (as)
{
- gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
- if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
- || sym->as->type == AS_ASSUMED_SHAPE)
+ gcc_assert (as->type != AS_IMPLIED_SHAPE);
+ if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
+ || as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{
- if (sym->as->type == AS_ASSUMED_SIZE)
+ if (as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array at %L must be a dummy argument",
&sym->declared_at);
else
&sym->declared_at);
return;
}
+ /* TS 29113, C535a. */
+ if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy)
+ {
+ gfc_error ("Assumed-rank array at %L must be a dummy argument",
+ &sym->declared_at);
+ return;
+ }
+ if (as->type == AS_ASSUMED_RANK
+ && (sym->attr.codimension || sym->attr.value))
+ {
+ gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+ "CODIMENSION attribute", &sym->declared_at);
+ return;
+ }
}
/* Make sure symbols with known intent or optional are really dummy
}
}
+ if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
+ && sym->ts.u.derived->attr.generic)
+ {
+ sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
+ if (!sym->ts.u.derived)
+ {
+ gfc_error ("The derived type '%s' at %L is of type '%s', "
+ "which has not been defined", sym->name,
+ &sym->declared_at, sym->ts.u.derived->name);
+ sym->ts.type = BT_UNKNOWN;
+ return;
+ }
+ }
+
+ if (sym->ts.type == BT_ASSUMED)
+ {
+ /* TS 29113, C407a. */
+ if (!sym->attr.dummy)
+ {
+ gfc_error ("Assumed type of variable %s at %L is only permitted "
+ "for dummy variables", sym->name, &sym->declared_at);
+ return;
+ }
+ if (sym->attr.allocatable || sym->attr.codimension
+ || sym->attr.pointer || sym->attr.value)
+ {
+ gfc_error ("Assumed-type variable %s at %L may not have the "
+ "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ if (sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Assumed-type variable %s at %L may not have the "
+ "INTENT(OUT) attribute",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
+ {
+ gfc_error ("Assumed-type variable %s at %L shall not be an "
+ "explicit-shape array", sym->name, &sym->declared_at);
+ return;
+ }
+ }
+
/* 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
in gfc_set_default_type. Handle dummy arguments and procedure
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
+ if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
+ && sym->ts.u.derived->components == NULL
&& !sym->ts.u.derived->attr.zero_comp)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->attr.use_assoc
&& sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE)
- {
- gfc_symbol *ds;
-
- if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
- return;
-
- gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
- if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
- {
- symtree = gfc_new_symtree (&sym->ns->sym_root,
- sym->ts.u.derived->name);
- symtree->n.sym = sym->ts.u.derived;
- sym->ts.u.derived->refs++;
- }
- }
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
+ return;
/* Unless the derived-type declaration is use associated, Fortran 95
does not allow public entries of private derived types.
&& !sym->ts.u.derived->attr.use_assoc
&& gfc_check_symbol_access (sym)
&& !gfc_check_symbol_access (sym->ts.u.derived)
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
+ && gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L "
"of PRIVATE derived type '%s'",
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
: "variable", sym->name, &sym->declared_at,
sym->ts.u.derived->name) == FAILURE)
return;
+ /* F2008, C1302. */
+ if (sym->ts.type == BT_DERIVED
+ && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+ || sym->ts.u.derived->attr.lock_comp)
+ && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
+ {
+ gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
+ "type LOCK_TYPE must be a coarray", sym->name,
+ &sym->declared_at);
+ return;
+ }
+
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
}
}
- /* F2008, C526. */
- if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
- || sym->attr.codimension)
- && sym->attr.result)
- gfc_error ("Function result '%s' at %L shall not be a coarray or have "
- "a coarray component", sym->name, &sym->declared_at);
+ /* F2008, C542. */
+ if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
+ {
+ gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
+ "INTENT(OUT)", sym->name, &sym->declared_at);
+ return;
+ }
+
+ /* F2008, C525. */
+ if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->attr.coarray_comp))
+ || class_attr.codimension)
+ && (sym->attr.result || sym->result == sym))
+ {
+ gfc_error ("Function result '%s' at %L shall not be a coarray or have "
+ "a coarray component", sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C524. */
if (sym->attr.codimension && sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->ts.is_iso_c)
- gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
- "shall not be a coarray", sym->name, &sym->declared_at);
+ {
+ gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+ "shall not be a coarray", sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C525. */
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
- && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
- || sym->attr.allocatable))
- gfc_error ("Variable '%s' at %L with coarray component "
- "shall be a nonpointer, nonallocatable scalar",
- sym->name, &sym->declared_at);
+ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->attr.coarray_comp))
+ && (class_attr.codimension || class_attr.pointer || class_attr.dimension
+ || class_attr.allocatable))
+ {
+ gfc_error ("Variable '%s' at %L with coarray component "
+ "shall be a nonpointer, nonallocatable scalar",
+ sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C526. The function-result case was handled above. */
- if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
- || sym->attr.codimension)
- && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+ if (class_attr.codimension
+ && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
+ || sym->attr.select_type_temporary
+ || sym->ns->save_all
|| sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program
|| sym->attr.function || sym->attr.result || sym->attr.use_assoc))
- gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
- "component and is not ALLOCATABLE, SAVE nor a "
- "dummy argument", sym->name, &sym->declared_at);
- /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
- else if (sym->attr.codimension && !sym->attr.allocatable
- && sym->as && sym->as->cotype == AS_DEFERRED)
- gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
- "deferred shape", sym->name, &sym->declared_at);
- else if (sym->attr.codimension && sym->attr.allocatable
- && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
- gfc_error ("Allocatable coarray variable '%s' at %L must have "
- "deferred shape", sym->name, &sym->declared_at);
-
+ {
+ gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
+ "nor a dummy argument", sym->name, &sym->declared_at);
+ return;
+ }
+ /* F2008, C528. */
+ else if (class_attr.codimension && !sym->attr.select_type_temporary
+ && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
+ {
+ gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
+ "deferred shape", sym->name, &sym->declared_at);
+ return;
+ }
+ else if (class_attr.codimension && class_attr.allocatable && as
+ && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
+ {
+ gfc_error ("Allocatable coarray variable '%s' at %L must have "
+ "deferred shape", sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C541. */
- if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
- || (sym->attr.codimension && sym->attr.allocatable))
+ if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->attr.coarray_comp))
+ || (class_attr.codimension && class_attr.allocatable))
&& sym->attr.dummy && sym->attr.intent == INTENT_OUT)
- gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
- "allocatable coarray or have coarray components",
- sym->name, &sym->declared_at);
+ {
+ gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
+ "allocatable coarray or have coarray components",
+ sym->name, &sym->declared_at);
+ return;
+ }
- if (sym->attr.codimension && sym->attr.dummy
+ if (class_attr.codimension && sym->attr.dummy
&& sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
- gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
- "procedure '%s'", sym->name, &sym->declared_at,
- sym->ns->proc_name->name);
+ {
+ gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
+ "procedure '%s'", sym->name, &sym->declared_at,
+ sym->ns->proc_name->name);
+ return;
+ }
switch (sym->attr.flavor)
{
if (formal)
{
sym->formal_ns = formal->sym->ns;
- sym->formal_ns->refs++;
+ if (sym->ns != formal->sym->ns)
+ sym->formal_ns->refs++;
}
}
mpz_set_ui (size, 0);
}
- t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
- offset, range);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr,
+ offset, &range);
mpz_add (offset, offset, range);
mpz_clear (range);
mpz_sub_ui (values.left, values.left, 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, NULL);
if (t == FAILURE)
break;
}
proc = sym->ns->proc_name;
- if (sym->attr.dummy && gfc_pure (proc)
- && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
- ||
- proc->attr.function))
+ if (sym->attr.dummy
+ && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
+ || proc->attr.function))
return 1;
/* TODO: Sort out what can be storage associated, if anything, and include
int
gfc_implicit_pure (gfc_symbol *sym)
{
- symbol_attribute attr;
+ gfc_namespace *ns;
if (sym == NULL)
{
- /* Check if the current namespace is implicit_pure. */
- sym = gfc_current_ns->proc_name;
- if (sym == NULL)
- return 0;
- attr = sym->attr;
- if (attr.flavor == FL_PROCEDURE
- && attr.implicit_pure && !attr.pure)
- return 1;
- return 0;
+ /* Check if the current procedure is implicit_pure. Walk up
+ the procedure list until we find a procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ sym = ns->proc_name;
+ if (sym == NULL)
+ return 0;
+
+ if (sym->attr.flavor == FL_PROCEDURE)
+ break;
+ }
}
-
- attr = sym->attr;
-
- return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
+
+ return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
+ && !sym->attr.pure;
}
&& !gfc_check_symbol_access (sym->ts.u.derived)
&& gfc_check_symbol_access (sym))
{
- gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
+ gfc_notify_std (GFC_STD_F2003, "PUBLIC function '%s' at "
"%L of PRIVATE type '%s'", sym->name,
&sym->declared_at, sym->ts.u.derived->name);
}
}
forall_flag = 0;
+ do_concurrent_flag = 0;
gfc_check_interfaces (ns);
gfc_traverse_ns (ns, resolve_values);
projects / platform / upstream / gcc.git / blobdiff