static code_stack *cs_base = NULL;
-/* Nonzero if we're inside a FORALL block. */
+/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
static int forall_flag;
+static int do_concurrent_flag;
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
- sym->ts = ifc->result->ts;
+ {
+ sym->ts = ifc->result->ts;
+ sym->result = sym;
+ }
else
sym->ts = ifc->ts;
sym->ts.interface = ifc;
if (sym->attr.if_source != IFSRC_UNKNOWN)
resolve_formal_arglist (sym);
- if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
+ if (sym->attr.subroutine || sym->attr.external)
{
- if (gfc_pure (proc) && !gfc_pure (sym))
- {
- gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
- "also be PURE", sym->name, &sym->declared_at);
- continue;
- }
-
- if (proc->attr.implicit_pure && !gfc_pure(sym))
- proc->attr.implicit_pure = 0;
-
- if (gfc_elemental (proc))
- {
- gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
- "procedure", &sym->declared_at);
- continue;
- }
-
- if (sym->attr.function
- && sym->ts.type == BT_UNKNOWN
- && sym->attr.intrinsic)
- {
- gfc_intrinsic_sym *isym;
- isym = gfc_find_function (sym->name);
- if (isym == NULL || !isym->specific)
- {
- gfc_error ("Unable to find a specific INTRINSIC procedure "
- "for the reference '%s' at %L", sym->name,
- &sym->declared_at);
- }
- sym->ts = isym->ts;
- }
-
- continue;
+ if (sym->attr.flavor == FL_UNKNOWN)
+ gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
+ }
+ else
+ {
+ if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
+ && (!sym->attr.function || sym->result == sym))
+ gfc_set_default_type (sym, 1, sym->ns);
}
-
- if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
- && (!sym->attr.function || sym->result == sym))
- gfc_set_default_type (sym, 1, sym->ns);
gfc_resolve_array_spec (sym->as, 0);
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))
+ && !(sym->attr.pointer || sym->attr.allocatable)
+ && sym->attr.flavor != FL_PROCEDURE)
{
sym->as->type = AS_ASSUMED_SHAPE;
for (i = 0; i < sym->as->rank; i++)
if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
- if (gfc_pure (proc) && !sym->attr.pointer
- && sym->attr.flavor != FL_PROCEDURE)
+ if (gfc_pure (proc))
{
- if (proc->attr.function && sym->attr.intent != INTENT_IN)
- gfc_error ("Argument '%s' of pure function '%s' at %L must be "
- "INTENT(IN)", sym->name, proc->name,
- &sym->declared_at);
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ /* F08:C1279. */
+ if (!gfc_pure (sym))
+ {
+ gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
+ "also be PURE", sym->name, &sym->declared_at);
+ continue;
+ }
+ }
+ else if (!sym->attr.pointer)
+ {
+ if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ {
+ if (sym->attr.value)
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
+ " of pure function '%s' at %L with VALUE "
+ "attribute but without INTENT(IN)",
+ sym->name, proc->name, &sym->declared_at);
+ else
+ gfc_error ("Argument '%s' of pure function '%s' at %L must "
+ "be INTENT(IN) or VALUE", sym->name, proc->name,
+ &sym->declared_at);
+ }
- if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
- gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
- "have its INTENT specified", 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'"
+ " of pure subroutine '%s' at %L with VALUE "
+ "attribute but without INTENT", sym->name,
+ proc->name, &sym->declared_at);
+ else
+ gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
+ "must have its INTENT specified or have the "
+ "VALUE attribute", sym->name, proc->name,
+ &sym->declared_at);
+ }
+ }
}
- if (proc->attr.implicit_pure && !sym->attr.pointer
- && sym->attr.flavor != FL_PROCEDURE)
+ if (proc->attr.implicit_pure)
{
- if (proc->attr.function && sym->attr.intent != INTENT_IN)
- proc->attr.implicit_pure = 0;
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ if (!gfc_pure(sym))
+ proc->attr.implicit_pure = 0;
+ }
+ else if (!sym->attr.pointer)
+ {
+ if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ proc->attr.implicit_pure = 0;
- if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
- proc->attr.implicit_pure = 0;
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ proc->attr.implicit_pure = 0;
+ }
}
if (gfc_elemental (proc))
{
- /* F2008, C1289. */
+ /* F08:C1289. */
if (sym->attr.codimension)
{
gfc_error ("Coarray dummy argument '%s' at %L to elemental "
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
- if (!cl || !cl->length)
+ if ((!cl || !cl->length) && !sym->result->ts.deferred)
{
/* See if this is a module-procedure and adapt error message
accordingly. */
gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
sym->name, &common_root->n.common->where, &sym->declared_at);
+ if (sym->attr.external)
+ gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
+ sym->name, &common_root->n.common->where);
+
if (sym->attr.intrinsic)
gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
sym->name, &common_root->n.common->where);
}
+static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
+
+
/* Resolve all of the elements of a structure constructor and make sure that
the types are correct. The 'init' flag indicates that the given
constructor is an initializer. */
t = SUCCESS;
if (expr->ts.type == BT_DERIVED)
- resolve_symbol (expr->ts.u.derived);
+ resolve_fl_derived0 (expr->ts.u.derived);
cons = gfc_constructor_first (expr->value.constructor);
/* A constructor may have references if it is the result of substituting a
if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
&& (comp->attr.allocatable || cons->expr->rank))
{
- gfc_error ("The rank of the element in the derived type "
+ gfc_error ("The rank of the element in the structure "
"constructor at %L does not match that of the "
"component (%d/%d)", &cons->expr->where,
cons->expr->rank, rank);
t = SUCCESS;
}
else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
- gfc_error ("The element in the derived type constructor at %L, "
+ gfc_error ("The element in the structure constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
gfc_basic_typename (cons->expr->ts.type),
cl2->next = cl->next;
gfc_free_expr (cl->length);
- gfc_free (cl);
+ free (cl);
}
cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|| CLASS_DATA (comp)->attr.allocatable))))
{
t = FAILURE;
- gfc_error ("The NULL in the derived type constructor at %L is "
+ gfc_error ("The NULL in the structure constructor at %L is "
"being applied to component '%s', which is neither "
"a POINTER nor ALLOCATABLE", &cons->expr->where,
comp->name);
}
+ if (comp->attr.proc_pointer && comp->ts.interface)
+ {
+ /* Check procedure pointer interface. */
+ gfc_symbol *s2 = NULL;
+ gfc_component *c2;
+ const char *name;
+ char err[200];
+
+ if (gfc_is_proc_ptr_comp (cons->expr, &c2))
+ {
+ s2 = c2->ts.interface;
+ name = c2->name;
+ }
+ else if (cons->expr->expr_type == EXPR_FUNCTION)
+ {
+ s2 = cons->expr->symtree->n.sym->result;
+ name = cons->expr->symtree->n.sym->result->name;
+ }
+ else if (cons->expr->expr_type != EXPR_NULL)
+ {
+ s2 = cons->expr->symtree->n.sym;
+ name = cons->expr->symtree->n.sym->name;
+ }
+
+ if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
+ err, sizeof (err)))
+ {
+ gfc_error ("Interface mismatch for procedure-pointer component "
+ "'%s' in structure constructor at %L: %s",
+ comp->name, &cons->expr->where, err);
+ return FAILURE;
+ }
+ }
+
if (!comp->attr.pointer || comp->attr.proc_pointer
|| cons->expr->expr_type == EXPR_NULL)
continue;
if (!a.pointer && !a.target)
{
t = FAILURE;
- gfc_error ("The element in the derived type constructor at %L, "
+ gfc_error ("The element in the structure constructor at %L, "
"for pointer component '%s' should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
|| gfc_is_coindexed (cons->expr)))
{
t = FAILURE;
- gfc_error ("Invalid expression in the derived type constructor for "
+ gfc_error ("Invalid expression in the structure constructor for "
"pointer component '%s' at %L in PURE procedure",
comp->name, &cons->expr->where);
}
if (sym->formal)
return SUCCESS;
+ /* Already resolved. */
+ if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
+ return SUCCESS;
+
/* We already know this one is an intrinsic, so we don't call
gfc_is_intrinsic for full checking but rather use gfc_find_function and
gfc_find_subroutine directly to check whether it is a function or
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
- gfc_component *comp;
for (; arg; arg = arg->next)
{
continue;
}
- if (gfc_is_proc_ptr_comp (e, &comp))
- {
- e->ts = comp->ts;
- if (e->expr_type == EXPR_PPC)
- {
- if (comp->as != NULL)
- e->rank = comp->as->rank;
- e->expr_type = EXPR_FUNCTION;
- }
- if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
- goto argument_list;
- }
-
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.generic
&& no_formal_args
if (!gsym->ns->resolved)
{
gfc_dt_list *old_dt_list;
+ struct gfc_omp_saved_state old_omp_state;
/* Stash away derived types so that the backend_decls do not
get mixed up. */
old_dt_list = gfc_derived_types;
gfc_derived_types = NULL;
+ /* And stash away openmp state. */
+ gfc_omp_save_and_clear_state (&old_omp_state);
gfc_resolve (gsym->ns);
/* Restore the derived types of this namespace. */
gfc_derived_types = old_dt_list;
+ /* And openmp state. */
+ gfc_omp_restore_state (&old_omp_state);
}
/* Make sure that translation for the gsymbol occurs before
/* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
- && def_sym->ts.u.cl->length != NULL)
+ && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
switch (ref->type)
{
case REF_SUBSTRING:
- if (ref->u.ss.length != NULL
- && ref->u.ss.length->length != NULL
- && ref->u.ss.start
- && ref->u.ss.start->expr_type == EXPR_CONSTANT
- && ref->u.ss.end
- && ref->u.ss.end->expr_type == EXPR_CONSTANT)
- {
- start = (int) mpz_get_si (ref->u.ss.start->value.integer);
- end = (int) mpz_get_si (ref->u.ss.end->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
- else
- retval = FAILURE;
+ if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
+ || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
+ retval = FAILURE;
break;
+
case REF_ARRAY:
if (ref->u.ar.type == AR_ELEMENT)
retval = SUCCESS;
{
/* We have constant lower and upper bounds. If the
difference between is 1, it can be considered a
- scalar. */
+ scalar.
+ FIXME: Use gfc_dep_compare_expr instead. */
start = (int) mpz_get_si
(ref->u.ar.as->lower[0]->value.integer);
end = (int) mpz_get_si
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
+ gfc_ref *ref;
+ bool seen_section;
+
/* Make sure we have either the target or pointer attribute. */
if (!arg_attr.target && !arg_attr.pointer)
{
retval = FAILURE;
}
+ if (gfc_is_coindexed (args->expr))
+ {
+ gfc_error_now ("Coindexed argument not permitted"
+ " in '%s' call at %L", name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+
+ /* Follow references to make sure there are no array
+ sections. */
+ seen_section = false;
+
+ for (ref=args->expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY)
+ {
+ if (ref->u.ar.type == AR_SECTION)
+ seen_section = true;
+
+ if (ref->u.ar.type != AR_ELEMENT)
+ {
+ gfc_ref *r;
+ for (r = ref->next; r; r=r->next)
+ if (r->type == REF_COMPONENT)
+ {
+ gfc_error_now ("Array section not permitted"
+ " in '%s' call at %L", name,
+ &(args->expr->where));
+ retval = FAILURE;
+ break;
+ }
+ }
+ }
+ }
+
+ if (seen_section && retval == SUCCESS)
+ gfc_warning ("Array section in '%s' call at %L", name,
+ &(args->expr->where));
+
/* See if we have interoperable type and type param. */
- if (verify_c_interop (arg_ts) == SUCCESS
+ if (gfc_verify_c_interop (arg_ts) == SUCCESS
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
{
if (args_sym->attr.target == 1)
&& sym->ts.u.cl
&& sym->ts.u.cl->length == NULL
&& !sym->attr.dummy
+ && !sym->ts.deferred
&& expr->value.function.esym == NULL
&& !sym->attr.contained)
{
{
if (forall_flag)
{
- gfc_error ("reference to non-PURE function '%s' at %L inside a "
+ gfc_error ("Reference to non-PURE function '%s' at %L inside a "
"FORALL %s", name, &expr->where,
forall_flag == 2 ? "mask" : "block");
t = FAILURE;
}
+ else if (do_concurrent_flag)
+ {
+ gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+ "DO CONCURRENT %s", name, &expr->where,
+ do_concurrent_flag == 2 ? "mask" : "block");
+ t = FAILURE;
+ }
else if (gfc_pure (NULL))
{
gfc_error ("Function reference to '%s' at %L is to a non-PURE "
if (forall_flag)
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
sym->name, &c->loc);
+ else if (do_concurrent_flag)
+ gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
+ "PURE", sym->name, &c->loc);
else if (gfc_pure (NULL))
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
&c->loc);
switch (ar->dimen_type[i])
{
case DIMEN_VECTOR:
+ case DIMEN_THIS_IMAGE:
break;
case DIMEN_STAR:
if (ar->codimen != 0)
for (i = as->rank; i < as->rank + as->corank; i++)
{
- if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+ if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
+ && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
{
gfc_error ("Coindex of codimension %d must be a scalar at %L",
i + 1 - as->rank, &ar->where);
/* Fill in the upper bound, which may be lower than the
specified one for something like a(2:10:5), which is
identical to a(2:7:5). Only relevant for strides not equal
- to one. */
+ to one. Don't try a division by zero. */
if (ar->dimen_type[i] == DIMEN_RANGE
&& ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
+ && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
+ && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
{
mpz_t size, end;
}
}
- if (ar->type == AR_FULL && ar->as->rank == 0)
- ar->type = AR_ELEMENT;
+ if (ar->type == AR_FULL)
+ {
+ if (ar->as->rank == 0)
+ ar->type = AR_ELEMENT;
+
+ /* Make sure array is the same as array(:,:), this way
+ we don't need to special case all the time. */
+ ar->dimen = ar->as->rank;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ ar->dimen_type[i] = DIMEN_RANGE;
+
+ gcc_assert (ar->start[i] == NULL);
+ gcc_assert (ar->end[i] == NULL);
+ gcc_assert (ar->stride[i] == NULL);
+ }
+ }
/* If the reference type is unknown, figure out what kind it is. */
if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
return FAILURE;
+ if (ar->as->corank && ar->codimen == 0)
+ {
+ int n;
+ ar->codimen = ar->as->corank;
+ for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
+ ar->dimen_type[n] = DIMEN_THIS_IMAGE;
+ }
+
return SUCCESS;
}
for (ref = e->ref; ref; ref = ref->next)
{
+ if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->attr.function && !ref->next)
+ rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
+
if (ref->type != REF_ARRAY)
continue;
&& sym->attr.contained)
{
/* Clear the shape, since it might not be valid. */
- if (e->shape != NULL)
- {
- for (n = 0; n < e->rank; n++)
- mpz_clear (e->shape[n]);
-
- gfc_free (e->shape);
- }
+ gfc_free_shape (&e->shape, e->rank);
/* Give the expression the right symtree! */
gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
{
/* Original was variable so convert array references into
an actual arglist. This does not need any checking now
- since gfc_resolve_function will take care of it. */
+ since resolve_function will take care of it. */
e->value.function.actual = NULL;
e->expr_type = EXPR_FUNCTION;
e->symtree = st;
/* Make sure that we have the right specific instance for the name. */
derived = get_declared_from_expr (NULL, NULL, e);
- st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
+ st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
e->value.compcall.tbp = st->n.tb;
/* Deal with typebound operators for CLASS objects. */
expr = code->expr1->value.compcall.base_object;
- if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
- && code->expr1->value.compcall.name)
+ if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
{
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
- ts = expr->symtree->n.sym->ts;
- declared = ts.u.derived;
+ declared = expr->ts.u.derived;
c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
c->ts.u.derived = gfc_find_derived_vtab (declared);
/* Use the generic name if it is there. */
name = name ? name : code->expr1->value.function.esym->name;
code->expr1->symtree = expr->symtree;
- expr->symtree->n.sym->ts.u.derived = declared;
+ code->expr1->ref = gfc_copy_ref (expr->ref);
gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
code->expr1->value.function.esym = NULL;
== FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
+ if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
== FAILURE)
return FAILURE;
switch (ref->type)
{
case REF_ARRAY:
- if (ref->u.ar.type != AR_FULL)
+ if (ref->u.ar.type != AR_FULL
+ && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
+ && ref->u.ar.codimen && gfc_ref_this_image (ref)))
allocatable = 0;
break;
return FAILURE;
}
+ /* F2008, C644. */
+ if (gfc_is_coindexed (e))
+ {
+ gfc_error ("Coindexed allocatable object at %L", &e->where);
+ return FAILURE;
+ }
+
if (pointer
- && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
+ && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
+ == FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
+ if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
+ == FAILURE)
return FAILURE;
return SUCCESS;
for (i = 0; i < ref->u.ar.dimen; i++)
ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
- result->rank = ref->u.ar.dimen;
break;
}
+ gfc_free_shape (&result->shape, result->rank);
+
+ /* Recalculate rank, shape, etc. */
+ gfc_resolve_expr (result);
return result;
}
{
int i, pointer, allocatable, dimension, is_abstract;
int codimension;
+ bool coindexed;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_expr *e2;
codimension = sym->attr.codimension;
}
+ coindexed = false;
+
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
+ if (ref->u.ar.codimen > 0)
+ {
+ int n;
+ for (n = ref->u.ar.dimen;
+ n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+ if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+ {
+ coindexed = true;
+ break;
+ }
+ }
+
if (ref->next != NULL)
pointer = 0;
break;
case REF_COMPONENT:
/* F2008, C644. */
- if (gfc_is_coindexed (e))
+ if (coindexed)
{
gfc_error ("Coindexed allocatable object at %L",
&e->where);
&e->where, &code->expr3->where);
goto failure;
}
+
+ /* Check F2008, C642. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
+ || (code->expr3->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && code->expr3->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_LOCK_TYPE)))
+ {
+ gfc_error ("The source-expr at %L shall neither be of type "
+ "LOCK_TYPE nor have a LOCK_TYPE component if "
+ "allocate-object at %L is a coarray",
+ &code->expr3->where, &e->where);
+ goto failure;
+ }
}
/* Check F08:C629. */
e2 = remove_last_array_ref (e);
t = SUCCESS;
if (t == SUCCESS && pointer)
- t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
+ t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
if (t == SUCCESS)
- t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
+ t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
gfc_free_expr (e2);
if (t == FAILURE)
goto failure;
gfc_find_derived_vtab (ts.u.derived);
}
- if (pointer || (dimension == 0 && codimension == 0))
+ if (dimension == 0 && codimension == 0)
goto success;
/* Make sure the last reference node is an array specifiction. */
ar = &ref2->u.ar;
- if (codimension && ar->codimen == 0)
- {
- gfc_error ("Coarray specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
- }
+ if (codimension)
+ for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
+ if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
+ {
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
for (i = 0; i < ar->dimen; i++)
{
case DIMEN_UNKNOWN:
case DIMEN_VECTOR:
case DIMEN_STAR:
+ case DIMEN_THIS_IMAGE:
gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where);
goto failure;
goto failure;
}
- if (codimension && ar->as->rank == 0)
- {
- gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
- "at %L", &e->where);
- goto failure;
- }
-
success:
- if (e->ts.deferred)
- {
- gfc_error ("Support for entity at %L with deferred type parameter "
- "not yet implemented", &e->where);
- return FAILURE;
- }
return SUCCESS;
failure:
/* Check the stat variable. */
if (stat)
{
- gfc_check_vardef_context (stat, false, _("STAT variable"));
+ gfc_check_vardef_context (stat, false, false, _("STAT variable"));
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
- gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
+ gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
if (type == BT_INTEGER)
for (body = code->block; body; body = body->block)
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
if (cp->low
&& gfc_check_integer_range (cp->low->value.integer,
for (body = code->block; body; body = body->block)
{
/* Walk the case label list. */
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
/* Intercept the DEFAULT case. It does not have a kind. */
if (cp->low == NULL && cp->high == NULL)
/* Walk the case label list, making sure that all case labels
are legal. */
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
/* Count the number of cases in the whole construct. */
ncases++;
if (seen_unreachable)
{
/* Advance until the first case in the list is reachable. */
- while (body->ext.case_list != NULL
- && body->ext.case_list->unreachable)
+ while (body->ext.block.case_list != NULL
+ && body->ext.block.case_list->unreachable)
{
- gfc_case *n = body->ext.case_list;
- body->ext.case_list = body->ext.case_list->next;
+ gfc_case *n = body->ext.block.case_list;
+ body->ext.block.case_list = body->ext.block.case_list->next;
n->next = NULL;
gfc_free_case_list (n);
}
/* Strip all other unreachable cases. */
- if (body->ext.case_list)
+ if (body->ext.block.case_list)
{
- for (cp = body->ext.case_list; cp->next; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
{
if (cp->next->unreachable)
{
unreachable case labels for a block. */
for (body = code; body && body->block; body = body->block)
{
- if (body->block->ext.case_list == NULL)
+ if (body->block->ext.block.case_list == NULL)
{
/* Cut the unreachable block from the code chain. */
gfc_code *c = body->block;
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
- c = body->ext.case_list;
+ c = body->ext.block.case_list;
/* Check F03:C815. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
{
gfc_error ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
- &default_case->ext.case_list->where, &c->where);
+ &default_case->ext.block.case_list->where, &c->where);
error++;
continue;
}
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
- c = body->ext.case_list;
+ c = body->ext.block.case_list;
if (c->ts.type == BT_DERIVED)
c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
body = code;
while (body && body->block)
{
- if (body->block->ext.case_list->ts.type == BT_CLASS)
+ if (body->block->ext.block.case_list->ts.type == BT_CLASS)
{
/* Add to class_is list. */
if (class_is == NULL)
tail->block = gfc_get_code ();
tail = tail->block;
tail->op = EXEC_SELECT_TYPE;
- tail->ext.case_list = gfc_get_case ();
- tail->ext.case_list->ts.type = BT_UNKNOWN;
+ tail->ext.block.case_list = gfc_get_case ();
+ tail->ext.block.case_list->ts.type = BT_UNKNOWN;
tail->next = NULL;
default_case = tail;
}
{
c2 = (*c1)->block;
/* F03:C817 (check for doubles). */
- if ((*c1)->ext.case_list->ts.u.derived->hash_value
- == c2->ext.case_list->ts.u.derived->hash_value)
+ if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
+ == c2->ext.block.case_list->ts.u.derived->hash_value)
{
gfc_error ("Double CLASS IS block in SELECT TYPE "
- "statement at %L", &c2->ext.case_list->where);
+ "statement at %L",
+ &c2->ext.block.case_list->where);
return;
}
- if ((*c1)->ext.case_list->ts.u.derived->attr.extension
- < c2->ext.case_list->ts.u.derived->attr.extension)
+ if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
+ < c2->ext.block.case_list->ts.u.derived->attr.extension)
{
/* Swap. */
(*c1)->block = c2->block;
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
new_st->expr1->value.function.actual->expr->where = code->loc;
gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
- vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+ vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
&& exp->value.op.op == INTRINSIC_PARENTHESES)
exp = exp->value.op.op1;
+ if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
+ {
+ gfc_error ("NULL intrinsic at %L in data transfer statement requires "
+ "MOLD=", &exp->where);
+ return;
+ }
+
if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
&& exp->expr_type != EXPR_FUNCTION))
return;
code->ext.dt may be NULL if the TRANSFER is related to
an INQUIRE statement -- but in this case, we are not reading, either. */
if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
- && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
+ && gfc_check_vardef_context (exp, false, false, _("item in READ"))
+ == FAILURE)
return;
sym = exp->symtree->n.sym;
components. */
if (ts->u.derived->attr.pointer_comp)
{
+ gfc_error ("Data transfer element at %L cannot have POINTER "
+ "components unless it is processed by a defined "
+ "input/output procedure", &code->loc);
+ return;
+ }
+
+ /* F08:C935. */
+ if (ts->u.derived->attr.proc_pointer_comp)
+ {
gfc_error ("Data transfer element at %L cannot have "
- "POINTER components", &code->loc);
+ "procedure pointer components", &code->loc);
return;
}
if (ts->u.derived->attr.alloc_comp)
{
- gfc_error ("Data transfer element at %L cannot have "
- "ALLOCATABLE components", &code->loc);
+ gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
+ "components unless it is processed by a defined "
+ "input/output procedure", &code->loc);
return;
}
}
}
- if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
+ if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
&& exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
{
gfc_error ("Data transfer element at %L cannot be a full reference to "
up through the code_stack. */
for (c = block; c; c = c->next)
{
- if (c->here && c->op != EXEC_END_BLOCK)
+ if (c->here && c->op != EXEC_END_NESTED_BLOCK)
bitmap_set_bit (cs_base->reachable_labels, c->here->value);
}
static void
+resolve_lock_unlock (gfc_code *code)
+{
+ if (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+ || code->expr1->rank != 0
+ || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
+ gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
+ &code->expr1->where);
+
+ /* Check STAT. */
+ if (code->expr2
+ && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+ || code->expr2->expr_type != EXPR_VARIABLE))
+ gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+ &code->expr2->where);
+
+ if (code->expr2
+ && gfc_check_vardef_context (code->expr2, false, false,
+ _("STAT variable")) == FAILURE)
+ return;
+
+ /* Check ERRMSG. */
+ if (code->expr3
+ && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+ || code->expr3->expr_type != EXPR_VARIABLE))
+ gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+ &code->expr3->where);
+
+ if (code->expr3
+ && gfc_check_vardef_context (code->expr3, false, false,
+ _("ERRMSG variable")) == FAILURE)
+ return;
+
+ /* Check ACQUIRED_LOCK. */
+ if (code->expr4
+ && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
+ || code->expr4->expr_type != EXPR_VARIABLE))
+ gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
+ "variable", &code->expr4->where);
+
+ if (code->expr4
+ && gfc_check_vardef_context (code->expr4, false, false,
+ _("ACQUIRED_LOCK variable")) == FAILURE)
+ return;
+}
+
+
+static void
resolve_sync (gfc_code *code)
{
/* Check imageset. The * case matches expr1 == NULL. */
whether the label is still visible outside of the CRITICAL block,
which is invalid. */
for (stack = cs_base; stack; stack = stack->prev)
- if (stack->current->op == EXEC_CRITICAL
- && bitmap_bit_p (stack->reachable_labels, label->value))
- gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
- " at %L", &code->loc, &label->where);
+ {
+ if (stack->current->op == EXEC_CRITICAL
+ && bitmap_bit_p (stack->reachable_labels, label->value))
+ gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
+ "label at %L", &code->loc, &label->where);
+ else if (stack->current->op == EXEC_DO_CONCURRENT
+ && bitmap_bit_p (stack->reachable_labels, label->value))
+ gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
+ "for label at %L", &code->loc, &label->where);
+ }
return;
}
" at %L", &code->loc, &label->where);
return;
}
+ else if (stack->current->op == EXEC_DO_CONCURRENT)
+ {
+ gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
+ "label at %L", &code->loc, &label->where);
+ return;
+ }
}
if (stack)
{
- gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
+ gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
return;
}
result = SUCCESS;
over:
- for (i--; i >= 0; i--)
- {
- mpz_clear (shape[i]);
- mpz_clear (shape2[i]);
- }
+ gfc_clear_shape (shape, i);
+ gfc_clear_shape (shape2, i);
return result;
}
total_var = gfc_count_forall_iterators (code);
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
- var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
+ var_expr = XCNEWVEC (gfc_expr *, total_var);
}
/* The information about FORALL iterator, including FORALL index start, end
gcc_assert (forall_save == 0);
/* VAR_EXPR is not needed any more. */
- gfc_free (var_expr);
+ free (var_expr);
total_var = 0;
}
}
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_DO_CONCURRENT:
case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
break;
resolve_code (gfc_code *code, gfc_namespace *ns)
{
int omp_workshare_save;
- int forall_save;
+ int forall_save, do_concurrent_save;
code_stack frame;
gfc_try t;
{
frame.current = code;
forall_save = forall_flag;
+ do_concurrent_save = do_concurrent_flag;
if (code->op == EXEC_FORALL)
{
/* Blocks are handled in resolve_select_type because we have
to transform the SELECT TYPE into ASSOCIATE first. */
break;
+ case EXEC_DO_CONCURRENT:
+ do_concurrent_flag = 1;
+ gfc_resolve_blocks (code->block, ns);
+ do_concurrent_flag = 2;
+ break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
t = gfc_resolve_expr (code->expr1);
forall_flag = forall_save;
+ do_concurrent_flag = do_concurrent_save;
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
{
case EXEC_NOP:
case EXEC_END_BLOCK:
+ case EXEC_END_NESTED_BLOCK:
case EXEC_CYCLE:
case EXEC_PAUSE:
case EXEC_STOP:
resolve_sync (code);
break;
+ case EXEC_LOCK:
+ case EXEC_UNLOCK:
+ resolve_lock_unlock (code);
+ break;
+
case EXEC_ENTRY:
/* Keep track of which entry we are up to. */
current_entry_id = code->ext.entry->id;
if (t == FAILURE)
break;
- if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
- == FAILURE)
+ if (gfc_check_vardef_context (code->expr1, false, false,
+ _("assignment")) == FAILURE)
break;
if (resolve_ordinary_assign (code, ns))
array ref may be present on the LHS and fool gfc_expr_attr
used in gfc_check_vardef_context. Remove it. */
e = remove_last_array_ref (code->expr1);
- t = gfc_check_vardef_context (e, true, _("pointer assignment"));
+ t = gfc_check_vardef_context (e, true, false,
+ _("pointer assignment"));
if (t == SUCCESS)
- t = gfc_check_vardef_context (e, false, _("pointer assignment"));
+ t = gfc_check_vardef_context (e, false, false,
+ _("pointer assignment"));
gfc_free_expr (e);
if (t == FAILURE)
break;
resolve_transfer (code);
break;
+ case EXEC_DO_CONCURRENT:
case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator);
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
gfc_resolve_omp_directive (code, ns);
break;
static gfc_try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
+ /* Avoid double diagnostics for function result symbols. */
+ if ((sym->result || sym->attr.result) && !sym->attr.dummy
+ && (sym->ns != gfc_current_ns))
+ return SUCCESS;
+
/* Constraints on deferred shape variable. */
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
{
else
{
if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
- && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
+ && sym->ts.type != BT_CLASS && !sym->assoc)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
if (!gfc_is_constant_expr (e)
&& !(e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
- && sym->ns->proc_name
- && (sym->ns->proc_name->attr.flavor == FL_MODULE
- || sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc)
- {
- gfc_error ("'%s' at %L must have constant character length "
- "in this context", sym->name, &sym->declared_at);
- return FAILURE;
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
+ {
+ if (!sym->attr.use_assoc && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program))
+ {
+ gfc_error ("'%s' at %L must have constant character length "
+ "in this context", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ if (sym->attr.in_common)
+ {
+ gfc_error ("COMMON variable '%s' at %L must have constant "
+ "character length", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
}
}
/* Also, they must not have the SAVE attribute.
SAVE_IMPLICIT is checked below. */
- if (sym->attr.save == SAVE_EXPLICIT)
+ if (sym->as && sym->attr.codimension)
+ {
+ int corank = sym->as->corank;
+ sym->as->corank = 0;
+ no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
+ sym->as->corank = corank;
+ }
+ if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
/* Reject illegal initializers. */
if (!sym->mark && sym->value)
{
- if (sym->attr.allocatable)
+ if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.allocatable))
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.external)
the host. */
if (!(sym->ns->parent
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
- && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ && gfc_check_symbol_access (sym))
{
gfc_interface *iface;
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
"PRIVATE type and cannot be a dummy argument"
" of '%s', which is PUBLIC at %L",
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
return FAILURE;
}
+ if (sym->attr.proc == PROC_ST_FUNCTION
+ && (sym->attr.allocatable || sym->attr.pointer))
+ {
+ gfc_error ("Statement function '%s' at %L may not have pointer or "
+ "allocatable attribute", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
/* 5.1.1.5 of the Standard: A function name declared with an asterisk
char-len-param shall not be array-valued, pointer-valued, recursive
or pure. ....snip... A character value of * may only be used in the
}
/* Appendix B.2 of the standard. Contained functions give an
- error anyway. Fixed-form is likely to be F77/legacy. */
- if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
+ error anyway. Fixed-form is likely to be F77/legacy. Deferred
+ character length is an F2003 feature. */
+ if (!sym->attr.contained
+ && gfc_current_form != FORM_FIXED
+ && !sym->ts.deferred)
gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
"CHARACTER(*) function '%s' at %L",
sym->name, &sym->declared_at);
{
/* Skip implicitly typed dummy args here. */
if (curr_arg->sym->attr.implicit_type == 0)
- if (verify_c_interop_param (curr_arg->sym) == FAILURE)
+ if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
/* If something is found to fail, record the fact so we
can mark the symbol for the procedure as not being
BIND(C) to try and prevent multiple errors being
}
-/* Check that it is ok for the typebound procedure proc to override the
- procedure old. */
-
-static gfc_try
-check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
-{
- locus where;
- const gfc_symbol* proc_target;
- const gfc_symbol* old_target;
- unsigned proc_pass_arg, old_pass_arg, argpos;
- gfc_formal_arglist* proc_formal;
- gfc_formal_arglist* old_formal;
-
- /* This procedure should only be called for non-GENERIC proc. */
- gcc_assert (!proc->n.tb->is_generic);
-
- /* If the overwritten procedure is GENERIC, this is an error. */
- if (old->n.tb->is_generic)
- {
- gfc_error ("Can't overwrite GENERIC '%s' at %L",
- old->name, &proc->n.tb->where);
- return FAILURE;
- }
-
- where = proc->n.tb->where;
- proc_target = proc->n.tb->u.specific->n.sym;
- old_target = old->n.tb->u.specific->n.sym;
-
- /* Check that overridden binding is not NON_OVERRIDABLE. */
- if (old->n.tb->non_overridable)
- {
- gfc_error ("'%s' at %L overrides a procedure binding declared"
- " NON_OVERRIDABLE", proc->name, &where);
- return FAILURE;
- }
-
- /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
- if (!old->n.tb->deferred && proc->n.tb->deferred)
- {
- gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
- " non-DEFERRED binding", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is PURE, the overriding must be, too. */
- if (old_target->attr.pure && !proc_target->attr.pure)
- {
- gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
- proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
- is not, the overriding must not be either. */
- if (old_target->attr.elemental && !proc_target->attr.elemental)
- {
- gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
- " ELEMENTAL", proc->name, &where);
- return FAILURE;
- }
- if (!old_target->attr.elemental && proc_target->attr.elemental)
- {
- gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
- " be ELEMENTAL, either", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is a SUBROUTINE, the overriding must also be a
- SUBROUTINE. */
- if (old_target->attr.subroutine && !proc_target->attr.subroutine)
- {
- gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
- " SUBROUTINE", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is a FUNCTION, the overriding must also be a
- FUNCTION and have the same characteristics. */
- if (old_target->attr.function)
- {
- if (!proc_target->attr.function)
- {
- gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
- " FUNCTION", proc->name, &where);
- return FAILURE;
- }
-
- /* FIXME: Do more comprehensive checking (including, for instance, the
- rank and array-shape). */
- gcc_assert (proc_target->result && old_target->result);
- if (!gfc_compare_types (&proc_target->result->ts,
- &old_target->result->ts))
- {
- gfc_error ("'%s' at %L and the overridden FUNCTION should have"
- " matching result types", proc->name, &where);
- return FAILURE;
- }
- }
-
- /* If the overridden binding is PUBLIC, the overriding one must not be
- PRIVATE. */
- if (old->n.tb->access == ACCESS_PUBLIC
- && proc->n.tb->access == ACCESS_PRIVATE)
- {
- gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
- " PRIVATE", proc->name, &where);
- return FAILURE;
- }
-
- /* Compare the formal argument lists of both procedures. This is also abused
- to find the position of the passed-object dummy arguments of both
- bindings as at least the overridden one might not yet be resolved and we
- need those positions in the check below. */
- proc_pass_arg = old_pass_arg = 0;
- if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
- proc_pass_arg = 1;
- if (!old->n.tb->nopass && !old->n.tb->pass_arg)
- old_pass_arg = 1;
- argpos = 1;
- for (proc_formal = proc_target->formal, old_formal = old_target->formal;
- proc_formal && old_formal;
- proc_formal = proc_formal->next, old_formal = old_formal->next)
- {
- if (proc->n.tb->pass_arg
- && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
- proc_pass_arg = argpos;
- if (old->n.tb->pass_arg
- && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
- old_pass_arg = argpos;
-
- /* Check that the names correspond. */
- if (strcmp (proc_formal->sym->name, old_formal->sym->name))
- {
- gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
- " to match the corresponding argument of the overridden"
- " procedure", proc_formal->sym->name, proc->name, &where,
- old_formal->sym->name);
- return FAILURE;
- }
-
- /* Check that the types correspond if neither is the passed-object
- argument. */
- /* FIXME: Do more comprehensive testing here. */
- if (proc_pass_arg != argpos && old_pass_arg != argpos
- && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
- {
- gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
- "in respect to the overridden procedure",
- proc_formal->sym->name, proc->name, &where);
- return FAILURE;
- }
-
- ++argpos;
- }
- if (proc_formal || old_formal)
- {
- gfc_error ("'%s' at %L must have the same number of formal arguments as"
- " the overridden procedure", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is NOPASS, the overriding one must also be
- NOPASS. */
- if (old->n.tb->nopass && !proc->n.tb->nopass)
- {
- gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
- " NOPASS", proc->name, &where);
- return FAILURE;
- }
-
- /* If the overridden binding is PASS(x), the overriding one must also be
- PASS and the passed-object dummy arguments must correspond. */
- if (!old->n.tb->nopass)
- {
- if (proc->n.tb->nopass)
- {
- gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
- " PASS", proc->name, &where);
- return FAILURE;
- }
-
- if (proc_pass_arg != old_pass_arg)
- {
- gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
- " the same position as the passed-object dummy argument of"
- " the overridden procedure", proc->name, &where);
- return FAILURE;
- }
- }
-
- return SUCCESS;
-}
-
-
/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
static gfc_try
overridden = gfc_find_typebound_proc (super_type, NULL,
stree->name, true, NULL);
- if (overridden && overridden->n.tb)
- stree->n.tb->overridden = overridden->n.tb;
+ if (overridden)
+ {
+ if (overridden->n.tb)
+ stree->n.tb->overridden = overridden->n.tb;
- if (overridden && check_typebound_override (stree, overridden) == FAILURE)
- goto error;
+ if (gfc_check_typebound_override (stree, overridden) == FAILURE)
+ goto error;
+ }
}
/* See if there's a name collision with a component directly in this type. */
resolve_typebound_procedures (gfc_symbol* derived)
{
int op;
+ gfc_symbol* super_type;
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
+
+ super_type = gfc_get_derived_super_type (derived);
+ if (super_type)
+ resolve_typebound_procedures (super_type);
resolve_bindings_derived = derived;
resolve_bindings_result = SUCCESS;
}
-/* Resolve the components of a derived type. */
+/* Resolve the components of a derived type. This does not have to wait until
+ resolution stage, but can be done as soon as the dt declaration has been
+ parsed. */
static gfc_try
-resolve_fl_derived (gfc_symbol *sym)
+resolve_fl_derived0 (gfc_symbol *sym)
{
gfc_symbol* super_type;
gfc_component *c;
super_type = gfc_get_derived_super_type (sym);
-
- if (sym->attr.is_class && sym->ts.u.derived == NULL)
- {
- /* Fix up incomplete CLASS symbols. */
- gfc_component *data = gfc_find_component (sym, "_data", true, true);
- gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
- if (vptr->ts.u.derived == NULL)
- {
- gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
- gcc_assert (vtab);
- vptr->ts.u.derived = vtab->ts.u.derived;
- }
- }
/* F2008, C432. */
if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
}
/* Ensure the extended type gets resolved before we do. */
- if (super_type && resolve_fl_derived (super_type) == FAILURE)
+ if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
return FAILURE;
/* An ABSTRACT type must be extensible. */
return FAILURE;
}
- if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
+ if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
+ && !c->ts.deferred)
{
if (c->ts.u.cl->length == NULL
|| (resolve_charlen (c->ts.u.cl) == FAILURE)
}
}
+ if (c->ts.type == BT_CHARACTER && c->ts.deferred
+ && !c->attr.pointer && !c->attr.allocatable)
+ {
+ gfc_error ("Character component '%s' of '%s' at %L with deferred "
+ "length must be a POINTER or ALLOCATABLE",
+ c->name, sym->name, &c->loc);
+ return FAILURE;
+ }
+
if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE
- && gfc_check_access (sym->attr.access, sym->ns->default_access)
+ && gfc_check_symbol_access (sym)
&& !is_sym_host_assoc (c->ts.u.derived, sym->ns)
&& !c->ts.u.derived->attr.use_assoc
- && !gfc_check_access (c->ts.u.derived->attr.access,
- c->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (c->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
"is a PRIVATE type and cannot be a component of "
"'%s', which is PUBLIC at %L", c->name,
return FAILURE;
}
- if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
+ if (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.class_pointer
&& CLASS_DATA (c)->ts.u.derived->components == NULL
&& !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
{
}
/* C437. */
- if (c->ts.type == BT_CLASS
- && !(CLASS_DATA (c)->attr.class_pointer
- || CLASS_DATA (c)->attr.allocatable))
+ if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
+ && (!c->attr.class_ok
+ || !(CLASS_DATA (c)->attr.class_pointer
+ || CLASS_DATA (c)->attr.allocatable)))
{
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
"or pointer", c->name, &c->loc);
return FAILURE;
}
- /* Resolve the type-bound procedures. */
- if (resolve_typebound_procedures (sym) == FAILURE)
- return FAILURE;
-
- /* Resolve the finalizer procedures. */
- if (gfc_resolve_finalizers (sym) == FAILURE)
- return FAILURE;
-
/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
all DEFERRED bindings are overridden. */
if (super_type && super_type->attr.abstract && !sym->attr.abstract
}
+/* The following procedure does the full resolution of a derived type,
+ including resolution of all type-bound procedures (if present). In contrast
+ to 'resolve_fl_derived0' this can only be done after the module has been
+ parsed completely. */
+
+static gfc_try
+resolve_fl_derived (gfc_symbol *sym)
+{
+ if (sym->attr.is_class && sym->ts.u.derived == NULL)
+ {
+ /* Fix up incomplete CLASS symbols. */
+ gfc_component *data = gfc_find_component (sym, "_data", true, true);
+ gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
+ if (vptr->ts.u.derived == NULL)
+ {
+ gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
+ gcc_assert (vtab);
+ vptr->ts.u.derived = vtab->ts.u.derived;
+ }
+ }
+
+ if (resolve_fl_derived0 (sym) == FAILURE)
+ return FAILURE;
+
+ /* Resolve the type-bound procedures. */
+ if (resolve_typebound_procedures (sym) == FAILURE)
+ return FAILURE;
+
+ /* Resolve the finalizer procedures. */
+ if (gfc_resolve_finalizers (sym) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
static gfc_try
resolve_fl_namelist (gfc_symbol *sym)
{
for (nl = sym->namelist; nl; nl = nl->next)
{
- /* Reject namelist arrays of assumed shape. */
+ /* Check again, the check in match only works if NAMELIST comes
+ after the decl. */
+ if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
+ {
+ gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
+ "allowed", nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
- && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
- "must not have assumed shape in namelist "
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ "object '%s' with assumed shape in namelist "
"'%s' at %L", nl->sym->name, sym->name,
&sym->declared_at) == FAILURE)
- return FAILURE;
+ return FAILURE;
- /* Reject namelist arrays that are not constant shape. */
- if (is_non_constant_shape_array (nl->sym))
- {
- gfc_error ("NAMELIST array object '%s' must have constant "
- "shape in namelist '%s' at %L", nl->sym->name,
- sym->name, &sym->declared_at);
- return FAILURE;
- }
+ if (is_non_constant_shape_array (nl->sym)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ "object '%s' with nonconstant shape in namelist "
+ "'%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
- /* Namelist objects cannot have allocatable or pointer components. */
- if (nl->sym->ts.type != BT_DERIVED)
- continue;
+ 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 "
+ "'%s' with nonconstant character length in "
+ "namelist '%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
- if (nl->sym->ts.u.derived->attr.alloc_comp)
+ /* FIXME: Once UDDTIO is implemented, the following can be
+ removed. */
+ if (nl->sym->ts.type == BT_CLASS)
{
- gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
- "have ALLOCATABLE components",
- nl->sym->name, sym->name, &sym->declared_at);
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
+ "polymorphic and requires a defined input/output "
+ "procedure", nl->sym->name, sym->name, &sym->declared_at);
return FAILURE;
}
- if (nl->sym->ts.u.derived->attr.pointer_comp)
+ if (nl->sym->ts.type == BT_DERIVED
+ && (nl->sym->ts.u.derived->attr.alloc_comp
+ || nl->sym->ts.u.derived->attr.pointer_comp))
{
- gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
- "have POINTER components",
- nl->sym->name, sym->name, &sym->declared_at);
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ "'%s' in namelist '%s' at %L with ALLOCATABLE "
+ "or POINTER components", nl->sym->name,
+ sym->name, &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* FIXME: Once UDDTIO is implemented, the following can be
+ removed. */
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
+ "ALLOCATABLE or POINTER components and thus requires "
+ "a defined input/output procedure", nl->sym->name,
+ sym->name, &sym->declared_at);
return FAILURE;
}
}
/* Reject PRIVATE objects in a PUBLIC namelist. */
- if (gfc_check_access(sym->attr.access, sym->ns->default_access))
+ if (gfc_check_symbol_access (sym))
{
for (nl = sym->namelist; nl; nl = nl->next)
{
if (!nl->sym->attr.use_assoc
&& !is_sym_host_assoc (nl->sym, sym->ns)
- && !gfc_check_access(nl->sym->attr.access,
- nl->sym->ns->default_access))
+ && !gfc_check_symbol_access (nl->sym))
{
gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
"cannot be member of PUBLIC namelist '%s' at %L",
/* Types with private components that are defined in the same module. */
if (nl->sym->ts.type == BT_DERIVED
&& !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
- && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
- ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
- nl->sym->ns->default_access))
+ && nl->sym->ts.u.derived->attr.private_comp)
{
gfc_error ("NAMELIST object '%s' has PRIVATE components and "
"cannot be a member of PUBLIC namelist '%s' at %L",
gfc_namespace *ns;
gfc_component *c;
- /* Avoid double resolution of function result symbols. */
- if ((sym->result || sym->attr.result) && !sym->attr.dummy
- && (sym->ns != gfc_current_ns))
- return;
-
if (sym->attr.flavor == FL_UNKNOWN)
{
}
}
}
+ else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
+ gfc_resolve_array_spec (sym->result->as, false);
/* Assumed size arrays and assumed shape arrays must be dummy
arguments. Array-spec's of implied-shape should have been resolved to
return;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
- if (!ds && sym->attr.function
- && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
{
symtree = gfc_new_symtree (&sym->ns->sym_root,
sym->ts.u.derived->name);
if (sym->ts.type == BT_DERIVED
&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ts.u.derived->attr.use_assoc
- && gfc_check_access (sym->attr.access, sym->ns->default_access)
- && !gfc_check_access (sym->ts.u.derived->attr.access,
- sym->ts.u.derived->ns->default_access)
+ && 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 "
"of PRIVATE derived type '%s'",
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
sym->ts.u.derived->name) == FAILURE)
return;
+ /* F2008, C1302. */
+ if (sym->ts.type == BT_DERIVED
+ && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+ || sym->ts.u.derived->attr.lock_comp)
+ && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
+ {
+ gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
+ "type LOCK_TYPE must be a coarray", sym->name,
+ &sym->declared_at);
+ return;
+ }
+
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
}
}
- /* F2008, C526. */
+ /* F2008, C542. */
+ if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
+ {
+ gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
+ "INTENT(OUT)", sym->name, &sym->declared_at);
+ return;
+ }
+
+ /* F2008, C525. */
if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| sym->attr.codimension)
- && sym->attr.result)
- gfc_error ("Function result '%s' at %L shall not be a coarray or have "
- "a coarray component", sym->name, &sym->declared_at);
+ && (sym->attr.result || sym->result == sym))
+ {
+ gfc_error ("Function result '%s' at %L shall not be a coarray or have "
+ "a coarray component", sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C524. */
if (sym->attr.codimension && sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->ts.is_iso_c)
- gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
- "shall not be a coarray", sym->name, &sym->declared_at);
+ {
+ gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+ "shall not be a coarray", sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C525. */
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
&& (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
|| sym->attr.allocatable))
- gfc_error ("Variable '%s' at %L with coarray component "
- "shall be a nonpointer, nonallocatable scalar",
- sym->name, &sym->declared_at);
+ {
+ gfc_error ("Variable '%s' at %L with coarray component "
+ "shall be a nonpointer, nonallocatable scalar",
+ sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C526. The function-result case was handled above. */
- if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
- || sym->attr.codimension)
+ if (sym->attr.codimension
&& !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+ || sym->ns->save_all
|| sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program
|| sym->attr.function || sym->attr.result || sym->attr.use_assoc))
- gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
- "component and is not ALLOCATABLE, SAVE nor a "
- "dummy argument", sym->name, &sym->declared_at);
+ {
+ gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
+ "nor a dummy argument", sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
else if (sym->attr.codimension && !sym->attr.allocatable
&& sym->as && sym->as->cotype == AS_DEFERRED)
- gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
- "deferred shape", sym->name, &sym->declared_at);
+ {
+ gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
+ "deferred shape", sym->name, &sym->declared_at);
+ return;
+ }
else if (sym->attr.codimension && sym->attr.allocatable
&& (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
- gfc_error ("Allocatable coarray variable '%s' at %L must have "
- "deferred shape", sym->name, &sym->declared_at);
-
+ {
+ gfc_error ("Allocatable coarray variable '%s' at %L must have "
+ "deferred shape", sym->name, &sym->declared_at);
+ return;
+ }
/* F2008, C541. */
if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| (sym->attr.codimension && sym->attr.allocatable))
&& sym->attr.dummy && sym->attr.intent == INTENT_OUT)
- gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
- "allocatable coarray or have coarray components",
- sym->name, &sym->declared_at);
+ {
+ gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
+ "allocatable coarray or have coarray components",
+ sym->name, &sym->declared_at);
+ return;
+ }
if (sym->attr.codimension && sym->attr.dummy
&& sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
- gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
- "procedure '%s'", sym->name, &sym->declared_at,
- sym->ns->proc_name->name);
+ {
+ gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
+ "procedure '%s'", sym->name, &sym->declared_at,
+ sym->ns->proc_name->name);
+ return;
+ }
switch (sym->attr.flavor)
{
has_pointer = sym->attr.pointer;
+ if (gfc_is_coindexed (e))
+ {
+ gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
+ where);
+ return FAILURE;
+ }
+
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1;
- if (ref->type == REF_ARRAY && ref->u.ar.codimen)
- {
- gfc_error ("DATA element '%s' at %L cannot have a coindex",
- sym->name, where);
- return FAILURE;
- }
-
if (has_pointer
&& ref->type == REF_ARRAY
&& ref->u.ar.type != AR_FULL)
mpz_set_ui (size, 0);
}
- t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
- offset, range);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr,
+ offset, &range);
mpz_add (offset, offset, range);
mpz_clear (range);
mpz_sub_ui (values.left, values.left, 1);
mpz_sub_ui (size, size, 1);
- t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr,
+ offset, NULL);
if (t == FAILURE)
break;
e->ts.u.cl = NULL;
}
ref = ref->next;
- gfc_free (mem);
+ free (mem);
}
/* Any further ref is an error. */
if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
&& !sym->attr.contained
- && !gfc_check_access (sym->ts.u.derived->attr.access,
- sym->ts.u.derived->ns->default_access)
- && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ && !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 "
"%L of PRIVATE type '%s'", sym->name,
resolve_contained_functions (ns);
+ if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
+ && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ resolve_formal_arglist (ns->proc_name);
+
gfc_traverse_ns (ns, resolve_bind_c_derived_types);
for (cl = ns->cl_list; cl; cl = cl->next)
}
forall_flag = 0;
+ do_concurrent_flag = 0;
gfc_check_interfaces (ns);
gfc_traverse_ns (ns, resolve_values);
OSDN Git Service
