#include "config.h"
#include "system.h"
+#include "coretypes.h"
#include "flags.h"
#include "gfortran.h"
#include "obstack.h"
static int forall_flag;
static int do_concurrent_flag;
+/* True when we are resolving an expression that is an actual argument to
+ a procedure. */
+static bool actual_arg = false;
+/* True when we are resolving an expression that is the first actual argument
+ to a procedure. */
+static bool first_actual_arg = false;
+
+
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
static int omp_workshare_flag;
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
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;
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)
{
sym = f->sym;
+ gfc_array_spec *as;
if (sym == NULL)
{
gfc_set_default_type (sym, 1, sym->ns);
}
- gfc_resolve_array_spec (sym->as, 0);
+ as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+ ? CLASS_DATA (sym)->as : sym->as;
+
+ 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 (proc->attr.function && sym->attr.intent != INTENT_IN)
{
if (sym->attr.value)
- gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
+ 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);
if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
{
if (sym->attr.value)
- gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
+ 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);
&& 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);
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);
}
}
if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
- err, sizeof (err)))
+ err, sizeof (err), NULL, NULL))
{
gfc_error ("Interface mismatch for procedure-pointer component "
"'%s' in structure constructor at %L: %s",
/* 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. */
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)
}
-gfc_array_spec *
-symbol_as (gfc_symbol *sym)
-{
- if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
- return CLASS_DATA (sym)->as;
- else
- return sym->as;
-}
-
-
/* Resolve an actual argument list. Most of the time, this is just
resolving the expressions in the list.
The exception is that we sometimes have to decide whether arguments
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;
}
&& 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;
}
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 **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)
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;
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 (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;
{
/* 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;
+ /* TS 29113, 407b. */
+ if (e->ts.type == BT_ASSUMED)
+ {
+ 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. */
- if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
- return FAILURE;
+ 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);
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
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;
/* 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);
e->value.compcall.actual = NULL;
/* If we find a deferred typebound procedure, check for derived types
- that an over-riding typebound procedure has not been missed. */
- if (e->value.compcall.tbp->deferred
- && e->value.compcall.name
- && !e->value.compcall.tbp->non_overridable
- && e->value.compcall.base_object
- && e->value.compcall.base_object->ts.type == BT_DERIVED)
+ 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;
derived = e->value.compcall.base_object->ts.u.derived;
st = NULL;
- /* If necessary, go throught the inheritance chain. */
+ /* If necessary, go through the inheritance chain. */
while (!st && derived)
{
/* Look for the typebound procedure 'name'. */
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
{
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)
}
}
+ /* Check for F08:C628. */
if (allocatable == 0 && pointer == 0)
{
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
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))
}
}
- /* 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
}
-/* 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.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)
{
/* 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;
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;
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;
{
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
|| 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. */
if (allocatable)
{
- if (dimension)
+ 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 (pointer && 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;
}
}
&& !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)
&& 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);
}
}
/* 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);
check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
const char* generic_name, locus where)
{
- gfc_symbol* sym1;
- gfc_symbol* sym2;
+ gfc_symbol *sym1, *sym2;
+ const char *pass1, *pass2;
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);
sym1 = t1->specific->u.specific->n.sym;
sym2 = t2->specific->u.specific->n.sym;
}
/* 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);
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);
}
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);
for ( ; c != NULL; c = c->next)
{
/* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
- if (c->ts.type == BT_CHARACTER && c->ts.deferred)
+ 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);
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;
&& !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 (!sym->attr.is_class)
gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
if (gen_dt && gen_dt->generic && gen_dt->generic->next
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
+ && (!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
}
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)
symbol_attribute class_attr;
gfc_array_spec *as;
- if (sym->attr.flavor == FL_UNKNOWN)
+ 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)
&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_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
&& !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,
&& !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);
}
projects / gcc.git / blobdiff