#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;
-static bool assumed_type_expr_allowed = false;
+/* 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)
{
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. */
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;
- assumed_type_expr_allowed = true;
+ 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;
}
- assumed_type_expr_allowed = 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)
}
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;
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++)
sym = e->symtree->n.sym;
/* TS 29113, 407b. */
- if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+ if (e->ts.type == BT_ASSUMED)
{
- gfc_error ("Invalid expression with assumed-type variable %s at %L",
- sym->name, &e->where);
- return FAILURE;
+ 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))
+ && 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-type variable %s with designator at %L",
- sym->name, &e->ref->u.ar.where);
+ 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. */
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);
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
/* 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;
|| 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,
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);
}
/* Compare the interfaces. */
+ 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))
+ 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 (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);
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 (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, "Fortran 2003: Generic name '%s' of "
+ && 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)
&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
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 "
&& !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