aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/resolve.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/resolve.c')
-rw-r--r--gcc/fortran/resolve.c211
1 files changed, 139 insertions, 72 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b2c907495a2..3aad0bfa79b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1045,7 +1045,7 @@ resolve_common_blocks (gfc_symtree *common_root)
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->name);
+ gsym = gfc_get_gsymbol (common_root->n.common->name, false);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
@@ -1067,7 +1067,7 @@ resolve_common_blocks (gfc_symtree *common_root)
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->binding_label);
+ gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
@@ -1681,8 +1681,6 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
|| gfc_fl_struct (sym->attr.flavor))
return false;
- gcc_assert (sym->attr.flavor == FL_PROCEDURE);
-
/* If we've got an ENTRY, find real procedure. */
if (sym->attr.entry && sym->ns->entries)
proc_sym = sym->ns->entries->sym;
@@ -2484,7 +2482,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
- gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name);
+ gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
+ sym->binding_label != NULL);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
gfc_global_used (gsym, where);
@@ -2494,64 +2493,64 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
&& gsym->type != GSYM_UNKNOWN
&& !gsym->binding_label
&& gsym->ns
- && gsym->ns->resolved != -1
&& gsym->ns->proc_name
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
gfc_symbol *def_sym;
+ def_sym = gsym->ns->proc_name;
/* Resolve the gsymbol namespace if needed. */
- if (!gsym->ns->resolved)
+ if (gsym->ns->resolved != -1)
{
- gfc_dt_list *old_dt_list;
+ if (!gsym->ns->resolved)
+ {
+ gfc_dt_list *old_dt_list;
- /* Stash away derived types so that the backend_decls do not
- get mixed up. */
- old_dt_list = gfc_derived_types;
- gfc_derived_types = NULL;
+ /* Stash away derived types so that the backend_decls
+ do not get mixed up. */
+ old_dt_list = gfc_derived_types;
+ gfc_derived_types = NULL;
- gfc_resolve (gsym->ns);
+ gfc_resolve (gsym->ns);
- /* Store the new derived types with the global namespace. */
- if (gfc_derived_types)
- gsym->ns->derived_types = gfc_derived_types;
+ /* Store the new derived types with the global namespace. */
+ if (gfc_derived_types)
+ gsym->ns->derived_types = gfc_derived_types;
- /* Restore the derived types of this namespace. */
- gfc_derived_types = old_dt_list;
- }
+ /* Restore the derived types of this namespace. */
+ gfc_derived_types = old_dt_list;
+ }
- /* Make sure that translation for the gsymbol occurs before
- the procedure currently being resolved. */
- ns = gfc_global_ns_list;
- for (; ns && ns != gsym->ns; ns = ns->sibling)
- {
- if (ns->sibling == gsym->ns)
+ /* Make sure that translation for the gsymbol occurs before
+ the procedure currently being resolved. */
+ ns = gfc_global_ns_list;
+ for (; ns && ns != gsym->ns; ns = ns->sibling)
{
- ns->sibling = gsym->ns->sibling;
- gsym->ns->sibling = gfc_global_ns_list;
- gfc_global_ns_list = gsym->ns;
- break;
+ if (ns->sibling == gsym->ns)
+ {
+ ns->sibling = gsym->ns->sibling;
+ gsym->ns->sibling = gfc_global_ns_list;
+ gfc_global_ns_list = gsym->ns;
+ break;
+ }
}
- }
- def_sym = gsym->ns->proc_name;
-
- /* This can happen if a binding name has been specified. */
- if (gsym->binding_label && gsym->sym_name != def_sym->name)
- gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
+ /* This can happen if a binding name has been specified. */
+ if (gsym->binding_label && gsym->sym_name != def_sym->name)
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
- if (def_sym->attr.entry_master)
- {
- gfc_entry_list *entry;
- for (entry = gsym->ns->entries; entry; entry = entry->next)
- if (strcmp (entry->sym->name, sym->name) == 0)
- {
- def_sym = entry->sym;
- break;
- }
+ if (def_sym->attr.entry_master || def_sym->attr.entry)
+ {
+ gfc_entry_list *entry;
+ for (entry = gsym->ns->entries; entry; entry = entry->next)
+ if (strcmp (entry->sym->name, sym->name) == 0)
+ {
+ def_sym = entry->sym;
+ break;
+ }
+ }
}
-
if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
{
gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
@@ -4633,9 +4632,13 @@ find_array_spec (gfc_expr *e)
gfc_array_spec *as;
gfc_component *c;
gfc_ref *ref;
+ bool class_as = false;
if (e->symtree->n.sym->ts.type == BT_CLASS)
- as = CLASS_DATA (e->symtree->n.sym)->as;
+ {
+ as = CLASS_DATA (e->symtree->n.sym)->as;
+ class_as = true;
+ }
else
as = e->symtree->n.sym->as;
@@ -4654,7 +4657,7 @@ find_array_spec (gfc_expr *e)
c = ref->u.c.component;
if (c->attr.dimension)
{
- if (as != NULL)
+ if (as != NULL && !(class_as && as == c->as))
gfc_internal_error ("find_array_spec(): unused as(1)");
as = c->as;
}
@@ -5630,11 +5633,14 @@ resolve_procedure:
/* Checks to see that the correct symbol has been host associated.
- The only situation where this arises is that in which a twice
- contained function is parsed after the host association is made.
- Therefore, on detecting this, change the symbol in the expression
- and convert the array reference into an actual arglist if the old
- symbol is a variable. */
+ The only situations where this arises are:
+ (i) That in which a twice contained function is parsed after
+ the host association is made. On detecting this, change
+ the symbol in the expression and convert the array reference
+ into an actual arglist if the old symbol is a variable; or
+ (ii) That in which an external function is typed but not declared
+ explcitly to be external. Here, the old symbol is changed
+ from a variable to an external function. */
static bool
check_host_association (gfc_expr *e)
{
@@ -5724,6 +5730,26 @@ check_host_association (gfc_expr *e)
gfc_resolve_expr (e);
sym->refs++;
}
+ /* This case corresponds to a call, from a block or a contained
+ procedure, to an external function, which has not been declared
+ as being external in the main program but has been typed. */
+ else if (sym && old_sym != sym
+ && !e->ref
+ && sym->ts.type == BT_UNKNOWN
+ && old_sym->ts.type != BT_UNKNOWN
+ && sym->attr.flavor == FL_PROCEDURE
+ && old_sym->attr.flavor == FL_VARIABLE
+ && sym->ns->parent == old_sym->ns
+ && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_LABEL
+ || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
+ {
+ old_sym->attr.flavor = FL_PROCEDURE;
+ old_sym->attr.external = 1;
+ old_sym->attr.function = 1;
+ old_sym->result = old_sym;
+ gfc_resolve_expr (e);
+ }
}
/* This might have changed! */
return e->expr_type == EXPR_FUNCTION;
@@ -6903,19 +6929,6 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
"Step expression in DO loop"))
return false;
- if (iter->step->expr_type == EXPR_CONSTANT)
- {
- if ((iter->step->ts.type == BT_INTEGER
- && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
- || (iter->step->ts.type == BT_REAL
- && mpfr_sgn (iter->step->value.real) == 0))
- {
- gfc_error ("Step expression in DO loop at %L cannot be zero",
- &iter->step->where);
- return false;
- }
- }
-
/* Convert start, end, and step to the same type as var. */
if (iter->start->ts.kind != iter->var->ts.kind
|| iter->start->ts.type != iter->var->ts.type)
@@ -6929,6 +6942,19 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
|| iter->step->ts.type != iter->var->ts.type)
gfc_convert_type (iter->step, &iter->var->ts, 1);
+ if (iter->step->expr_type == EXPR_CONSTANT)
+ {
+ if ((iter->step->ts.type == BT_INTEGER
+ && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
+ || (iter->step->ts.type == BT_REAL
+ && mpfr_sgn (iter->step->value.real) == 0))
+ {
+ gfc_error ("Step expression in DO loop at %L cannot be zero",
+ &iter->step->where);
+ return false;
+ }
+ }
+
if (iter->start->expr_type == EXPR_CONSTANT
&& iter->end->expr_type == EXPR_CONSTANT
&& iter->step->expr_type == EXPR_CONSTANT)
@@ -7655,13 +7681,54 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
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;
- }
+ {
+ switch (ar->dimen_type[i])
+ {
+ case DIMEN_THIS_IMAGE:
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+
+ case DIMEN_RANGE:
+ if (ar->start[i] == 0 || ar->end[i] == 0)
+ {
+ /* If ar->stride[i] is NULL, we issued a previous error. */
+ if (ar->stride[i] == NULL)
+ gfc_error ("Bad array specification in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
+ else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
+ {
+ gfc_error ("Upper cobound is less than lower cobound at %L",
+ &ar->start[i]->where);
+ goto failure;
+ }
+ break;
+
+ case DIMEN_ELEMENT:
+ if (ar->start[i]->expr_type == EXPR_CONSTANT)
+ {
+ gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
+ if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
+ {
+ gfc_error ("Upper cobound is less than lower cobound "
+ " of 1 at %L", &ar->start[i]->where);
+ goto failure;
+ }
+ }
+ break;
+
+ case DIMEN_STAR:
+ break;
+
+ default:
+ gfc_error ("Bad array specification in ALLOCATE statement at %L",
+ &e->where);
+ goto failure;
+ }
+ }
for (i = 0; i < ar->dimen; i++)
{
if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
@@ -11665,7 +11732,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
&& (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
{
if (!gsym)
- gsym = gfc_get_gsymbol (sym->binding_label);
+ gsym = gfc_get_gsymbol (sym->binding_label, true);
gsym->where = sym->declared_at;
gsym->sym_name = sym->name;
gsym->binding_label = sym->binding_label;
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-17 02:17:31 +0000