diff options
Diffstat (limited to 'gcc/fortran/resolve.cc')
| -rw-r--r-- | gcc/fortran/resolve.cc | 165 |
1 files changed, 165 insertions, 0 deletions
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 4a6e951..93df5d0 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -3919,10 +3919,153 @@ found: } + +static bool +check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e, + gfc_code *c, gfc_namespace *ns) +{ + locus *here; + + /* If the type has been imported then its vtype functions are OK. */ + if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype) + return true; + + if (e) + here = &e->where; + else + here = &c->loc; + + if (s && !s->import_only) + s = gfc_find_symtree (ns->sym_root, sym->name); + + if (ns->import_state == IMPORT_ONLY + && sym->ns != ns + && (!s || !s->import_only)) + { + gfc_error ("F2018: C8102 %qs at %L is host associated but does not " + "appear in an IMPORT or IMPORT, ONLY list", sym->name, here); + return false; + } + else if (ns->import_state == IMPORT_NONE + && sym->ns != ns) + { + gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that " + "has IMPORT, NONE", sym->name, here); + return false; + } + return true; +} + + +static bool +check_import_status (gfc_expr *e) +{ + gfc_symtree *st; + gfc_ref *ref; + gfc_symbol *sym, *der; + gfc_namespace *ns = gfc_current_ns; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + case EXPR_FUNCTION: + case EXPR_SUBSTRING: + sym = e->symtree ? e->symtree->n.sym : NULL; + + /* Check the symbol itself. */ + if (sym + && !(ns->proc_name + && (sym == ns->proc_name)) + && !check_sym_import_status (sym, e->symtree, e, NULL, ns)) + return false; + + /* Check the declared derived type. */ + if (sym->ts.type == BT_DERIVED) + { + der = sym->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym)) + { + der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived + : sym->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + + /* Check the declared derived types of component references. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + { + gfc_component *c = ref->u.c.component; + if (c->ts.type == BT_DERIVED) + { + der = c->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c)) + { + der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived + : c->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + } + + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + /* Check the declared derived type. */ + if (e->ts.type == BT_DERIVED) + { + der = e->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e)) + { + der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived + : e->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + + break; + +/* Either not applicable or resolved away + case EXPR_OP: + case EXPR_UNKNOWN: + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_COMPCALL: + case EXPR_PPC: */ + + default: + break; + } + + return true; +} + + /* Resolve a subroutine call. Although it was tempting to use the same code for functions, subroutines and functions are stored differently and this makes things awkward. */ + static bool resolve_call (gfc_code *c) { @@ -4080,6 +4223,11 @@ resolve_call (gfc_code *c) "Using subroutine %qs at %L is deprecated", c->resolved_sym->name, &c->loc); + csym = c->resolved_sym ? c->resolved_sym : csym; + if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym + && csym != gfc_current_ns->proc_name) + return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns); + return t; } @@ -7792,6 +7940,7 @@ fixup_unique_dummy (gfc_expr *e) e->symtree = st; } + /* Resolve an expression. That is, make sure that types of operands agree with their operators, intrinsic operators are converted to function calls for overloaded types and unresolved function references are resolved. */ @@ -7919,6 +8068,9 @@ gfc_resolve_expr (gfc_expr *e) && UNLIMITED_POLY (e->symtree->n.sym)) e->do_not_resolve_again = 1; + if (t && gfc_current_ns->import_state != IMPORT_NOT_SET) + t = check_import_status (e); + return t; } @@ -10572,6 +10724,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) int rank = 0, corank = 0; gfc_ref* ref = NULL; gfc_expr *selector_expr = NULL; + gfc_code *old_code = code; ns = code->ext.block.ns; if (code->expr2) @@ -10860,6 +11013,18 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) when this case is actually true, so build a new ASSOCIATE that does precisely this here (instead of using the 'global' one). */ + + /* First check the derived type import status. */ + if (gfc_current_ns->import_state != IMPORT_NOT_SET + && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)) + { + st = gfc_find_symtree (gfc_current_ns->sym_root, + c->ts.u.derived->name); + if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code, + gfc_current_ns)) + error++; + } + const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1); if (c->ts.type == BT_CLASS) snprintf (name, sizeof (name), "__tmp_class_%s_%s", |