Hello All, I was mulling over the F2018 status of gfortran, when I came across the additions to the IMPORT statement. This seemed like such a useful addition to fortran that I set about an implementation; thinking that this would be low hanging fruit. Parsing and checking the constraints C897-8100 turned out to be straightforward. C8101 was already implemented for F2008 IMPORT. C8102 required a lot more work! (Please see the patch for the constraints.)
Steve K got in touch, when he found out that we had been working in parallel on the new IMPORT features. Thus encouraged by our exchanges, I ground on until the patch reached its present state. I think that the ChangeLog is clear enough, even if the patch came out a bit long winded. Of the existing IMPORT tests, only import3.f90 needed modification by setting -std=f2008 because of the change in the wording of the error messages. The new test, import12.f90, is complete IMHO but I am open to suggestions for additions. I cannot return to working on this until the second week of July so you have plenty of time to test and comment. Regtests fine with x86_64 on FC42. OK for mainline? Paul
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 69acd2da981..111ebc5f845 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -1723,13 +1723,17 @@ build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
symbol_attribute attr;
gfc_symbol *sym;
int upper;
- gfc_symtree *st;
+ gfc_symtree *st, *host_st = NULL;
/* Symbols in a submodule are host associated from the parent module or
submodules. Therefore, they can be overridden by declarations in the
submodule scope. Deal with this by attaching the existing symbol to
a new symtree and recycling the old symtree with a new symbol... */
st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL))
+ && gfc_current_ns->parent)
+ host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name);
+
if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
&& st->n.sym != NULL
&& st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
@@ -1742,6 +1746,20 @@ build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
sym->refs++;
gfc_set_sym_referenced (sym);
}
+ /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the
+ current scope are not violated by local redeclarations. Note that there is
+ no need to guard for std >= F2018 because import_only and IMPORT_ALL are
+ only set for these standards. */
+ else if (host_st && host_st->n.sym
+ && host_st->n.sym != gfc_current_ns->proc_name
+ && !(st && st->n.sym
+ && (st->n.sym->attr.dummy || st->n.sym->attr.result)))
+ {
+ gfc_error ("F2018: C8102 %s at %L is already imported by an %s "
+ "statement and must not be re-declared", name, var_locus,
+ (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL");
+ return false;
+ }
/* ...Otherwise generate a new symtree and new symbol. */
else if (gfc_get_symbol (name, NULL, &sym, var_locus))
return false;
@@ -5100,6 +5118,54 @@ error:
}
+/* Match the IMPORT statement. IMPORT was added to F2003 as
+
+ R1209 import-stmt is IMPORT [[ :: ] import-name-list ]
+
+ C1210 (R1209) The IMPORT statement is allowed only in an interface-body.
+
+ C1211 (R1209) Each import-name shall be the name of an entity in the
+ host scoping unit.
+
+ under the description of an interface block. Under F2008, IMPORT was
+ split out of the interface block description to 12.4.3.3 and C1210
+ became
+
+ C1210 (R1209) The IMPORT statement is allowed only in an interface-body
+ that is not a module procedure interface body.
+
+ Finally, F2018, section 8.8, has changed the IMPORT statement to
+
+ R867 import-stmt is IMPORT [[ :: ] import-name-list ]
+ or IMPORT, ONLY : import-name-list
+ or IMPORT, NONE
+ or IMPORT, ALL
+
+ C896 (R867) An IMPORT statement shall not appear in the scoping unit of
+ a main-program, external-subprogram, module, or block-data.
+
+ C897 (R867) Each import-name shall be the name of an entity in the host
+ scoping unit.
+
+ C898 If any IMPORT statement in a scoping unit has an ONLY specifier,
+ all IMPORT statements in that scoping unit shall have an ONLY
+ specifier.
+
+ C899 IMPORT, NONE shall not appear in the scoping unit of a submodule.
+
+ C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping
+ unit, no other IMPORT statement shall appear in that scoping unit.
+
+ C8101 Within an interface body, an entity that is accessed by host
+ association shall be accessible by host or use association within
+ the host scoping unit, or explicitly declared prior to the interface
+ body.
+
+ C8102 An entity whose name appears as an import-name or which is made
+ accessible by an IMPORT, ALL statement shall not appear in any
+ context described in 19.5.1.4 that would cause the host entity
+ of that name to be inaccessible. */
+
match
gfc_match_import (void)
{
@@ -5107,16 +5173,28 @@ gfc_match_import (void)
match m;
gfc_symbol *sym;
gfc_symtree *st;
+ bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;;
+ importstate current_import_state = gfc_current_ns->import_state;
- if (gfc_current_ns->proc_name == NULL
- || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
+ if (!f2018_allowed
+ && (gfc_current_ns->proc_name == NULL
+ || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY))
{
gfc_error ("IMPORT statement at %C only permitted in "
"an INTERFACE body");
return MATCH_ERROR;
}
+ else if (f2018_allowed
+ && (!gfc_current_ns->parent || gfc_current_ns->is_block_data))
+ goto C897;
+
+ if (f2018_allowed
+ && (current_import_state == IMPORT_ALL
+ || current_import_state == IMPORT_NONE))
+ goto C8100;
- if (gfc_current_ns->proc_name->attr.module_procedure)
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.module_procedure)
{
gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
"in a module procedure interface body");
@@ -5126,20 +5204,65 @@ gfc_match_import (void)
if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
return MATCH_ERROR;
+ gfc_current_ns->import_state = IMPORT_NOT_SET;
+ if (f2018_allowed)
+ {
+ if (gfc_match (" , none") == MATCH_YES)
+ {
+ if (current_import_state == IMPORT_ONLY)
+ goto C898;
+ if (gfc_current_state () == COMP_SUBMODULE)
+ goto C899;
+ gfc_current_ns->import_state = IMPORT_NONE;
+ }
+ else if (gfc_match (" , only :") == MATCH_YES)
+ {
+ if (current_import_state != IMPORT_NOT_SET
+ && current_import_state != IMPORT_ONLY)
+ goto C898;
+ gfc_current_ns->import_state = IMPORT_ONLY;
+ }
+ else if (gfc_match (" , all") == MATCH_YES)
+ {
+ if (current_import_state == IMPORT_ONLY)
+ goto C898;
+ gfc_current_ns->import_state = IMPORT_ALL;
+ }
+
+ if (current_import_state != IMPORT_NOT_SET
+ && (gfc_current_ns->import_state == IMPORT_NONE
+ || gfc_current_ns->import_state == IMPORT_ALL))
+ goto C8100;
+ }
+
+ /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */
if (gfc_match_eos () == MATCH_YES)
{
- /* All host variables should be imported. */
- gfc_current_ns->has_import_set = 1;
+ /* This is the F2008 variant. */
+ if (gfc_current_ns->import_state == IMPORT_NOT_SET)
+ {
+ if (current_import_state == IMPORT_ONLY)
+ goto C898;
+ gfc_current_ns->import_state = IMPORT_F2008;
+ }
+
+ /* Host variables should be imported. */
+ if (gfc_current_ns->import_state != IMPORT_NONE)
+ gfc_current_ns->has_import_set = 1;
return MATCH_YES;
}
- if (gfc_match (" ::") == MATCH_YES)
+ if (gfc_match (" ::") == MATCH_YES
+ && gfc_current_ns->import_state != IMPORT_ONLY)
{
if (gfc_match_eos () == MATCH_YES)
- {
- gfc_error ("Expecting list of named entities at %C");
- return MATCH_ERROR;
- }
+ goto expecting_list;
+ gfc_current_ns->import_state = IMPORT_F2008;
+ }
+ else if (gfc_current_ns->import_state == IMPORT_ONLY)
+ {
+ if (gfc_match_eos () == MATCH_YES)
+ goto expecting_list;
}
for(;;)
@@ -5166,12 +5289,28 @@ gfc_match_import (void)
if (sym == NULL)
{
- gfc_error ("Cannot IMPORT %qs from host scoping unit "
- "at %C - does not exist.", name);
- return MATCH_ERROR;
+ if (gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ {
+ gfc_error ("Cannot IMPORT %qs from host scoping unit "
+ "at %C - does not exist.", name);
+ return MATCH_ERROR;
+ }
+ else
+ {
+ /* This might be a procedure that has not yet been parsed. If
+ so gfc_fixup_sibling_symbols will replace this symbol with
+ that of the procedure. */
+ gfc_get_sym_tree (name, gfc_current_ns, &st, false,
+ &gfc_current_locus);
+ st->n.sym->refs++;
+ st->n.sym->attr.imported = 1;
+ st->import_only = 1;
+ goto next_item;
+ }
}
- if (gfc_find_symtree (gfc_current_ns->sym_root, name))
+ st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (st && st->n.sym && st->n.sym->attr.imported)
{
gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
"at %C", name);
@@ -5182,6 +5321,7 @@ gfc_match_import (void)
st->n.sym = sym;
sym->refs++;
sym->attr.imported = 1;
+ st->import_only = 1;
if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
{
@@ -5193,6 +5333,7 @@ gfc_match_import (void)
st->n.sym = sym;
sym->refs++;
sym->attr.imported = 1;
+ st->import_only = 1;
}
goto next_item;
@@ -5216,6 +5357,34 @@ gfc_match_import (void)
syntax:
gfc_error ("Syntax error in IMPORT statement at %C");
return MATCH_ERROR;
+
+C897:
+ gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main "
+ "program, an external subprogram, a module or block data");
+ return MATCH_ERROR;
+
+C898:
+ gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because "
+ "a scoping unit has an ONLY specifier, can only have IMPORT "
+ "with an ONLY specifier");
+ return MATCH_ERROR;
+
+C899:
+ gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit"
+ " of a submodule as at %C");
+ return MATCH_ERROR;
+
+C8100:
+ gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because "
+ "%s has already been declared, which must be unique in the "
+ "scoping unit",
+ gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" :
+ "IMPORT, NONE");
+ return MATCH_ERROR;
+
+expecting_list:
+ gfc_error ("Expecting list of named entities at %C");
+ return MATCH_ERROR;
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f73b5f9c23f..8e909e06db0 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2188,6 +2188,7 @@ typedef struct gfc_symtree
gfc_omp_udr *omp_udr;
}
n;
+ unsigned import_only:1;
}
gfc_symtree;
@@ -2215,6 +2216,17 @@ typedef struct gfc_was_finalized {
}
gfc_was_finalized;
+
+ /* Flag F2018 import status */
+enum importstate
+{ IMPORT_NOT_SET = 0, /* Default condition. */
+ IMPORT_F2008, /* Old style IMPORT. */
+ IMPORT_ONLY, /* Import list used. */
+ IMPORT_NONE, /* No host association. Unique in scoping unit. */
+ IMPORT_ALL /* Must be unique in the scoping unit. */
+};
+
+
/* A namespace describes the contents of procedure, module, interface block
or BLOCK construct. */
/* ??? Anything else use these? */
@@ -2328,6 +2340,10 @@ typedef struct gfc_namespace
/* Set to 1 if namespace is an interface body with "IMPORT" used. */
unsigned has_import_set:1;
+ /* Flag F2018 import status */
+ ENUM_BITFIELD (importstate) import_state :3;
+
+
/* Set to 1 if the namespace uses "IMPLICIT NONE (export)". */
unsigned has_implicit_none_export:1;
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 8d4ca39929c..847ff37cafd 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -6793,6 +6793,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
gfc_namespace *ns;
gfc_symtree *st;
gfc_symbol *old_sym;
+ bool imported;
for (ns = siblings; ns; ns = ns->sibling)
{
@@ -6808,6 +6809,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
goto fixup_contained;
old_sym = st->n.sym;
+ imported = old_sym->attr.imported == 1;
if (old_sym->ns == ns
&& !old_sym->attr.contained
@@ -6834,7 +6836,8 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
/* Replace it with the symbol from the parent namespace. */
st->n.sym = sym;
sym->refs++;
-
+ if (imported)
+ sym->attr.imported = 1;
gfc_release_symbol (old_sym);
}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index d09aef0a899..ac15e93b1a8 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;
}
@@ -7820,6 +7968,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. */
@@ -7947,6 +8096,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;
}
@@ -10583,6 +10735,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)
@@ -10870,6 +11023,18 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
that does precisely this here (instead of using the
'global' one). */
+ /* Check the symbol itself. */
+
+ 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++;
+ }
+
if (c->ts.type == BT_CLASS)
sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
else if (c->ts.type == BT_DERIVED)
diff --git a/gcc/testsuite/gfortran.dg/import12.f90 b/gcc/testsuite/gfortran.dg/import12.f90
new file mode 100644
index 00000000000..df1aae6d0d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/import12.f90
@@ -0,0 +1,302 @@
+! { dg-do compile }
+!
+! Tests the variants of IMPORT introduced in F2018
+!
+! Contributed by Paul Thomas <pa...@gcc.gnu.org>
+!
+MODULE M
+ import, none ! { dg-error "F2018: C897 IMPORT statement" }
+ IMPLICIT NONE
+ integer :: z
+end module
+
+MODULE N
+ IMPLICIT NONE
+ integer :: z
+end module
+
+! Taken from gfortran.dg/pr103312.f90. These F2008-style invocations should
+! be accepted.
+module example
+ type, abstract :: foo
+ integer :: i
+ contains
+ procedure(foo_size), deferred :: size
+ procedure(foo_func), deferred :: func
+ end type
+ abstract interface
+ pure integer function foo_size (this)
+ import :: foo
+ class(foo), intent(in) :: this
+ end function
+ function foo_func (this) result (string)
+ import :: foo
+ class(foo) :: this
+ character(this%size()) :: string
+ end function
+ end interface
+end module
+
+block data blk
+ import, all ! { dg-error "F2018: C897 IMPORT statement" }
+ integer a(2)
+ common /my_common/a
+ data a/1,2/
+end
+
+subroutine extern_sub1
+ import ! { dg-error "F2018: C897 IMPORT statement" }
+end
+
+subroutine extern_sub2 (arg1, arg2, arg3)
+ implicit none
+ integer :: arg1, arg2, arg3
+ arg1 = int_fcn ()
+contains
+ integer function int_fcn ()
+ import, only : arg2, arg3
+ int_fcn = arg2 * arg3
+ end
+end
+
+program p
+ import, all ! { dg-error "F2018: C897 IMPORT statement" }
+ implicit none
+ integer :: x, y
+ type :: t
+ integer :: i
+ end type
+ type(t) :: progtype
+ type, extends(t) :: s
+ integer :: j
+ end type
+ class(t), allocatable :: progclass
+contains
+
+! OK because arg is just that and x is declared in scope of sub1.
+ subroutine sub1 (arg)
+ import, none
+ implicit none
+ real :: arg, x
+ end
+
+! IMPORT, ALL must be the only IMPORT statement in the scope.
+ subroutine sub2 (arg)
+ import, none
+ import, all ! { dg-error "F2018: C8100 IMPORT statement" }
+ implicit none
+ real :: arg, x
+ end
+
+! Error message says it all.
+ subroutine sub3 (arg)
+ import, none
+ implicit none
+ integer :: arg
+ print *, arg
+ x = 1 ! { dg-error "F2018: C8102" }
+ end
+
+! Error messages say it all.
+ subroutine sub4 (arg)
+ import, only : y
+ implicit none
+ integer :: arg
+ print *, arg
+ x = 1 ! { dg-error "F2018: C8102" }
+ y = 2
+ print *, x ! { dg-error "F2018: C8102" }
+ end
+
+! IMPORT eos and IMPORT, ALL must be unique in the scope.
+ subroutine sub5a (arg)
+ import, all
+ import ! { dg-error "F2018: C8100" }
+ implicit none
+ real :: arg
+ real :: x ! { dg-error "F2018: C8102" }
+ end
+
+ subroutine sub5b (arg)
+ import, only : x
+ implicit none
+ real :: arg
+ real :: x ! { dg-error "F2018: C8102" }
+ end
+
+! Error message says it all.
+ integer function func1 ()
+ import, only : x
+ func1 = x * y ! { dg-error "F2018: C8102" }
+ end
+
+! Error messages say it all.
+ subroutine sub6 (arg)
+ import, only : func1
+ import, only : func2
+ import, only : foobar ! { dg-error "has no IMPLICIT type" }
+ implicit none
+ integer :: arg
+ arg = func1 () * func2 () * func3 () ! { dg-error "F2018: C8102" }
+ end
+
+! Error message says it all.
+ integer function func2 ()
+ use N
+ import, none
+ implicit none
+ func2 = y ! { dg-error "F2018: C8102" }
+ end
+
+! OK
+ integer function func3 ()
+ func3 = 42
+ end
+
+ subroutine sub7 (arg)
+ implicit none
+ integer :: arg
+! OK
+ block
+ import, only : arg, func1, func2, func3
+ arg = func1 () * func2 () * func3 ()
+ end block
+ block
+ arg = func1 ()
+ import, only : arg, func1 ! { dg-error "Unexpected IMPORT statement" }
+ end block
+ end
+
+! Error messages say it all.
+ subroutine sub8 (arg)
+ implicit none
+ integer :: arg
+ block
+ import, only : func1
+ import, only : func2
+ import, only : foobar ! { dg-error "has no IMPLICIT type" }
+ arg = func1 () * func2 () * func3 () ! { dg-error "F2018: C8102" }
+ end block
+ end
+
+! ASSOCIATE does not have a specification part so IMPORT cannot appear.
+ subroutine sub9 (arg)
+ implicit none
+ integer :: arg
+ associate (f3 => func3 ()) ! { dg-error "F2018: C8102" }
+ import, only : arg, func1 ! { dg-error "Unexpected IMPORT statement" }
+ arg = func1 () * func2 () * f3 ! { dg-error "F2018: C8102" }
+ end associate
+ end
+
+! OK
+ subroutine sub10 (arg)
+ import, only : t
+ implicit none
+ type(t) :: arg, mytype
+ mytype%i = 1
+ arg = mytype
+ end
+
+! TYPE t does not appear in the IMPORT list
+ subroutine sub11 (arg)
+ import, only : progtype
+ implicit none
+ type(t) :: arg
+ progtype%i = 1 ! { dg-error "F2018: C8102" }
+ arg = progtype ! { dg-error "F2018: C8102" }
+ end
+
+! TYPE t is excluded by IMPORT, NONE
+ subroutine sub12 (arg)
+ import, none
+ implicit none
+ type(t) :: arg, mytype
+ mytype%i = 1 ! { dg-error "F2018: C8102" }
+ arg = mytype ! { dg-error "F2018: C8102" }
+ end
+
+! TYPE t does not appear in the IMPORT list
+ subroutine sub13 (arg)
+ import, only : progclass
+ implicit none
+ class(t) :: arg
+ type(t) :: ca(2) = [t(1), t(2)] ! { dg-error "F2018: C8102" }
+ progclass%i = t(1) ! { dg-error "F2018: C8102" }
+ arg = progclass ! { dg-error "F2018: C8102" }
+ ca = [t(1), t(2)] ! { dg-error "has no IMPLICIT type|F2018: C8102" }
+ arg = ca(2) ! Note: The preceeding line catches 'ca' having no implicit type.
+ end
+
+! TYPE t is excluded by IMPORT, NONE
+ subroutine sub14 (arg)
+ import, none
+ implicit none
+ class(t) :: arg
+ class(t), allocatable :: myclass
+ myclass%i = t(1) ! { dg-error "F2018: C8102" }
+ arg%i = myclass%i ! { dg-error "F2018: C8102" }
+ select type (arg) ! { dg-error "F2018: C8102" }
+ type is (t)
+ arg%i = arg%i + 1
+ type is (s)
+ arg%j = -1
+ end select
+ end
+
+! TYPE s does not appear in the IMPORT, ONLY list
+ subroutine sub15 (arg)
+ import, only : t
+ implicit none
+ class(t) :: arg
+ class(t), allocatable :: myclass
+ myclass = t(1)
+ arg%i = myclass%i
+ select type (arg) ! { dg-error "F2018: C8102" }
+ type is (t)
+ arg%i = arg%i + 1
+ type is (s)
+ arg%j = -1 ! s is caught at the SELECT TYPE statement
+ end select
+ end
+
+! This is OK
+ subroutine sub16 (arg)
+ import, only : t, s
+ implicit none
+ class(t) :: arg
+ class(t), allocatable :: myclass
+ myclass = t(1)
+ arg%i = myclass%i
+ select type (arg)
+ type is (t)
+ arg%i = arg%i + 1
+ type is (s)
+ arg%j = -1
+ end select
+ end
+
+ subroutine sub17 (arg)
+ import, only : t
+ implicit none
+ class(t) :: arg
+ call sub16 (arg) ! { dg-error "F2018: C8102" }
+ end
+
+! Make sure that recursive procedures do not require the procedure itself to be imported.
+ recursive subroutine sub18 (arg)
+ import, none
+ implicit none
+ integer :: arg
+ if (arg <= 0) call sub18 (arg)
+ arg = 1
+ end
+
+ recursive integer function func4 (arg) result (res)
+ import, none
+ implicit none
+ integer :: arg
+ if (arg <= 0) arg = func4 (arg)
+ res = 1
+ end
+end
diff --git a/gcc/testsuite/gfortran.dg/import3.f90 b/gcc/testsuite/gfortran.dg/import3.f90
index 74cd5279b1f..9288c6b63a2 100644
--- a/gcc/testsuite/gfortran.dg/import3.f90
+++ b/gcc/testsuite/gfortran.dg/import3.f90
@@ -1,6 +1,8 @@
! { dg-do compile }
+! { dg-options "-std=f2008" }
! { dg-shouldfail "Invalid use of IMPORT" }
! Test invalid uses of import
+! Wording of some error messages change for -std>=F2018 but all are caught.
! PR fortran/29601
subroutine test()
Change.Logs
Description: Binary data
