From patchwork Wed Oct 1 22:32:26 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 395697 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 30C2214016A for ; Thu, 2 Oct 2014 08:32:43 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=fkmGw7ZJya+6ls7fNDUGUrPGW4jNwRhS77dhFk31/IVc90 Bj5sOH0F7k4oISLn1ZmU+m0a/Ansfnl7yYBcvcpJ3Hv1QNOKnI/ShIx7+/5sR0Wo hFGrZ1voabQlhgaWgOYTmWARvc+LKWCma5PrF5VBYJpHZOpL5C1yZzQvKofnk= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=IQ/z29Xgdjnn+nCGfVVrw/bbcyU=; b=o5eN2xlwxCj3jPX7bJ5l 5tDi3FRfww3JSDbBZGk/uLjcI8QHCY7re7YmK/jGYOPuf2yxaQmB5Id9YbFHaYB/ XJo4yb3yH+4YuKCiW+5dnXIu/KSmQ324gQPZ6pTBEWq9nNTViwYZauHUsUG+bmu/ voPDhnZZi/SHl+3k40mXMVA= Received: (qmail 26258 invoked by alias); 1 Oct 2014 22:32:35 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 26239 invoked by uid 89); 1 Oct 2014 22:32:34 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.0 required=5.0 tests=AWL, BAYES_00 autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx01.qsc.de Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Wed, 01 Oct 2014 22:32:31 +0000 Received: from tux.net-b.de (port-92-194-55-197.dynamic.qsc.de [92.194.55.197]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mx01.qsc.de (Postfix) with ESMTPSA id 8D7113CBCB; Thu, 2 Oct 2014 00:32:27 +0200 (CEST) Message-ID: <542C80FA.3000306@net-b.de> Date: Thu, 02 Oct 2014 00:32:26 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:31.0) Gecko/20100101 Thunderbird/31.1.0 MIME-Version: 1.0 To: gfortran , gcc-patches Subject: [Fortran, Patch] Implement IMPLICIT NONE I don't want to implement Fortran 90's implicit none, which is of course already supported. However, I would like to implement as vendor extension: IMPLICIT NONE (external) which forces at that least an "external" or "procedure" is used or an explicit interface available, if one tries to invoke a procedure. Background for the change is my recent bug: internal co_broadcast call co_broadcasr(...) While I have implemented is as vendor extension (-std=gnu), of course, the syntax doesn't come out of the blue but is in the current Fortran 2015 draft (14-007r2): R563 implicit-stmt is IMPLICIT implicit-spec-list or IMPLICIT NONE [ ( [ implicit-none-spec-list ] ) ] R566 implicit-none-spec is EXTERNAL or TYPE Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 2014-10-02 Tobias Burnus gcc/fortran/ * 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. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 0e0364c..bbf35ce 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f1c78cc..f6f95f8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index f6233b7..1eb09ac 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 9165061..4539beb 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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 diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8e1d8b3..3f17152 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -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; diff --git a/gcc/testsuite/gfortran.dg/implicit_14.f90 b/gcc/testsuite/gfortran.dg/implicit_14.f90 new file mode 100644 index 0000000..5b1a3b6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implicit_14.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/implicit_15.f90 b/gcc/testsuite/gfortran.dg/implicit_15.f90 new file mode 100644 index 0000000..7924b42 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implicit_15.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/implicit_4.f90 b/gcc/testsuite/gfortran.dg/implicit_4.f90 index 2e871b0..9bf8d86 100644 --- a/gcc/testsuite/gfortran.dg/implicit_4.f90 +++ b/gcc/testsuite/gfortran.dg/implicit_4.f90 @@ -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