#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)
{
}
+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);
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);
}
else if (!sym->attr.pointer)
{
- if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ 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)
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
+ && !sym->value)
proc->attr.implicit_pure = 0;
}
}
&& 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);
}
const char *name;
char err[200];
- if (gfc_is_proc_ptr_comp (cons->expr, &c2))
+ c2 = gfc_get_proc_ptr_comp (cons->expr);
+ if (c2)
{
s2 = c2->ts.interface;
name = c2->name;
}
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. */
/* 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;
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;
- 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;
}
/* 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;
}
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)
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
{
/* 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))
/* 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))
{
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;
}
}
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 with designator at %L",
- sym->name, &e->ref->u.ar.where);
+ 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. */
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);
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'. */
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
{
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))
"statement at %L", &e->where);
goto failure;
}
- break;
+ continue;
}
if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
}
}
- /* 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;
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);
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);
gfc_error ("Finalization at %L is not yet implemented",
&derived->declared_at);
+ gfc_find_derived_vtab (derived);
return result;
}
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);
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;
/* 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);
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)
{
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)
{
&& !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
&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. */
if (resolve_typebound_procedures (sym) == FAILURE)
return FAILURE;
- /* Resolve the finalizer procedures. */
- if (gfc_resolve_finalizers (sym) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
}
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.artificial)
+ return;
+
if (sym->attr.flavor == FL_UNKNOWN
|| (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
&& !sym->attr.generic && !sym->attr.external
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;
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. */
/* F2008, C530. */
if (sym->attr.contiguous
&& (!class_attr.dimension
- || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
+ || (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 array", sym->name,
- &sym->declared_at);
+ "array pointer or an assumed-shape or assumed-rank array",
+ sym->name, &sym->declared_at);
return;
}
&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,
if (formal)
{
sym->formal_ns = formal->sym->ns;
- sym->formal_ns->refs++;
+ if (sym->ns != formal->sym->ns)
+ sym->formal_ns->refs++;
}
}
}
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
&& !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 / platform / upstream / gcc.git / blobdiff