2014-10-02 Tobias Burnus <burnus@net-b.de>
gcc/fortran/
* libgfortran.h (GFC_STD_F2015): Add.
* decl.c (gfc_match_implicit_none): Handle spec list.
(gfc_match_implicit): Move double intrinsic warning here.
* gfortran.h (gfc_namespace): Add has_implicit_none_export:1.
(gfc_set_implicit_none): Update interface.
* interface.c (gfc_procedure_use): Add implicit-none external
error check.
* parse.c (accept_statement): Remove call.
(verify_st_order): Permit that external-implict-none follows
implicit statement.
* symbol.c (gfc_set_implicit_none): Handle external/type
implicit none.
gcc/testsuite/
* gfortran.dg/implicit_14.f90: New.
* gfortran.dg/implicit_15.f90: New.
* gfortran.dg/implicit_4.f90: Update dg-error.
@@ -22,6 +22,8 @@ along with GCC; see the file COPYING3. If not see
Note that no features were obsoleted nor deleted in F2003.
Please remember to keep those definitions in sync with
gfortran.texi. */
+/* For now, use F2015 = GFC_STD_GNU. */
+#define GFC_STD_F2015 (1<<5) /* PLACEHOLDER for Fortran 2015. */
#define GFC_STD_F2008_TS (1<<9) /* POST-F2008 technical reports. */
#define GFC_STD_F2008_OBS (1<<8) /* Obsolescent in F2008. */
#define GFC_STD_F2008 (1<<7) /* New in F2008. */
@@ -2946,7 +2946,50 @@ get_kind:
match
gfc_match_implicit_none (void)
{
- return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
+ char c;
+ match m;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ bool type = false;
+ bool external = false;
+
+ gfc_gobble_whitespace ();
+ c = gfc_peek_ascii_char ();
+ if (c == '(')
+ {
+ (void) gfc_next_ascii_char ();
+ if (!gfc_notify_std (GFC_STD_F2015, "IMPORT NONE with spec list at %C"))
+ return MATCH_ERROR;
+ for(;;)
+ {
+ m = gfc_match (" %n", name);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (strcmp (name, "type") == 0)
+ type = true;
+ else if (strcmp (name, "external") == 0)
+ external = true;
+ else
+ return MATCH_ERROR;
+
+ gfc_gobble_whitespace ();
+ c = gfc_next_ascii_char ();
+ if (c == ',')
+ continue;
+ if (c == ')')
+ break;
+ return MATCH_ERROR;
+ }
+ }
+ else
+ type = true;
+
+ if (gfc_match_eos () != MATCH_YES)
+ return MATCH_ERROR;
+
+ gfc_set_implicit_none (type, external);
+
+ return MATCH_YES;
}
@@ -3062,6 +3105,13 @@ gfc_match_implicit (void)
char c;
match m;
+ if (gfc_current_ns->seen_implicit_none)
+ {
+ gfc_error ("IMPLICIT statement at %C following a type IMPLICIT NONE "
+ "statement");
+ return MATCH_ERROR;
+ }
+
gfc_clear_ts (&ts);
/* We don't allow empty implicit statements. */
@@ -1655,6 +1655,9 @@ typedef struct gfc_namespace
/* Set to 1 if namespace is an interface body with "IMPORT" used. */
unsigned has_import_set:1;
+ /* Set to 1 if the namespace uses "IMPLICT NONE (export)". */
+ unsigned has_implicit_none_export:1;
+
/* Set to 1 if resolved has been called for this namespace.
Holds -1 during resolution. */
signed resolved:2;
@@ -2754,7 +2757,7 @@ extern int gfc_character_storage_size;
void gfc_clear_new_implicit (void);
bool gfc_add_new_implicit_range (int, int);
bool gfc_merge_new_implicit (gfc_typespec *);
-void gfc_set_implicit_none (void);
+void gfc_set_implicit_none (bool, bool);
void gfc_check_function_type (gfc_namespace *);
bool gfc_is_intrinsic_typename (const char *);
@@ -3252,8 +3252,14 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
for calling a ISO_C_BINDING because c_loc and c_funloc
are pseudo-unknown. Additionally, warn about procedures not
explicitly declared at all if requested. */
- if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
+ if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c)
{
+ if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
+ {
+ gfc_error ("Procedure '%s' called at %L is not explicitly declared",
+ sym->name, where);
+ return false;
+ }
if (gfc_option.warn_implicit_interface)
gfc_warning ("Procedure '%s' called with an implicit interface at %L",
sym->name, where);
@@ -1950,9 +1950,6 @@ accept_statement (gfc_statement st)
switch (st)
{
case ST_IMPLICIT_NONE:
- gfc_set_implicit_none ();
- break;
-
case ST_IMPLICIT:
break;
@@ -2142,7 +2139,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
break;
case ST_IMPLICIT_NONE:
- if (p->state > ORDER_IMPLICIT_NONE)
+ if (p->state > ORDER_IMPLICIT)
goto order;
/* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
@@ -114,22 +114,34 @@ static int new_flag[GFC_LETTERS];
/* Handle a correctly parsed IMPLICIT NONE. */
void
-gfc_set_implicit_none (void)
+gfc_set_implicit_none (bool type, bool external)
{
int i;
- if (gfc_current_ns->seen_implicit_none)
+ if (gfc_current_ns->seen_implicit_none
+ || gfc_current_ns->has_implicit_none_export)
{
- gfc_error ("Duplicate IMPLICIT NONE statement at %C");
+ gfc_error_now ("Duplicate IMPLICIT NONE statement at %C");
return;
}
- gfc_current_ns->seen_implicit_none = 1;
+ if (external)
+ gfc_current_ns->has_implicit_none_export = 1;
- for (i = 0; i < GFC_LETTERS; i++)
+ if (type)
{
- gfc_clear_ts (&gfc_current_ns->default_type[i]);
- gfc_current_ns->set_flag[i] = 1;
+ gfc_current_ns->seen_implicit_none = 1;
+ for (i = 0; i < GFC_LETTERS; i++)
+ {
+ if (gfc_current_ns->set_flag[i])
+ {
+ gfc_error_now ("Type IMPLICIT NONE statement at %C following an "
+ "IMPLICIT statement");
+ return;
+ }
+ gfc_clear_ts (&gfc_current_ns->default_type[i]);
+ gfc_current_ns->set_flag[i] = 1;
+ }
}
}
@@ -2383,6 +2395,9 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types)
}
}
+ if (parent_types && ns->parent != NULL)
+ ns->has_implicit_none_export = ns->parent->has_implicit_none_export;
+
ns->refs = 1;
return ns;
new file mode 100644
@@ -0,0 +1,8 @@
+! { dg-do compile }
+! { dg-options "-std=f2008ts" }
+!
+! Support Fortran 2015's IMPLICIT NONE with spec list
+! (currently implemented as vendor extension)
+
+implicit none (type) ! { dg-error "GNU Extension: IMPORT NONE with spec list at \\(1\\)" }
+end
new file mode 100644
@@ -0,0 +1,70 @@
+! { dg-do compile }
+! { dg-options "" }
+!
+! Support Fortran 2015's IMPLICIT NONE with spec list
+!
+
+subroutine sub1
+implicit none (type)
+call test()
+i = 1 ! { dg-error "Symbol 'i' at .1. has no IMPLICIT type" }
+end subroutine sub1
+
+subroutine sub2
+implicit none ( external )
+call foo() ! { dg-error "Procedure 'foo' called at .1. is not explicitly declared" }
+i = 2
+end subroutine sub2
+
+subroutine sub3
+implicit none ( external, type, external, type )
+call foo() ! { dg-error "Procedure 'foo' called at .1. is not explicitly declared" }
+i = 3 ! { dg-error "Symbol 'i' at .1. has no IMPLICIT type" }
+end subroutine sub3
+
+subroutine sub4
+implicit none ( external ,type)
+external foo
+call foo()
+i = 4 ! { dg-error "Symbol 'i' at .1. has no IMPLICIT type" }
+end subroutine sub4
+
+subroutine sub5 ! OK
+implicit integer(a-z)
+implicit none ( external )
+procedure() :: foo
+call foo()
+i = 5
+end subroutine sub5
+
+subroutine sub6 ! OK
+implicit none ( external )
+implicit integer(a-z)
+procedure() :: foo
+call foo()
+i = 5
+end subroutine sub6
+
+subroutine sub7
+implicit none ( external )
+implicit none ! { dg-error "Duplicate IMPLICIT NONE statement" }
+end subroutine sub7
+
+subroutine sub8
+implicit none
+implicit none ( type ) ! { dg-error "Duplicate IMPLICIT NONE statement" }
+end subroutine sub8
+
+subroutine sub9
+implicit none ( external, type )
+implicit integer(a-z) ! { dg-error "IMPLICIT statement at .1. following a type IMPLICIT NONE statement" }
+procedure() :: foo
+call foo()
+end subroutine sub9
+
+subroutine sub10
+implicit integer(a-z)
+implicit none ( external, type ) ! { dg-error "Type IMPLICIT NONE statement at .1. following an IMPLICIT statement" }
+procedure() :: foo
+call foo()
+end subroutine sub10
@@ -5,13 +5,13 @@ IMPLICIT NONE ! { dg-error "Duplicate" }
END
SUBROUTINE a
-IMPLICIT REAL(b-j) ! { dg-error "cannot follow" }
-implicit none ! { dg-error "cannot follow" }
+IMPLICIT REAL(b-j)
+implicit none ! { dg-error "Type IMPLICIT NONE statement at .1. following an IMPLICIT statement" }
END SUBROUTINE a
subroutine b
implicit none
-implicit real(g-k) ! { dg-error "Cannot specify" }
+implicit real(g-k) ! { dg-error "IMPLICIT statement at .1. following a type IMPLICIT NONE statement" }
end subroutine b
subroutine c