static code_stack *cs_base = NULL;
-/* Nonzero if we're inside a FORALL block */
+/* Nonzero if we're inside a FORALL block. */
static int forall_flag;
+/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
+
+static int omp_workshare_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;
gfc_namespace *child;
gfc_entry_list *el;
+ resolve_entries (ns);
+
resolve_formal_arglists (ns);
for (child = ns->contained; child; child = child->sibling)
|| sym->attr.external)
{
- if (sym->attr.proc == PROC_ST_FUNCTION)
- {
- gfc_error ("Statement function '%s' at %L is not allowed as an "
- "actual argument", sym->name, &e->where);
- }
+ if (sym->attr.proc == PROC_ST_FUNCTION)
+ {
+ gfc_error ("Statement function '%s' at %L is not allowed as an "
+ "actual argument", sym->name, &e->where);
+ }
+
+ if (sym->attr.contained && !sym->attr.use_assoc
+ && sym->ns->proc_name->attr.flavor != FL_MODULE)
+ {
+ gfc_error ("Internal procedure '%s' is not allowed as an "
+ "actual argument at %L", sym->name, &e->where);
+ }
+
+ if (sym->attr.elemental && !sym->attr.intrinsic)
+ {
+ gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
+ "allowed as an actual argument at %L", sym->name,
+ &e->where);
+ }
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
ap->expr->inline_noncopying_intrinsic = 1;
}
+/* This function does the checking of references to global procedures
+ as defined in sections 18.1 and 14.1, respectively, of the Fortran
+ 77 and 95 standards. It checks for a gsymbol for the name, making
+ one if it does not already exist. If it already exists, then the
+ reference being resolved must correspond to the type of gsymbol.
+ Otherwise, the new symbol is equipped with the attributes of the
+ reference. The corresponding code that is called in creating
+ global entities is parse.c. */
+
+static void
+resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
+{
+ gfc_gsymbol * gsym;
+ unsigned int type;
+
+ type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+
+ gsym = gfc_get_gsymbol (sym->name);
+
+ if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
+ global_used (gsym, where);
+
+ if (gsym->type == GSYM_UNKNOWN)
+ {
+ gsym->type = type;
+ gsym->where = *where;
+ }
+
+ gsym->used = 1;
+}
/************* Function resolution *************/
resolve_function (gfc_expr * expr)
{
gfc_actual_arglist *arg;
+ gfc_symbol * sym;
const char *name;
try t;
int temp;
+ sym = NULL;
+ if (expr->symtree)
+ sym = expr->symtree->n.sym;
+
+ /* If the procedure is not internal, a statement function or a module
+ procedure,it must be external and should be checked for usage. */
+ if (sym && !sym->attr.dummy && !sym->attr.contained
+ && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.use_assoc)
+ resolve_global_procedure (sym, &expr->where, 0);
+
/* Switch off assumed size checking and do this again for certain kinds
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
/* Resume assumed_size checking. */
need_full_assumed_size--;
+ if (sym && sym->ts.type == BT_CHARACTER
+ && sym->ts.cl && sym->ts.cl->length == NULL)
+ {
+ if (sym->attr.if_source == IFSRC_IFBODY)
+ {
+ /* This follows from a slightly odd requirement at 5.1.1.5 in the
+ standard that allows assumed character length functions to be
+ declared in interfaces but not used. Picking up the symbol here,
+ rather than resolve_symbol, accomplishes that. */
+ gfc_error ("Function '%s' can be declared in an interface to "
+ "return CHARACTER(*) but cannot be used at %L",
+ sym->name, &expr->where);
+ return FAILURE;
+ }
+
+ /* Internal procedures are taken care of in resolve_contained_fntype. */
+ if (!sym->attr.dummy && !sym->attr.contained)
+ {
+ gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
+ "be used at %L since it is not a dummy argument",
+ sym->name, &expr->where);
+ return FAILURE;
+ }
+ }
+
/* See if function is already resolved. */
if (expr->value.function.name != NULL)
{
if (expr->ts.type == BT_UNKNOWN)
- expr->ts = expr->symtree->n.sym->ts;
+ expr->ts = sym->ts;
t = SUCCESS;
}
else
{
/* Apply the rules of section 14.1.2. */
- switch (procedure_kind (expr->symtree->n.sym))
+ switch (procedure_kind (sym))
{
case PTYPE_GENERIC:
t = resolve_generic_f (expr);
return FAILURE;
}
}
+ if (omp_workshare_flag
+ && expr->value.function.esym
+ && ! gfc_elemental (expr->value.function.esym))
+ {
+ gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
+ " in WORKSHARE construct", expr->value.function.esym->name,
+ &expr->where);
+ t = FAILURE;
+ }
else if (expr->value.function.actual != NULL
- && expr->value.function.isym != NULL
- && strcmp (expr->value.function.isym->name, "lbound"))
+ && expr->value.function.isym != NULL
+ && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
+ && 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
asumed size array argument. UBOUND and SIZE have to be
excluded from the check if the second argument is anything
than a constant. */
int inquiry;
- inquiry = strcmp (expr->value.function.isym->name, "ubound") == 0
- || strcmp (expr->value.function.isym->name, "size") == 0;
+ inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
+ || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
for (arg = expr->value.function.actual; arg; arg = arg->next)
{
{
try t;
+ if (c->symtree && c->symtree->n.sym
+ && c->symtree->n.sym->ts.type != BT_UNKNOWN)
+ {
+ gfc_error ("'%s' at %L has a type, which is not consistent with "
+ "the CALL at %L", c->symtree->n.sym->name,
+ &c->symtree->n.sym->declared_at, &c->loc);
+ return FAILURE;
+ }
+
+ /* If the procedure is not internal or module, it must be external and
+ should be checked for usage. */
+ if (c->symtree && c->symtree->n.sym
+ && !c->symtree->n.sym->attr.dummy
+ && !c->symtree->n.sym->attr.contained
+ && !c->symtree->n.sym->attr.use_assoc)
+ resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
+
/* Switch off assumed size checking and do this again for certain kinds
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
return FAILURE;
break;
goto bad_op;
+ case INTRINSIC_PARENTHESES:
+ break;
+
default:
gfc_internal_error ("resolve_operator(): Bad intrinsic");
}
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
e->rank = op1->rank;
if (e->shape == NULL)
if (index->ts.kind != gfc_index_integer_kind
|| index->ts.type != BT_INTEGER)
{
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
if (found == NULL)
{
- /* still nothing, so illegal. */
- gfc_error_now ("Label at %L is not in the same block as the "
- "GOTO statement at %L", &lp->where, &code->loc);
+ /* The label is not in an enclosing block, so illegal. This was
+ allowed in Fortran 66, so we allow it as extension. We also
+ forego further checks if we run into this. */
+ gfc_notify_std (GFC_STD_LEGACY,
+ "Label at %L is not in the same block as the "
+ "GOTO statement at %L", &lp->where, &code->loc);
return;
}
gfc_resolve_assign_in_forall (c, nvar, var_expr);
break;
- /* Because the resolve_blocks() will handle the nested FORALL,
+ /* Because the gfc_resolve_blocks() will handle the nested FORALL,
there is no need to handle it here. */
case EXEC_FORALL:
break;
/* Given a FORALL construct, first resolve the FORALL iterator, then call
gfc_resolve_forall_body to resolve the FORALL body. */
-static void resolve_blocks (gfc_code *, gfc_namespace *);
-
static void
gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
{
gfc_resolve_forall_body (code, nvar, var_expr);
/* May call gfc_resolve_forall to resolve the inner FORALL loop. */
- resolve_blocks (code->block, ns);
+ gfc_resolve_blocks (code->block, ns);
/* Free VAR_EXPR after the whole FORALL construct resolved. */
for (i = 0; i < total_var; i++)
static void resolve_code (gfc_code *, gfc_namespace *);
-static void
-resolve_blocks (gfc_code * b, gfc_namespace * ns)
+void
+gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
{
try t;
case EXEC_IOLENGTH:
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ break;
+
default:
gfc_internal_error ("resolve_block(): Bad block type");
}
static void
resolve_code (gfc_code * code, gfc_namespace * ns)
{
- int forall_save = 0;
+ int omp_workshare_save;
code_stack frame;
gfc_alloc *a;
try t;
if (code->op == EXEC_FORALL)
{
- forall_save = forall_flag;
+ int forall_save = forall_flag;
+
forall_flag = 1;
- gfc_resolve_forall (code, ns, forall_save);
- }
- else
- resolve_blocks (code->block, ns);
+ gfc_resolve_forall (code, ns, forall_save);
+ forall_flag = forall_save;
+ }
+ else if (code->block)
+ {
+ omp_workshare_save = -1;
+ switch (code->op)
+ {
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ omp_workshare_save = omp_workshare_flag;
+ omp_workshare_flag = 1;
+ gfc_resolve_omp_parallel_blocks (code, ns);
+ break;
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ omp_workshare_save = omp_workshare_flag;
+ omp_workshare_flag = 0;
+ gfc_resolve_omp_parallel_blocks (code, ns);
+ break;
+ case EXEC_OMP_DO:
+ gfc_resolve_omp_do_blocks (code, ns);
+ break;
+ case EXEC_OMP_WORKSHARE:
+ omp_workshare_save = omp_workshare_flag;
+ omp_workshare_flag = 1;
+ /* FALLTHROUGH */
+ default:
+ gfc_resolve_blocks (code->block, ns);
+ break;
+ }
- if (code->op == EXEC_FORALL)
- forall_flag = forall_save;
+ if (omp_workshare_save != -1)
+ omp_workshare_flag = omp_workshare_save;
+ }
t = gfc_resolve_expr (code->expr);
if (gfc_resolve_expr (code->expr2) == FAILURE)
break;
if (gfc_extend_assign (code, ns) == SUCCESS)
- goto call;
+ {
+ if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
+ {
+ gfc_error ("Subroutine '%s' called instead of assignment at "
+ "%L must be PURE", code->symtree->n.sym->name,
+ &code->loc);
+ break;
+ }
+ goto call;
+ }
if (gfc_pure (NULL))
{
case EXEC_DO:
if (code->ext.iterator != NULL)
- gfc_resolve_iterator (code->ext.iterator, true);
+ {
+ gfc_iterator *iter = code->ext.iterator;
+ if (gfc_resolve_iterator (iter, true) != FAILURE)
+ gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
+ }
break;
case EXEC_DO_WHILE:
&code->expr->where);
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_FLUSH:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ gfc_resolve_omp_directive (code, ns);
+ break;
+
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ omp_workshare_save = omp_workshare_flag;
+ omp_workshare_flag = 0;
+ gfc_resolve_omp_directive (code, ns);
+ omp_workshare_flag = omp_workshare_save;
+ break;
+
default:
gfc_internal_error ("resolve_code(): Bad statement code");
}
}
+/* Resolve an index expression. */
+
+static try
+resolve_index_expr (gfc_expr * e)
+{
+
+ if (gfc_resolve_expr (e) == FAILURE)
+ return FAILURE;
+
+ if (gfc_simplify_expr (e, 0) == FAILURE)
+ return FAILURE;
+
+ if (gfc_specification_expr (e) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
/* Resolve a charlen structure. */
static try
cl->resolved = 1;
- if (gfc_resolve_expr (cl->length) == FAILURE)
+ if (resolve_index_expr (cl->length) == FAILURE)
return FAILURE;
- if (gfc_simplify_expr (cl->length, 0) == FAILURE)
+ return SUCCESS;
+}
+
+
+/* Test for non-constant shape arrays. */
+
+static bool
+is_non_constant_shape_array (gfc_symbol *sym)
+{
+ gfc_expr *e;
+ int i;
+
+ if (sym->as != NULL)
+ {
+ /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
+ has not been simplified; parameter array references. Do the
+ simplification now. */
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ e = sym->as->lower[i];
+ if (e && (resolve_index_expr (e) == FAILURE
+ || !gfc_is_constant_expr (e)))
+ return true;
+
+ e = sym->as->upper[i];
+ if (e && (resolve_index_expr (e) == FAILURE
+ || !gfc_is_constant_expr (e)))
+ return true;
+ }
+ }
+ return false;
+}
+
+/* Resolution of common features of flavors variable and procedure. */
+
+static try
+resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
+{
+ /* Constraints on deferred shape variable. */
+ if (sym->as == NULL || sym->as->type != AS_DEFERRED)
+ {
+ if (sym->attr.allocatable)
+ {
+ if (sym->attr.dimension)
+ gfc_error ("Allocatable array '%s' at %L must have "
+ "a deferred shape", sym->name, &sym->declared_at);
+ else
+ gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (sym->attr.pointer && sym->attr.dimension)
+ {
+ gfc_error ("Array pointer '%s' at %L must have a deferred shape",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ }
+ else
+ {
+ if (!mp_flag && !sym->attr.allocatable
+ && !sym->attr.pointer && !sym->attr.dummy)
+ {
+ gfc_error ("Array '%s' at %L cannot have a deferred shape",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ }
+ return SUCCESS;
+}
+
+/* Resolve symbols with flavor variable. */
+
+static try
+resolve_fl_variable (gfc_symbol *sym, int mp_flag)
+{
+ int flag;
+ int i;
+ gfc_expr *e;
+ gfc_expr *constructor_expr;
+
+ if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
- if (gfc_specification_expr (cl->length) == FAILURE)
+ /* The shape of a main program or module array needs to be constant. */
+ if (sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc
+ && !sym->attr.allocatable
+ && !sym->attr.pointer
+ && is_non_constant_shape_array (sym))
+ {
+ gfc_error ("The module or main program array '%s' at %L must "
+ "have constant shape", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Make sure that character string variables with assumed length are
+ dummy arguments. */
+ e = sym->ts.cl->length;
+ if (e == NULL && !sym->attr.dummy && !sym->attr.result)
+ {
+ gfc_error ("Entity with assumed character length at %L must be a "
+ "dummy argument or a PARAMETER", &sym->declared_at);
+ return FAILURE;
+ }
+
+ 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;
+ }
+ }
+
+ /* 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. */
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ if (sym->as->lower[i] == NULL
+ || sym->as->lower[i]->expr_type != EXPR_CONSTANT
+ || sym->as->upper[i] == NULL
+ || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
+ {
+ flag = 1;
+ break;
+ }
+ }
+ }
+
+ /* Reject illegal initializers. */
+ if (sym->value && flag)
+ {
+ 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 FAILURE;
+ }
+
+ /* 4th constraint in section 11.3: "If an object of a type for which
+ component-initialization is specified (R429) appears in the
+ specification-part of a module and does not have the ALLOCATABLE
+ or POINTER attribute, the object shall have the SAVE attribute." */
+
+ constructor_expr = NULL;
+ if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
+ constructor_expr = gfc_default_initializer (&sym->ts);
+
+ if (sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && constructor_expr
+ && !sym->ns->save_all && !sym->attr.save
+ && !sym->attr.pointer && !sym->attr.allocatable)
+ {
+ gfc_error("Object '%s' at %L must have the SAVE attribute %s",
+ sym->name, &sym->declared_at,
+ "for default initialization of a component");
+ return FAILURE;
+ }
+
+ /* Assign default initializer. */
+ if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
+ && !sym->attr.pointer)
+ sym->value = gfc_default_initializer (&sym->ts);
+
+ return SUCCESS;
+}
+
+
+/* Resolve a procedure. */
+
+static try
+resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
+{
+ gfc_formal_arglist *arg;
+
+ if (sym->attr.function
+ && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
+ if (sym->attr.proc == PROC_ST_FUNCTION)
+ {
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_charlen *cl = sym->ts.cl;
+ if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Character-valued statement function '%s' at %L must "
+ "have constant length", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ }
+ }
+
+ /* Ensure that derived type formal arguments of a public procedure
+ are not of a private type. */
+ if (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 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);
+ /* Stop this message from recurring. */
+ arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ return FAILURE;
+ }
+ }
+ }
+
+ /* An external symbol may not have an intializer because it is taken to be
+ a procedure. */
+ if (sym->attr.external && sym->value)
+ {
+ gfc_error ("External object '%s' at %L may not have an initializer",
+ 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
+ following ways: (i) Dummy arg of procedure - dummy associates with
+ actual length; (ii) To declare a named constant; or (iii) External
+ function - but length must be declared in calling scoping unit. */
+ if (sym->attr.function
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.cl && sym->ts.cl->length == NULL)
+ {
+ if ((sym->as && sym->as->rank) || (sym->attr.pointer)
+ || (sym->attr.recursive) || (sym->attr.pure))
+ {
+ if (sym->as && sym->as->rank)
+ gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+ "array-valued", sym->name, &sym->declared_at);
+
+ if (sym->attr.pointer)
+ gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+ "pointer-valued", sym->name, &sym->declared_at);
+
+ if (sym->attr.pure)
+ gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+ "pure", sym->name, &sym->declared_at);
+
+ if (sym->attr.recursive)
+ gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+ "recursive", sym->name, &sym->declared_at);
+
+ return FAILURE;
+ }
+
+ /* 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)
+ gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
+ "'%s' at %L is obsolescent in fortran 95",
+ sym->name, &sym->declared_at);
+ }
return SUCCESS;
}
/* Resolve the components of a derived type. */
static try
-resolve_derived (gfc_symbol *sym)
+resolve_fl_derived (gfc_symbol *sym)
{
gfc_component *c;
+ gfc_dt_list * dt_list;
+ int i;
for (c = sym->components; c != NULL; c = c->next)
{
if (c->ts.type == BT_CHARACTER)
{
- if (resolve_charlen (c->ts.cl) == FAILURE)
- return FAILURE;
-
if (c->ts.cl->length == NULL
+ || (resolve_charlen (c->ts.cl) == FAILURE)
|| !gfc_is_constant_expr (c->ts.cl->length))
{
gfc_error ("Character length of component '%s' needs to "
}
}
- /* TODO: Anything else that should be done here? */
+ if (c->ts.type == BT_DERIVED
+ && sym->component_access != ACCESS_PRIVATE
+ && gfc_check_access(sym->attr.access, sym->ns->default_access)
+ && !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 FAILURE;
+ }
+
+ if (c->pointer || c->as == NULL)
+ continue;
+
+ for (i = 0; i < c->as->rank; i++)
+ {
+ if (c->as->lower[i] == NULL
+ || !gfc_is_constant_expr (c->as->lower[i])
+ || (resolve_index_expr (c->as->lower[i]) == FAILURE)
+ || c->as->upper[i] == NULL
+ || (resolve_index_expr (c->as->upper[i]) == FAILURE)
+ || !gfc_is_constant_expr (c->as->upper[i]))
+ {
+ gfc_error ("Component '%s' of '%s' at %L must have "
+ "constant array bounds.",
+ c->name, sym->name, &c->loc);
+ return FAILURE;
+ }
+ }
}
+
+ /* Add derived type to the derived type list. */
+ dt_list = gfc_get_dt_list ();
+ dt_list->next = sym->ns->derived_types;
+ dt_list->derived = sym;
+ sym->ns->derived_types = dt_list;
return SUCCESS;
}
+
+static try
+resolve_fl_namelist (gfc_symbol *sym)
+{
+ gfc_namelist *nl;
+ gfc_symbol *nlsym;
+
+ /* Reject PRIVATE objects in a PUBLIC namelist. */
+ if (gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ 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,
+ &sym->declared_at);
+ return FAILURE;
+ }
+ }
+ }
+
+ /* Reject namelist arrays that are not constant shape. */
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ if (is_non_constant_shape_array (nl->sym))
+ {
+ gfc_error ("The array '%s' must have constant shape to be "
+ "a NAMELIST object at %L", nl->sym->name,
+ &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
+ /* 14.1.2 A module or internal procedure represent local entities
+ of the same type as a namelist member and so are not allowed.
+ Note that this is sometimes caught by check_conflict so the
+ same message has been used. */
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ nlsym = NULL;
+ if (sym->ns->parent && nl->sym && nl->sym->name)
+ gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
+ if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
+ "attribute in '%s' at %L", nlsym->name,
+ &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
+
+
+static try
+resolve_fl_parameter (gfc_symbol *sym)
+{
+ /* A parameter array's shape needs to be constant. */
+ if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
+ {
+ gfc_error ("Parameter array '%s' at %L cannot be automatic "
+ "or assumed shape", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* Make sure a parameter that has been implicitly typed still
+ matches the implicit type, since PARAMETER statements can precede
+ IMPLICIT statements. */
+ if (sym->attr.implicit_type
+ && !gfc_compare_types (&sym->ts,
+ gfc_get_default_type (sym, sym->ns)))
+ {
+ gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
+ "later IMPLICIT type", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* Make sure the types of derived parameters are consistent. This
+ type checking is deferred until resolution because the type may
+ refer to a derived type from the host. */
+ if (sym->ts.type == BT_DERIVED
+ && !gfc_compare_types (&sym->ts, &sym->value->ts))
+ {
+ gfc_error ("Incompatible derived type in PARAMETER at %L",
+ &sym->value->where);
+ return FAILURE;
+ }
+ return SUCCESS;
+}
+
+
/* Do anything necessary to resolve a symbol. Right now, we just
assume that an otherwise unknown symbol is a variable. This sort
of thing commonly happens for symbols in module. */
/* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1;
int formal_ns_save, check_constant, mp_flag;
- int i, flag;
- gfc_namelist *nl;
- gfc_symtree * symtree;
- gfc_symtree * this_symtree;
- gfc_namespace * ns;
- gfc_component * c;
- gfc_formal_arglist * arg;
+ gfc_symtree *symtree;
+ gfc_symtree *this_symtree;
+ gfc_namespace *ns;
+ gfc_component *c;
if (sym->attr.flavor == FL_UNKNOWN)
{
}
}
- if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE)
+ if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
/* Symbols that are module procedures with results (functions) have
return;
}
- /* A parameter array's shape needs to be constant. */
-
- if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
- && !gfc_is_compile_time_shape (sym->as))
- {
- gfc_error ("Parameter array '%s' at %L cannot be automatic "
- "or assumed shape", sym->name, &sym->declared_at);
- 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 (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
- && sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
- {
- gfc_error ("Entity with assumed character length at %L must be a "
- "dummy argument or a PARAMETER", &sym->declared_at);
- return;
- }
-
- /* Make sure a parameter that has been implicitly typed still
- matches the implicit type, since PARAMETER statements can precede
- IMPLICIT statements. */
-
- if (sym->attr.flavor == FL_PARAMETER
- && sym->attr.implicit_type
- && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
- gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
- "later IMPLICIT type", sym->name, &sym->declared_at);
-
- /* Make sure the types of derived parameters are consistent. This
- type checking is deferred until resolution because the type may
- refer to a derived type from the host. */
-
- if (sym->attr.flavor == FL_PARAMETER
- && sym->ts.type == BT_DERIVED
- && !gfc_compare_types (&sym->ts, &sym->value->ts))
- gfc_error ("Incompatible derived type in PARAMETER at %L",
- &sym->value->where);
-
/* Make sure symbols with known intent or optional are really dummy
variable. Because of ENTRY statement, this has to be deferred
until resolution time. */
- if (! sym->attr.dummy
+ if (!sym->attr.dummy
&& (sym->attr.optional
|| sym->attr.intent != INTENT_UNKNOWN))
{
return;
}
- if (sym->attr.proc == PROC_ST_FUNCTION)
- {
- if (sym->ts.type == BT_CHARACTER)
- {
- gfc_charlen *cl = sym->ts.cl;
- if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Character-valued statement function '%s' at %L must "
- "have constant length", sym->name, &sym->declared_at);
- return;
- }
- }
- }
-
/* 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
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
}
}
-
- /* 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
- && sym->attr.function))
- {
- if (sym->as == NULL || sym->as->type != AS_DEFERRED)
- {
- if (sym->attr.allocatable)
- {
- if (sym->attr.dimension)
- gfc_error ("Allocatable array '%s' at %L must have "
- "a deferred shape", sym->name, &sym->declared_at);
- else
- 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 ("Array pointer '%s' at %L must have a deferred shape",
- sym->name, &sym->declared_at);
- return;
- }
-
- }
- else
- {
- if (!mp_flag && !sym->attr.allocatable
- && !sym->attr.pointer && !sym->attr.dummy)
- {
- 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 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. */
- for (i = 0; i < sym->as->rank; i++)
- {
- if (sym->as->lower[i] == NULL
- || sym->as->lower[i]->expr_type != EXPR_CONSTANT
- || sym->as->upper[i] == NULL
- || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
- {
- flag = 1;
- break;
- }
- }
- }
-
- /* Reject illegal initializers. */
- if (sym->value && flag)
- {
- 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;
- }
+ if (resolve_fl_variable (sym, mp_flag) == FAILURE)
+ return;
+ break;
- /* Assign default initializer. */
- if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
- && !sym->attr.pointer)
- sym->value = gfc_default_initializer (&sym->ts);
+ case FL_PROCEDURE:
+ if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
+ return;
break;
case FL_NAMELIST:
- /* Reject PRIVATE objects in a PUBLIC namelist. */
- if (gfc_check_access(sym->attr.access, sym->ns->default_access))
- {
- for (nl = sym->namelist; nl; nl = nl->next)
- {
- 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,
- &sym->declared_at);
- }
- }
+ if (resolve_fl_namelist (sym) == FAILURE)
+ return;
break;
- case FL_DERIVED:
- /* Add derived type to the derived type list. */
- {
- gfc_dt_list * dt_list;
- dt_list = gfc_get_dt_list ();
- dt_list->next = sym->ns->derived_types;
- dt_list->derived = sym;
- sym->ns->derived_types = dt_list;
- }
+ case FL_PARAMETER:
+ if (resolve_fl_parameter (sym) == FAILURE)
+ return;
+
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;
}
-
/* Make sure that intrinsic exist */
if (sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0)
gfc_resolve (sym->formal_ns);
formal_ns_flag = formal_ns_save;
}
+
+ /* Check threadprivate restrictions. */
+ if (sym->attr.threadprivate && !sym->attr.save
+ && (!sym->attr.in_common
+ && sym->module == NULL
+ && (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 (e->expr_type != EXPR_VARIABLE)
gfc_internal_error ("check_data_variable(): Bad expression");
+ if (e->symtree->n.sym->ns->is_block_data
+ && !e->symtree->n.sym->attr.in_common)
+ {
+ gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
+ e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
+ }
+
if (e->rank == 0)
{
mpz_init_set_ui (size, 1);
/* Warn about unused labels. */
static void
-warn_unused_label (gfc_namespace * ns)
+warn_unused_label (gfc_st_label * label)
{
- gfc_st_label *l;
-
- l = ns->st_labels;
- if (l == NULL)
+ if (label == NULL)
return;
- while (l->next)
- l = l->next;
+ warn_unused_label (label->left);
- for (; l; l = l->prev)
- {
- if (l->defined == ST_LABEL_UNKNOWN)
- continue;
+ if (label->defined == ST_LABEL_UNKNOWN)
+ return;
- switch (l->referenced)
- {
- case ST_LABEL_UNKNOWN:
- gfc_warning ("Label %d at %L defined but not used", l->value,
- &l->where);
- break;
+ switch (label->referenced)
+ {
+ case ST_LABEL_UNKNOWN:
+ gfc_warning ("Label %d at %L defined but not used", label->value,
+ &label->where);
+ break;
- case ST_LABEL_BAD_TARGET:
- gfc_warning ("Label %d at %L defined but cannot be used", l->value,
- &l->where);
- break;
+ case ST_LABEL_BAD_TARGET:
+ gfc_warning ("Label %d at %L defined but cannot be used",
+ label->value, &label->where);
+ break;
- default:
- break;
- }
+ default:
+ break;
}
+
+ warn_unused_label (label->right);
}
}
-/* This function is called after a complete program unit has been compiled.
- Its purpose is to examine all of the expressions associated with a program
- unit, assign types to all intermediate expressions, make sure that all
- assignments are to compatible types and figure out which names refer to
- which functions or subroutines. */
+/* Examine all of the expressions associated with a program unit,
+ assign types to all intermediate expressions, make sure that all
+ assignments are to compatible types and figure out which names
+ refer to which functions or subroutines. It doesn't check code
+ block, which is handled by resolve_code. */
-void
-gfc_resolve (gfc_namespace * ns)
+static void
+resolve_types (gfc_namespace * ns)
{
- gfc_namespace *old_ns, *n;
+ gfc_namespace *n;
gfc_charlen *cl;
gfc_data *d;
gfc_equiv *eq;
- old_ns = gfc_current_ns;
gfc_current_ns = ns;
- resolve_entries (ns);
-
- resolve_contained_functions (ns);
-
gfc_traverse_ns (ns, resolve_symbol);
resolve_fntype (ns);
"also be PURE", n->proc_name->name,
&n->proc_name->declared_at);
- gfc_resolve (n);
+ resolve_types (n);
}
forall_flag = 0;
for (eq = ns->equiv; eq; eq = eq->next)
resolve_equivalence (eq);
+ /* Warn about unused labels. */
+ if (gfc_option.warn_unused_labels)
+ warn_unused_label (ns->st_labels);
+}
+
+
+/* Call resolve_code recursively. */
+
+static void
+resolve_codes (gfc_namespace * ns)
+{
+ gfc_namespace *n;
+
+ for (n = ns->contained; n; n = n->sibling)
+ resolve_codes (n);
+
+ gfc_current_ns = ns;
cs_base = NULL;
resolve_code (ns->code, ns);
+}
- /* Warn about unused labels. */
- if (gfc_option.warn_unused_labels)
- warn_unused_label (ns);
+
+/* This function is called after a complete program unit has been compiled.
+ Its purpose is to examine all of the expressions associated with a program
+ unit, assign types to all intermediate expressions, make sure that all
+ assignments are to compatible types and figure out which names refer to
+ which functions or subroutines. */
+
+void
+gfc_resolve (gfc_namespace * ns)
+{
+ gfc_namespace *old_ns;
+
+ old_ns = gfc_current_ns;
+
+ resolve_contained_functions (ns);
+ resolve_types (ns);
+ resolve_codes (ns);
gfc_current_ns = old_ns;
}
OSDN Git Service
