gfc_symbol *sym;
int i;
- /* TODO: Procedures whose return character length parameter is not constant
- or assumed must also have explicit interfaces. */
if (proc->result != NULL)
sym = proc->result;
else
{
gfc_error
("Character-valued argument '%s' of statement function at "
- "%L must has constant length",
+ "%L must have constant length",
sym->name, &sym->declared_at);
continue;
}
return 1;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
- || a.optional || a.pointer || a.save || a.target
+ || a.optional || a.pointer || a.save || a.target || a.volatile_
|| a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1;
{
gfc_error ("The upper bound in the last dimension must "
"appear in the reference to the assumed size "
- "array '%s' at %L.", sym->name, &e->where);
+ "array '%s' at %L", sym->name, &e->where);
return true;
}
return false;
function allowed as actual argument in F2003 and not allowed
in F95. */
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CHAR intrinsic "
- "allowed as actual argument at %L", &e->where);
+ "as actual argument at %L", &e->where);
if (sym->attr.contained && !sym->attr.use_assoc
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
&& expr->value.function.isym->generic_id != GFC_ISYM_LOC
&& expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
{
- /* Array instrinsics must also have the last upper bound of an
+ /* Array intrinsics must also have the last upper bound of an
assumed size array argument. UBOUND and SIZE have to be
excluded from the check if the second argument is anything
than a constant. */
break;
case REF_COMPONENT:
- if ((current_part_dimension || seen_part_dimension)
- && ref->u.c.component->pointer)
+ if (current_part_dimension || seen_part_dimension)
{
- gfc_error
- ("Component to the right of a part reference with nonzero "
- "rank must not have the POINTER attribute at %L",
- &expr->where);
- return FAILURE;
+ if (ref->u.c.component->pointer)
+ {
+ gfc_error
+ ("Component to the right of a part reference with nonzero "
+ "rank must not have the POINTER attribute at %L",
+ &expr->where);
+ return FAILURE;
+ }
+ else if (ref->u.c.component->allocatable)
+ {
+ gfc_error
+ ("Component to the right of a part reference with nonzero "
+ "rank must not have the ALLOCATABLE attribute at %L",
+ &expr->where);
+ return FAILURE;
+ }
}
n_components++;
else
{
/* Must be a simple variable reference. */
- if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
+ if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
return FAILURE;
e->ts = sym->ts;
}
{
init_st = gfc_get_code ();
init_st->loc = code->loc;
- init_st->op = EXEC_ASSIGN;
+ init_st->op = EXEC_INIT_ASSIGN;
init_st->expr = expr_to_initialize (e);
init_st->expr2 = init_e;
init_st->next = code->next;
if (t == SUCCESS && b->expr != NULL
&& (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
gfc_error
- ("ELSE IF clause at %L requires a scalar LOGICAL expression",
+ ("IF clause at %L requires a scalar LOGICAL expression",
&b->expr->where);
break;
"INTEGER return specifier", &code->expr->where);
break;
+ case EXEC_INIT_ASSIGN:
+ break;
+
case EXEC_ASSIGN:
if (t == FAILURE)
break;
return not_constant;
}
+
+/* Assign the default initializer to a derived type variable or result. */
+
+static void
+apply_default_init (gfc_symbol *sym)
+{
+ gfc_expr *lval;
+ gfc_expr *init = NULL;
+ gfc_code *init_st;
+ gfc_namespace *ns = sym->ns;
+
+ if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
+ return;
+
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived)
+ init = gfc_default_initializer (&sym->ts);
+
+ if (init == NULL)
+ return;
+
+ /* Search for the function namespace if this is a contained
+ function without an explicit result. */
+ if (sym->attr.function && sym == sym->result
+ && sym->name != sym->ns->proc_name->name)
+ {
+ ns = ns->contained;
+ for (;ns; ns = ns->sibling)
+ if (strcmp (ns->proc_name->name, sym->name) == 0)
+ break;
+ }
+
+ if (ns == NULL)
+ {
+ gfc_free_expr (init);
+ return;
+ }
+
+ /* Build an l-value expression for the result. */
+ lval = gfc_get_expr ();
+ lval->expr_type = EXPR_VARIABLE;
+ lval->where = sym->declared_at;
+ lval->ts = sym->ts;
+ lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+
+ /* It will always be a full array. */
+ lval->rank = sym->as ? sym->as->rank : 0;
+ if (lval->rank)
+ {
+ lval->ref = gfc_get_ref ();
+ lval->ref->type = REF_ARRAY;
+ lval->ref->u.ar.type = AR_FULL;
+ lval->ref->u.ar.dimen = lval->rank;
+ lval->ref->u.ar.where = sym->declared_at;
+ lval->ref->u.ar.as = sym->as;
+ }
+
+ /* Add the code at scope entry. */
+ init_st = gfc_get_code ();
+ init_st->next = ns->code;
+ ns->code = init_st;
+
+ /* Assign the default initializer to the l-value. */
+ init_st->loc = sym->declared_at;
+ init_st->op = EXEC_INIT_ASSIGN;
+ init_st->expr = lval;
+ init_st->expr2 = init;
+}
+
+
/* Resolution of common features of flavors variable and procedure. */
static try
}
/* Assign default initializer. */
- if (sym->ts.type == BT_DERIVED && !sym->value && !sym->attr.pointer
- && !sym->attr.allocatable && (!flag || sym->attr.intent == INTENT_OUT))
+ if (sym->ts.type == BT_DERIVED
+ && !sym->value
+ && !sym->attr.pointer
+ && !sym->attr.allocatable
+ && (!flag || sym->attr.intent == INTENT_OUT))
sym->value = gfc_default_initializer (&sym->ts);
return SUCCESS;
&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
- if (sym->attr.proc == PROC_ST_FUNCTION)
+ if (sym->ts.type == BT_CHARACTER)
{
- if (sym->ts.type == BT_CHARACTER)
- {
- gfc_charlen *cl = sym->ts.cl;
- if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
- {
+ gfc_charlen *cl = sym->ts.cl;
+ if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ {
+ if (sym->attr.proc == PROC_ST_FUNCTION)
+ {
gfc_error ("Character-valued statement function '%s' at %L must "
"have constant length", sym->name, &sym->declared_at);
return FAILURE;
}
+
+ if (sym->attr.external && sym->formal == NULL
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Automatic character length function '%s' at %L must "
+ "have an explicit interface", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
}
}
|| !gfc_is_constant_expr (c->ts.cl->length))
{
gfc_error ("Character length of component '%s' needs to "
- "be a constant specification expression at %L.",
+ "be a constant specification expression at %L",
c->name,
c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
return FAILURE;
|| !gfc_is_constant_expr (c->as->upper[i]))
{
gfc_error ("Component '%s' of '%s' at %L must have "
- "constant array bounds.",
+ "constant array bounds",
c->name, sym->name, &c->loc);
return FAILURE;
}
&& sym->ts.derived->components == NULL)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
- "which has not been defined.", sym->name,
+ "which has not been defined", sym->name,
&sym->declared_at, sym->ts.derived->name);
sym->ts.type = BT_UNKNOWN;
return;
case FL_PARAMETER:
if (resolve_fl_parameter (sym) == FAILURE)
return;
-
break;
default:
-
break;
}
/* Make sure that intrinsic exist */
- if (sym->attr.intrinsic
+ if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0)
&& ! gfc_intrinsic_name(sym->name, 1))
gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
&& (sym->ns->proc_name == NULL
|| sym->ns->proc_name->attr.flavor != FL_MODULE)))
gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
+
+ /* If we have come this far we can apply default-initializers, as
+ described in 14.7.5, to those variables that have not already
+ been assigned one. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->attr.referenced
+ && sym->ns == gfc_current_ns
+ && !sym->value
+ && !sym->attr.allocatable
+ && !sym->attr.alloc_comp)
+ {
+ symbol_attribute *a = &sym->attr;
+
+ if ((!a->save && !a->dummy && !a->pointer
+ && !a->in_common && !a->use_assoc
+ && !(a->function && sym != sym->result))
+ ||
+ (a->dummy && a->intent == INTENT_OUT))
+ apply_default_init (sym);
+ }
}
{
if (value_name != NULL)
{
- gfc_error ("Initialized objects '%s' and '%s' cannot both "
+ gfc_error ("Initialized objects '%s' and '%s' cannot both "
"be in the EQUIVALENCE statement at %L",
value_name, sym->name, &e->where);
continue;
resolve_equivalence (eq);
/* Warn about unused labels. */
- if (gfc_option.warn_unused_labels)
+ if (warn_unused_label)
warn_unused_fortran_label (ns->st_labels);
gfc_resolve_uops (ns->uop_root);
OSDN Git Service
