#include "gfortran.h"
#include "arith.h" /* For gfc_compare_expr(). */
+/* Types used in equivalence statements. */
+
+typedef enum seq_type
+{
+ SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
+}
+seq_type;
/* Stack to push the current if we descend into a block during
resolution. See resolve_branch() and resolve_code(). */
static int forall_flag;
+/* Nonzero if we are processing a formal arglist. The corresponding function
+ resets the flag each time that it is read. */
+static int formal_arg_flag = 0;
+
+int
+gfc_is_formal_arg (void)
+{
+ return formal_arg_flag;
+}
+
/* Resolve types of formal argument lists. These have to be done early so that
the formal argument lists of module procedures can be copied to the
containing module before the individual procedures are resolved
|| (sym->as && sym->as->rank > 0))
proc->attr.always_explicit = 1;
+ formal_arg_flag = 1;
+
for (f = proc->formal; f; f = f->next)
{
sym = f->sym;
}
}
}
+ formal_arg_flag = 0;
}
gfc_ref *ref;
as = e->symtree->n.sym->as;
- c = e->symtree->n.sym->components;
for (ref = e->ref; ref; ref = ref->next)
switch (ref->type)
break;
case REF_COMPONENT:
- for (; c; c = c->next)
+ for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
if (c == ref->u.c.component)
break;
as = c->as;
}
- c = c->ts.derived->components;
break;
case REF_SUBSTRING:
}
}
- if (compare_spec_to_ref (ar) == FAILURE)
+ if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
return FAILURE;
return SUCCESS;
}
+/* Given the expression node e for an allocatable/pointer of derived type to be
+ allocated, get the expression node to be initialized afterwards (needed for
+ derived types with default initializers). */
+
+static gfc_expr *
+expr_to_initialize (gfc_expr * e)
+{
+ gfc_expr *result;
+ gfc_ref *ref;
+ int i;
+
+ result = gfc_copy_expr (e);
+
+ /* Change the last array reference from AR_ELEMENT to AR_FULL. */
+ for (ref = result->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->next == NULL)
+ {
+ ref->u.ar.type = AR_FULL;
+
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+
+ result->rank = ref->u.ar.dimen;
+ break;
+ }
+
+ return result;
+}
+
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
static try
-resolve_allocate_expr (gfc_expr * e)
+resolve_allocate_expr (gfc_expr * e, gfc_code * code)
{
int i, pointer, allocatable, dimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
+ gfc_code *init_st;
+ gfc_expr *init_e;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
return FAILURE;
}
+ /* Add default initializer for those derived types that need them. */
+ if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
+ {
+ init_st = gfc_get_code ();
+ init_st->loc = code->loc;
+ init_st->op = EXEC_ASSIGN;
+ init_st->expr = expr_to_initialize (e);
+ init_st->expr2 = init_e;
+
+ init_st->next = code->next;
+ code->next = init_st;
+ }
+
if (pointer && dimension == 0)
return SUCCESS;
"of type INTEGER", &code->expr->where);
for (a = code->ext.alloc_list; a; a = a->next)
- resolve_allocate_expr (a->expr);
+ resolve_allocate_expr (a->expr, code);
break;
/* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1;
int formal_ns_save, check_constant, mp_flag;
- int i;
- const char *whynot;
+ int i, flag;
gfc_namelist *nl;
gfc_symtree * symtree;
gfc_symtree * this_symtree;
gfc_namespace * ns;
+ gfc_component * c;
+ gfc_formal_arglist * arg;
if (sym->attr.flavor == FL_UNKNOWN)
{
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
{
+ /* The specific case of an external procedure should emit an error
+ in the case that there is no implicit type. */
if (!mp_flag)
- gfc_set_default_type (sym, 0, NULL);
+ gfc_set_default_type (sym, sym->attr.external, NULL);
else
{
/* Result may be in another namespace. */
return;
}
+ /* A module array's shape needs to be constant. */
+
+ if (sym->ns->proc_name
+ && sym->attr.flavor == FL_VARIABLE
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && !sym->attr.use_assoc
+ && !sym->attr.allocatable
+ && !sym->attr.pointer
+ && sym->as != NULL
+ && !gfc_is_compile_time_shape (sym->as))
+ {
+ gfc_error ("Module array '%s' at %L cannot be automatic "
+ "or assumed shape", sym->name, &sym->declared_at);
+ return;
+ }
+
/* Make sure that character string variables with assumed length are
dummy arguments. */
}
}
+ /* If a derived type symbol has reached this point, without its
+ type being declared, we have an error. Notice that most
+ conditions that produce undefined derived types have already
+ been dealt with. However, the likes of:
+ implicit type(t) (t) ..... call foo (t) will get us here if
+ the type is not declared in the scope of the implicit
+ statement. Change the type to BT_UNKNOWN, both because it is so
+ and to prevent an ICE. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.derived->components == NULL)
+ {
+ gfc_error ("The derived type '%s' at %L is of type '%s', "
+ "which has not been defined.", sym->name,
+ &sym->declared_at, sym->ts.derived->name);
+ sym->ts.type = BT_UNKNOWN;
+ return;
+ }
+
+ /* If a component of a derived type is of a type declared to be private,
+ either the derived type definition must contain the PRIVATE statement,
+ or the derived type must be private. (4.4.1 just after R427) */
+ if (sym->attr.flavor == FL_DERIVED
+ && sym->component_access != ACCESS_PRIVATE
+ && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (c = sym->components; c; c = c->next)
+ {
+ if (c->ts.type == BT_DERIVED
+ && !c->ts.derived->attr.use_assoc
+ && !gfc_check_access(c->ts.derived->attr.access,
+ c->ts.derived->ns->default_access))
+ {
+ gfc_error ("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);
+ return;
+ }
+ }
+ }
+
+ /* An assumed-size array with INTENT(OUT) shall not be of a type for which
+ default initialization is defined (5.1.2.4.4). */
+ if (sym->ts.type == BT_DERIVED
+ && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT
+ && sym->as
+ && sym->as->type == AS_ASSUMED_SIZE)
+ {
+ for (c = sym->ts.derived->components; c; c = c->next)
+ {
+ if (c->initializer)
+ {
+ gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
+ "ASSUMED SIZE and so cannot have a default initializer",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ }
+ }
+
+
+ /* Ensure that derived type formal arguments of a public procedure
+ are not of a private type. */
+ if (sym->attr.flavor == FL_PROCEDURE
+ && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (arg = sym->formal; arg; arg = arg->next)
+ {
+ if (arg->sym
+ && arg->sym->ts.type == BT_DERIVED
+ && !arg->sym->ts.derived->attr.use_assoc
+ && !gfc_check_access(arg->sym->ts.derived->attr.access,
+ arg->sym->ts.derived->ns->default_access))
+ {
+ gfc_error_now ("'%s' is a PRIVATE type and cannot be "
+ "a dummy argument of '%s', which is PUBLIC at %L",
+ arg->sym->name, sym->name, &sym->declared_at);
+ /* Stop this message from recurring. */
+ arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ return;
+ }
+ }
+ }
+
/* Constraints on deferred shape variable. */
if (sym->attr.flavor == FL_VARIABLE
|| (sym->attr.flavor == FL_PROCEDURE
if (sym->attr.allocatable)
{
if (sym->attr.dimension)
- gfc_error ("Allocatable array at %L must have a deferred shape",
- &sym->declared_at);
+ gfc_error ("Allocatable array '%s' at %L must have "
+ "a deferred shape", sym->name, &sym->declared_at);
else
- gfc_error ("Object at %L may not be ALLOCATABLE",
- &sym->declared_at);
+ gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
+ sym->name, &sym->declared_at);
return;
}
if (sym->attr.pointer && sym->attr.dimension)
{
- gfc_error ("Pointer to array at %L must have a deferred shape",
- &sym->declared_at);
+ gfc_error ("Array pointer '%s' at %L must have a deferred shape",
+ sym->name, &sym->declared_at);
return;
}
if (!mp_flag && !sym->attr.allocatable
&& !sym->attr.pointer && !sym->attr.dummy)
{
- gfc_error ("Array at %L cannot have a deferred shape",
- &sym->declared_at);
+ gfc_error ("Array '%s' at %L cannot have a deferred shape",
+ sym->name, &sym->declared_at);
return;
}
}
switch (sym->attr.flavor)
{
case FL_VARIABLE:
- /* Can the sybol have an initializer? */
- whynot = NULL;
- if (sym->attr.allocatable)
- whynot = _("Allocatable");
- else if (sym->attr.external)
- whynot = _("External");
- else if (sym->attr.dummy)
- whynot = _("Dummy");
- else if (sym->attr.intrinsic)
- whynot = _("Intrinsic");
- else if (sym->attr.result)
- whynot = _("Function Result");
+ /* Can the symbol have an initializer? */
+ flag = 0;
+ if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
+ || sym->attr.intrinsic || sym->attr.result)
+ flag = 1;
else if (sym->attr.dimension && !sym->attr.pointer)
{
/* Don't allow initialization of automatic arrays. */
|| sym->as->upper[i] == NULL
|| sym->as->upper[i]->expr_type != EXPR_CONSTANT)
{
- whynot = _("Automatic array");
+ flag = 1;
break;
}
}
}
/* Reject illegal initializers. */
- if (sym->value && whynot)
+ if (sym->value && flag)
{
- gfc_error ("%s '%s' at %L cannot have an initializer",
- whynot, sym->name, &sym->declared_at);
+ if (sym->attr.allocatable)
+ gfc_error ("Allocatable '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else if (sym->attr.external)
+ gfc_error ("External '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else if (sym->attr.dummy)
+ gfc_error ("Dummy '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else if (sym->attr.intrinsic)
+ gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else if (sym->attr.result)
+ gfc_error ("Function result '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else
+ gfc_error ("Automatic array '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
return;
}
/* Assign default initializer. */
- if (sym->ts.type == BT_DERIVED && !(sym->value || whynot)
+ if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
&& !sym->attr.pointer)
sym->value = gfc_default_initializer (&sym->ts);
break;
{
for (nl = sym->namelist; nl; nl = nl->next)
{
- if (!gfc_check_access(nl->sym->attr.access,
+ if (!nl->sym->attr.use_assoc
+ &&
+ !(sym->ns->parent == nl->sym->ns)
+ &&
+ !gfc_check_access(nl->sym->attr.access,
nl->sym->ns->default_access))
gfc_error ("PRIVATE symbol '%s' cannot be member of "
"PUBLIC namelist at %L", nl->sym->name,
break;
default:
+
+ /* An external symbol falls through to here if it is not referenced. */
+ if (sym->attr.external && sym->value)
+ {
+ gfc_error ("External object '%s' at %L may not have an initializer",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
break;
}
}
+/* Returns the sequence type of a symbol or sequence. */
+
+static seq_type
+sequence_type (gfc_typespec ts)
+{
+ seq_type result;
+ gfc_component *c;
+
+ switch (ts.type)
+ {
+ case BT_DERIVED:
+
+ if (ts.derived->components == NULL)
+ return SEQ_NONDEFAULT;
+
+ result = sequence_type (ts.derived->components->ts);
+ for (c = ts.derived->components->next; c; c = c->next)
+ if (sequence_type (c->ts) != result)
+ return SEQ_MIXED;
+
+ return result;
+
+ case BT_CHARACTER:
+ if (ts.kind != gfc_default_character_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_CHARACTER;
+
+ case BT_INTEGER:
+ if (ts.kind != gfc_default_integer_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_REAL:
+ if (!(ts.kind == gfc_default_real_kind
+ || ts.kind == gfc_default_double_kind))
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_COMPLEX:
+ if (ts.kind != gfc_default_complex_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_LOGICAL:
+ if (ts.kind != gfc_default_logical_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ default:
+ return SEQ_NONDEFAULT;
+ }
+}
+
+
/* Resolve derived type EQUIVALENCE object. */
static try
in the structure. */
if (c->pointer)
{
- gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
+ gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
+ "cannot be an EQUIVALENCE object", sym->name, &e->where);
+ return FAILURE;
+ }
+
+ if (c->initializer)
+ {
+ gfc_error ("Derived type variable '%s' at %L with default initializer "
"cannot be an EQUIVALENCE object", sym->name, &e->where);
return FAILURE;
}
/* Resolve equivalence object.
- An EQUIVALENCE object shall not be a dummy argument, a pointer, an
- allocatable array, an object of nonsequence derived type, an object of
+ An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
+ an allocatable array, an object of nonsequence derived type, an object of
sequence derived type containing a pointer at any level of component
selection, an automatic object, a function name, an entry name, a result
name, a named constant, a structure component, or a subobject of any of
- the preceding objects. A substring shall not have length zero. */
+ the preceding objects. A substring shall not have length zero. A
+ derived type shall not have components with default initialization nor
+ shall two objects of an equivalence group be initialized.
+ The simple constraints are done in symbol.c(check_conflict) and the rest
+ are implemented here. */
static void
resolve_equivalence (gfc_equiv *eq)
{
gfc_symbol *sym;
gfc_symbol *derived;
+ gfc_symbol *first_sym;
gfc_expr *e;
gfc_ref *r;
+ locus *last_where = NULL;
+ seq_type eq_type, last_eq_type;
+ gfc_typespec *last_ts;
+ int object;
+ const char *value_name;
+ const char *msg;
+
+ value_name = NULL;
+ last_ts = &eq->expr->symtree->n.sym->ts;
+
+ first_sym = eq->expr->symtree->n.sym;
- for (; eq; eq = eq->eq)
+ for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
continue;
sym = e->symtree->n.sym;
-
- /* Shall not be a dummy argument. */
- if (sym->attr.dummy)
- {
- gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
- /* Shall not be an allocatable array. */
- if (sym->attr.allocatable)
- {
- gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
+ /* An equivalence statement cannot have more than one initialized
+ object. */
+ if (sym->value)
+ {
+ if (value_name != NULL)
+ {
+ gfc_error ("Initialized objects '%s' and '%s' cannot both "
+ "be in the EQUIVALENCE statement at %L",
+ value_name, sym->name, &e->where);
+ continue;
+ }
+ else
+ value_name = sym->name;
+ }
- /* Shall not be a pointer. */
- if (sym->attr.pointer)
- {
- gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
- sym->name, &e->where);
- continue;
- }
-
- /* Shall not be a function name, ... */
- if (sym->attr.function || sym->attr.result || sym->attr.entry
- || sym->attr.subroutine)
+ /* Shall not equivalence common block variables in a PURE procedure. */
+ if (sym->ns->proc_name
+ && sym->ns->proc_name->attr.pure
+ && sym->attr.in_common)
{
- gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
- sym->name, &e->where);
- continue;
+ gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
+ "object in the pure procedure '%s'",
+ sym->name, &e->where, sym->ns->proc_name->name);
+ break;
}
-
+
/* Shall not be a named constant. */
if (e->expr_type == EXPR_CONSTANT)
{
if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
continue;
+ /* Check that the types correspond correctly:
+ Note 5.28:
+ A numeric sequence structure may be equivalenced to another sequence
+ structure, an object of default integer type, default real type, double
+ precision real type, default logical type such that components of the
+ structure ultimately only become associated to objects of the same
+ kind. A character sequence structure may be equivalenced to an object
+ of default character kind or another character sequence structure.
+ Other objects may be equivalenced only to objects of the same type and
+ kind parameters. */
+
+ /* Identical types are unconditionally OK. */
+ if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
+ goto identical_types;
+
+ last_eq_type = sequence_type (*last_ts);
+ eq_type = sequence_type (sym->ts);
+
+ /* Since the pair of objects is not of the same type, mixed or
+ non-default sequences can be rejected. */
+
+ msg = "Sequence %s with mixed components in EQUIVALENCE "
+ "statement at %L with different type objects";
+ if ((object ==2
+ && last_eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
+ last_where) == FAILURE)
+ || (eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
+ &e->where) == FAILURE))
+ continue;
+
+ msg = "Non-default type object or sequence %s in EQUIVALENCE "
+ "statement at %L with objects of different type";
+ if ((object ==2
+ && last_eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
+ last_where) == FAILURE)
+ || (eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE))
+ continue;
+
+ msg ="Non-CHARACTER object '%s' in default CHARACTER "
+ "EQUIVALENCE statement at %L";
+ if (last_eq_type == SEQ_CHARACTER
+ && eq_type != SEQ_CHARACTER
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
+ continue;
+
+ msg ="Non-NUMERIC object '%s' in default NUMERIC "
+ "EQUIVALENCE statement at %L";
+ if (last_eq_type == SEQ_NUMERIC
+ && eq_type != SEQ_NUMERIC
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
+ continue;
+
+ identical_types:
+ last_ts =&sym->ts;
+ last_where = &e->where;
+
if (!e->ref)
continue;
OSDN Git Service
