From patchwork Tue Sep 10 15:05:48 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 273904 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 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client did not present a certificate) by ozlabs.org (Postfix) with ESMTPS id 1ABA72C00C2 for ; Wed, 11 Sep 2013 01:06:28 +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:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=os1zD12Y0am3fwviRu+2kiSlq5dN0d1N7gl4DWMwftp2paiR5Y vXeoc7UKtYtoo8ieyZK9hA6lQklpDbom4VZaLbljbaYr3nZUSbZvAPwmvF3pYko8 k6zM0JHH+SlAcwoLa4yujY3v+KF0X7QhBf+5vFlw7l/0tEtRnirWo2SHg= 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:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=5osZfkbteL1jMZGK5u0R6Te2dv8=; b=DJxQvVov9O3yYLRx/2Qy /FiMpTXtG2/XcQMHQ1w/ZUJ0jA8ugv54RGikr/sJNMBZ/h+bovClInckFEr3dHNa nT6PpNaxy4XT4NK8p2HJ4sIjOKetYihJvFoMCrz4sD69ZHQcdXjMTCq//LQohwE2 EFm/ve3ClZIGvoDTY2kkLjY= Received: (qmail 3796 invoked by alias); 10 Sep 2013 15:06:12 -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 3733 invoked by uid 89); 10 Sep 2013 15:06:11 -0000 Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Tue, 10 Sep 2013 15:06:11 +0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.6 required=5.0 tests=BAYES_50, RDNS_NONE autolearn=no version=3.3.2 X-HELO: rock.gnat.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id AB72611656C; Tue, 10 Sep 2013 11:06:00 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id xvKKKiWuUiVh; Tue, 10 Sep 2013 11:06:00 -0400 (EDT) Received: from kwai.gnat.com (unknown [IPv6:2620:20:4000:0:a6ba:dbff:fe26:1f63]) by rock.gnat.com (Postfix) with ESMTP id 8DEFD11631F; Tue, 10 Sep 2013 11:06:00 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id C81423FB31; Tue, 10 Sep 2013 11:05:48 -0400 (EDT) Date: Tue, 10 Sep 2013 11:05:48 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Missing aspect specifications on bodies, renamings and stubs Message-ID: <20130910150548.GA22107@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) This patch allows the compiler to parse and analyze aspect specifications that apply to package bodies, protected bodies, task bodies, [generic] renaming declarations, and body stubs. ------------ -- Source -- ------------ -- bodies.adb package body Bodies with Warnings => On is protected body Prot_Typ with Warnings => On is entry E when True is begin null; end E; end Prot_Typ; task body Task_Typ with Warnings => On is begin accept E; end Task_Typ; end Bodies; -- bodies.ads package Bodies is protected type Prot_Typ is entry E; end Prot_Typ; task type Task_Typ is entry E; end Task_Typ; end Bodies; -- declarations.ads package Declarations is -- Entry declaration task type Task_Typ is entry Task_Entry with Warnings => On; end Task_Typ; -- Exception declaration Exc : exception with Warnings => On; -- Object declaration Obj_1 : Integer with Warnings => On; Obj_2 : Integer := 123 with Warnings => On; Obj_3 : aliased Integer with Warnings => On; Obj_4 : aliased constant Integer := 123 with Warnings => On; Obj_5 : access Integer := null with Warnings => On; Obj_6 : not null access Integer := Obj_3'Access with Warnings => On; type Array_Typ is array (Integer range 1 .. 10) of Boolean; Obj_7 : Array_Typ := (others => False) with Warnings => On; -- Private extension declaration type Root is tagged null record; type Priv_Ext is new Root with private with Warnings => On; -- Private type declaration type Priv_Typ is private with Warnings => On; private type Priv_Ext is new Root with null record; type Priv_Typ is null record; end Declarations; -- expressions.ads package Expressions is -- Expression function function Func (Flag : Boolean) return Integer is (if Flag then 123 else 456) with Warnings => On; end Expressions; -- generics.ads package Generics is generic type Any is private; function Gen_Func return Any with Warnings => On; generic type Any is private; package Gen_Pack is end Gen_Pack; generic type Any is private; procedure Gen_Proc with Warnings => On; end Generics; -- instances.ads with Generics; use Generics; package Instances is -- Generic function instantiation function Func_Inst is new Gen_Func (Integer) with Warnings => On; -- Generic package instantiation package Pack_Inst is new Gen_Pack (Integer) with Warnings => On; -- Generic procedure instantiation procedure Proc_Inst is new Gen_Proc (Integer) with Warnings => On; end Instances; -- renamings.ads with Declarations; use Declarations; with Generics; use Generics; package Renamings is -- Exception renaming Exc_Ren : exception renames Exc with Warnings => On; -- Generic renaming declaration generic function Gen_Func_Ren renames Gen_Func with Warnings => On; generic package Gen_Pack_Ren renames Gen_Pack with Warnings => On; generic procedure Gen_Proc_Ren renames Gen_Proc with Warnings => On; -- Object renaming declaration Obj : aliased Integer; Obj_Ren : Integer renames Obj with Warnings => On; Obj_Ptr : not null access Integer := Obj'Access; Obj_Ptr_Ren_1 : access Integer renames Obj_Ptr with Warnings => On; Obj_Ptr_Ren_2 : not null access Integer renames Obj_Ptr with Warnings => On; -- Package renaming declaration package Decl_Ren renames Declarations with Warnings => On; -- Subprogram renaming declaration function Func return Integer; procedure Proc; function Func_Ren return Integer renames Func with Warnings => On; procedure Proc_ren renames Proc with Warnings => On; end Renamings; -- stubs.adb package body Stubs is -- Package stub package body Pack is separate with Warnings => On; -- Protected stub protected body Prot_Typ is separate with Warnings => On; -- Subprogram stub function Func return Integer is separate with Warnings => On; procedure Proc is separate with Warnings => On; -- Task stub task body Task_Typ is separate with Warnings => On; end Stubs; -- stubs.ads package Stubs is package Pack is procedure Dummy; end Pack; protected type Prot_Typ is entry E; end Prot_Typ; function Func return Integer; procedure Proc; task type Task_Typ is entry E; end Task_Typ; end Stubs; -- stubs-func.adb separate (Stubs) function Func return Integer is begin return 0; end Func; -- stubs-pack.adb separate (Stubs) package body Pack is procedure Dummy is begin null; end Dummy; end Pack; -- stubs-proc.adb separate (Stubs) procedure Proc is begin null; end Proc; -- stubs-prot_typ.adb separate (Stubs) protected body Prot_Typ is entry E when True is begin null; end E; end Prot_Typ; -- stubs-task_typ.adb separate (Stubs) task body Task_Typ is begin accept E; end Task_Typ; ---------------------------- -- Compilation and output -- ---------------------------- $ gcc -c -gnat12 bodies.adb $ gcc -c -gnatc -gnat12 declarations.ads $ gcc -c -gnatc -gnat12 expressions.ads $ gcc -c -gnatc -gnat12 instances.ads $ gcc -c -gnatc -gnat12 renamings.ads $ gcc -c -gnat12 stubs.adb bodies.adb:2:04: warning: user-defined aspects on protected bodies are not supported bodies.adb:6:04: warning: user-defined aspects on task bodies are not supported stubs-prot_typ.adb:3:01: warning: user-defined aspects on protected bodies are not supported stubs-task_typ.adb:3:01: warning: user-defined aspects on task bodies are not supported Tested on x86_64-pc-linux-gnu, committed on trunk 2013-09-10 Hristian Kirtchev * aspects.adb: Add entries in the Has_Aspect_Specifications_Flag table for package body and body stubs. (Move_Or_Merge_Aspects): New routine. (Remove_Aspects): New routine. * aspects.ads (Move_Aspects): Update comment on usage. (Move_Or_Merge_Aspects): New routine. (Remove_Aspects): New routine. * par-ch3.adb: Update the grammar of private_type_declaration, private_extension_declaration, object_renaming_declaration, and exception_renaming_declaration. (P_Subprogram): Parse the aspect specifications that apply to a body stub. * par-ch6.adb: Update the grammar of subprogram_body_stub and generic_instantiation. * par-ch7.adb: Update the grammar of package_declaration, package_specification, package_body, package_renaming_declaration, package_body_stub. (P_Package): Parse the aspect specifications that apply to a body, a body stub and package renaming. * par-ch9.adb: Update the grammar of entry_declaration, protected_body, protected_body_stub, task_body, and task_body_stub. (P_Protected): Add local variable Aspect_Sloc. Add local constant Dummy_Node. Parse the aspect specifications that apply to a protected body and a protected body stub. (P_Task): Add local variable Aspect_Sloc. Add local constant Dummy_Node. Parse the aspect specifications that apply to a task body and a task body stub. * par-ch12.adb: Update the grammar of generic_renaming_declaration. (P_Generic): Parse the aspect specifications that apply to a generic renaming. * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not emit an error when analyzing aspects that apply to a body stub. Such aspects are relocated to the proper body. * sem_ch7.adb (Analyze_Package_Body_Helper): Analyze the aspect specifications that apply to a body. * sem_ch9.adb (Analyze_Protected_Body): Warn about user-defined aspects not being supported on protected bodies. Remove the aspect specifications. (Analyze_Single_Protected_Declaration): Analyze the aspects that apply to a single protected declaration. (Analyze_Task_Body): Warn about user-defined aspects not being supported on task bodies. Remove the aspect specifications. * sem_ch10.adb: Add with and use clause for Aspects. (Analyze_Package_Body_Stub): Propagate the aspect specifications from the stub to the proper body. * sem_ch13.adb (Analyze_Aspect_Specifications): Insert the corresponding pragma of an aspect that applies to a body in the declarations of the body. * sinfo.ads: Update the gramma of expression_function, private_type_declaration, private_extension_declaration, object_renaming_declaration, exception_renaming_declaration, package_renaming_declaration, subprogram_renaming_declaration, generic_renaming_declaration, entry_declaration, subprogram_body_stub, package_body_stub, task_body_stub, generic_subprogram_declaration. Index: par-ch9.adb =================================================================== --- par-ch9.adb (revision 202451) +++ par-ch9.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -61,14 +61,15 @@ -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- TASK_BODY ::= - -- task body DEFINING_IDENTIFIER is + -- task body DEFINING_IDENTIFIER [ASPECT_SPECIFICATIONS] is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [task_IDENTIFIER] -- TASK_BODY_STUB ::= - -- task body DEFINING_IDENTIFIER is separate; + -- task body DEFINING_IDENTIFIER is separate + -- [ASPECT_SPECIFICATIONS]; -- This routine scans out a task declaration, task body, or task stub @@ -78,10 +79,16 @@ -- Error recovery: cannot raise Error_Resync function P_Task return Node_Id is - Name_Node : Node_Id; - Task_Node : Node_Id; - Task_Sloc : Source_Ptr; + Aspect_Sloc : Source_Ptr; + Name_Node : Node_Id; + Task_Node : Node_Id; + Task_Sloc : Source_Ptr; + Dummy_Node : constant Node_Id := New_Node (N_Task_Body, Token_Ptr); + -- Placeholder node used to hold legal or prematurely declared aspect + -- specifications. Depending on the context, the aspect specifications + -- may be moved to a new node. + begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; @@ -100,6 +107,11 @@ Discard_Junk_List (P_Known_Discriminant_Part_Opt); end if; + if Aspect_Specifications_Present then + Aspect_Sloc := Token_Ptr; + P_Aspect_Specifications (Dummy_Node, Semicolon => False); + end if; + TF_Is; -- Task stub @@ -108,6 +120,14 @@ Scan; -- past SEPARATE Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc); Set_Defining_Identifier (Task_Node, Name_Node); + + if Has_Aspects (Dummy_Node) then + Error_Msg + ("aspect specifications must come after SEPARATE", + Aspect_Sloc); + end if; + + P_Aspect_Specifications (Task_Node, Semicolon => False); TF_Semicolon; Pop_Scope_Stack; -- remove unused entry @@ -116,6 +136,13 @@ else Task_Node := New_Node (N_Task_Body, Task_Sloc); Set_Defining_Identifier (Task_Node, Name_Node); + + -- Move the aspect specifications to the body node + + if Has_Aspects (Dummy_Node) then + Move_Aspects (From => Dummy_Node, To => Task_Node); + end if; + Parse_Decls_Begin_End (Task_Node); end if; @@ -367,12 +394,15 @@ -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; -- PROTECTED_BODY ::= - -- protected body DEFINING_IDENTIFIER is + -- protected body DEFINING_IDENTIFIER + -- [ASPECT_SPECIFICATIONS] + -- is -- {PROTECTED_OPERATION_ITEM} -- end [protected_IDENTIFIER]; -- PROTECTED_BODY_STUB ::= - -- protected body DEFINING_IDENTIFIER is separate; + -- protected body DEFINING_IDENTIFIER is separate + -- [ASPECT_SPECIFICATIONS]; -- This routine scans out a protected declaration, protected body -- or a protected stub. @@ -383,11 +413,17 @@ -- Error recovery: cannot raise Error_Resync function P_Protected return Node_Id is + Aspect_Sloc : Source_Ptr; Name_Node : Node_Id; Protected_Node : Node_Id; Protected_Sloc : Source_Ptr; Scan_State : Saved_Scan_State; + Dummy_Node : constant Node_Id := New_Node (N_Protected_Body, Token_Ptr); + -- Placeholder node used to hold legal or prematurely declared aspect + -- specifications. Depending on the context, the aspect specifications + -- may be moved to a new node. + begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; @@ -405,14 +441,28 @@ Discard_Junk_List (P_Known_Discriminant_Part_Opt); end if; + if Aspect_Specifications_Present then + Aspect_Sloc := Token_Ptr; + P_Aspect_Specifications (Dummy_Node, Semicolon => False); + end if; + TF_Is; -- Protected stub if Token = Tok_Separate then Scan; -- past SEPARATE + Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc); Set_Defining_Identifier (Protected_Node, Name_Node); + + if Has_Aspects (Dummy_Node) then + Error_Msg + ("aspect specifications must come after SEPARATE", + Aspect_Sloc); + end if; + + P_Aspect_Specifications (Protected_Node, Semicolon => False); TF_Semicolon; Pop_Scope_Stack; -- remove unused entry @@ -421,6 +471,8 @@ else Protected_Node := New_Node (N_Protected_Body, Protected_Sloc); Set_Defining_Identifier (Protected_Node, Name_Node); + + Move_Aspects (From => Dummy_Node, To => Protected_Node); Set_Declarations (Protected_Node, P_Protected_Operation_Items); End_Statements (Protected_Node); end if; @@ -800,8 +852,8 @@ -- ENTRY_DECLARATION ::= -- [OVERRIDING_INDICATOR] - -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)] - -- PARAMETER_PROFILE; + -- entry DEFINING_IDENTIFIER + -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE -- [ASPECT_SPECIFICATIONS]; -- The caller has checked that the initial token is ENTRY, NOT or Index: sinfo.ads =================================================================== --- sinfo.ads (revision 202459) +++ sinfo.ads (working copy) @@ -4775,7 +4775,8 @@ -- and put in its proper section when we know exactly where that is! -- EXPRESSION_FUNCTION ::= - -- FUNCTION SPECIFICATION IS (EXPRESSION); + -- FUNCTION SPECIFICATION IS (EXPRESSION) + -- [ASPECT_SPECIFICATIONS]; -- N_Expression_Function -- Sloc points to FUNCTION @@ -5010,7 +5011,8 @@ -- PRIVATE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] - -- is [[abstract] tagged] [limited] private; + -- is [[abstract] tagged] [limited] private + -- [ASPECT_SPECIFICATIONS]; -- Note: TAGGED is not permitted in Ada 83 mode @@ -5032,7 +5034,7 @@ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is -- [abstract] [limited | synchronized] -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] - -- with private; + -- with private [ASPECT_SPECIFICATIONS]; -- Note: LIMITED, and private extension declarations are not allowed -- in Ada 83 mode. @@ -5102,9 +5104,11 @@ -- OBJECT_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : - -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME; + -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER : - -- ACCESS_DEFINITION renames object_NAME; + -- ACCESS_DEFINITION renames object_NAME + -- [ASPECT_SPECIFICATIONS]; -- Note: Access_Definition is an optional field that gives support to -- Ada 2005 (AI-230). The parser generates nodes that have either the @@ -5124,7 +5128,8 @@ ----------------------------------------- -- EXCEPTION_RENAMING_DECLARATION ::= - -- DEFINING_IDENTIFIER : exception renames exception_NAME; + -- DEFINING_IDENTIFIER : exception renames exception_NAME + -- [ASPECT_SPECIFICATIONS]; -- N_Exception_Renaming_Declaration -- Sloc points to first identifier @@ -5136,7 +5141,8 @@ --------------------------------------- -- PACKAGE_RENAMING_DECLARATION ::= - -- package DEFINING_PROGRAM_UNIT_NAME renames package_NAME; + -- package DEFINING_PROGRAM_UNIT_NAME renames package_NAME + -- [ASPECT_SPECIFICATIONS]; -- N_Package_Renaming_Declaration -- Sloc points to PACKAGE @@ -5149,7 +5155,8 @@ ------------------------------------------ -- SUBPROGRAM_RENAMING_DECLARATION ::= - -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME; + -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME + -- [ASPECT_SPECIFICATIONS]; -- N_Subprogram_Renaming_Declaration -- Sloc points to RENAMES @@ -5167,10 +5174,13 @@ -- GENERIC_RENAMING_DECLARATION ::= -- generic package DEFINING_PROGRAM_UNIT_NAME -- renames generic_package_NAME + -- [ASPECT_SPECIFICATIONS]; -- | generic procedure DEFINING_PROGRAM_UNIT_NAME -- renames generic_procedure_NAME + -- [ASPECT_SPECIFICATIONS]; -- | generic function DEFINING_PROGRAM_UNIT_NAME -- renames generic_function_NAME + -- [ASPECT_SPECIFICATIONS]; -- N_Generic_Package_Renaming_Declaration -- Sloc points to GENERIC @@ -5384,7 +5394,8 @@ -- ENTRY_DECLARATION ::= -- [[not] overriding] -- entry DEFINING_IDENTIFIER - -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE; + -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE + -- [ASPECT_SPECIFICATIONS]; -- N_Entry_Declaration -- Sloc points to ENTRY @@ -5985,7 +5996,8 @@ ---------------------------------- -- SUBPROGRAM_BODY_STUB ::= - -- SUBPROGRAM_SPECIFICATION is separate; + -- SUBPROGRAM_SPECIFICATION is separate + -- [ASPECT_SPECIFICATION]; -- N_Subprogram_Body_Stub -- Sloc points to FUNCTION or PROCEDURE @@ -5998,7 +6010,8 @@ ------------------------------- -- PACKAGE_BODY_STUB ::= - -- package body DEFINING_IDENTIFIER is separate; + -- package body DEFINING_IDENTIFIER is separate + -- [ASPECT_SPECIFICATION]; -- N_Package_Body_Stub -- Sloc points to PACKAGE @@ -6011,7 +6024,8 @@ ---------------------------- -- TASK_BODY_STUB ::= - -- task body DEFINING_IDENTIFIER is separate; + -- task body DEFINING_IDENTIFIER is separate + -- [ASPECT_SPECIFICATION]; -- N_Task_Body_Stub -- Sloc points to TASK @@ -6024,7 +6038,8 @@ --------------------------------- -- PROTECTED_BODY_STUB ::= - -- protected body DEFINING_IDENTIFIER is separate; + -- protected body DEFINING_IDENTIFIER is separate + -- [ASPECT_SPECIFICATION]; -- Note: protected body stubs are not allowed in Ada 83 mode @@ -6225,7 +6240,8 @@ ------------------------------------------ -- GENERIC_SUBPROGRAM_DECLARATION ::= - -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION; + -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; -- Note: Generic_Formal_Declarations can include pragmas Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 202451) +++ sem_ch7.adb (working copy) @@ -219,11 +219,15 @@ -- the later is never used for name resolution. In this fashion there -- is only one visible entity that denotes the package. - -- Set Body_Id. Note that this Will be reset to point to the generic + -- Set Body_Id. Note that this will be reset to point to the generic -- copy later on in the generic case. Body_Id := Defining_Entity (N); + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Body_Id); + end if; + if Present (Corresponding_Spec (N)) then -- Body is body of package instantiation. Corresponding spec has @@ -766,7 +770,7 @@ -- True when this package declaration is not a nested declaration begin - -- Analye aspect specifications immediately, since we need to recognize + -- Analyze aspect specifications immediately, since we need to recognize -- things like Pure early enough to diagnose violations during analysis. if Has_Aspects (N) then Index: sem_ch9.adb =================================================================== --- sem_ch9.adb (revision 202451) +++ sem_ch9.adb (working copy) @@ -1734,6 +1734,22 @@ Set_Ekind (Body_Id, E_Protected_Body); Spec_Id := Find_Concurrent_Spec (Body_Id); + -- Protected bodies are currently removed by the expander. Since there + -- are no language-defined aspects that apply to a protected body, it is + -- not worth changing the whole expansion to accomodate user-defined + -- aspects. Plus we cannot possibly known the semantics of user-defined + -- aspects in order to plan ahead. + + if Has_Aspects (N) then + Error_Msg_N + ("?user-defined aspects on protected bodies are not supported", N); + + -- The aspects are removed for now to prevent cascading errors down + -- stream. + + Remove_Aspects (N); + end if; + if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then @@ -2606,6 +2622,10 @@ -- disastrous result. Analyze_Protected_Type_Declaration (N); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; end Analyze_Single_Protected_Declaration; ------------------------------------- @@ -2703,6 +2723,22 @@ Set_Scope (Body_Id, Current_Scope); Spec_Id := Find_Concurrent_Spec (Body_Id); + -- Task bodies are transformed into a subprogram spec and body pair by + -- the expander. Since there are no language-defined aspects that apply + -- to a task body, it is not worth changing the whole expansion to + -- accomodate user-defined aspects. Plus we cannot possibly known the + -- semantics of user-defined aspects in order to plan ahead. + + if Has_Aspects (N) then + Error_Msg_N + ("?user-defined aspects on task bodies are not supported", N); + + -- The aspects are removed for now to prevent cascading errors down + -- stream. + + Remove_Aspects (N); + end if; + -- The spec is either a task type declaration, or a single task -- declaration for which we have created an anonymous type. Index: sem_ch10.adb =================================================================== --- sem_ch10.adb (revision 202451) +++ sem_ch10.adb (working copy) @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; @@ -1555,8 +1556,8 @@ ------------------------------- procedure Analyze_Package_Body_Stub (N : Node_Id) is - Id : constant Entity_Id := Defining_Identifier (N); - Nam : Entity_Id; + Id : constant Entity_Id := Defining_Identifier (N); + Nam : Entity_Id; begin -- The package declaration must be in the current declarative part @@ -1844,6 +1845,12 @@ SCO_Record (Unum); end if; + -- Propagate any aspect specifications associated with + -- with the stub to the proper body. + + Move_Or_Merge_Aspects + (From => N, To => Proper_Body (Unit (Comp_Unit))); + -- Analyze the unit if semantics active if not Fatal_Error (Unum) or else Try_Semantics then @@ -2327,8 +2334,8 @@ ---------------------------- procedure Analyze_Task_Body_Stub (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); - Loc : constant Source_Ptr := Sloc (N); begin Check_Stub_Level (N); Index: par-ch6.adb =================================================================== --- par-ch6.adb (revision 202451) +++ par-ch6.adb (working copy) @@ -161,13 +161,16 @@ -- [ASPECT_SPECIFICATIONS]; -- SUBPROGRAM_BODY_STUB ::= - -- SUBPROGRAM_SPECIFICATION is separate; + -- SUBPROGRAM_SPECIFICATION is separate + -- [ASPECT_SPECIFICATIONS]; -- GENERIC_INSTANTIATION ::= -- procedure DEFINING_PROGRAM_UNIT_NAME is - -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; + -- new generic_procedure_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; -- | function DEFINING_DESIGNATOR is - -- new generic_function_NAME [GENERIC_ACTUAL_PART]; + -- new generic_function_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; -- NULL_PROCEDURE_DECLARATION ::= -- SUBPROGRAM_SPECIFICATION is null; @@ -394,8 +397,8 @@ if Token = Tok_Identifier and then not Token_Is_At_Start_Of_Line then - T_Left_Paren; -- to generate message - Fpart_List := P_Formal_Part; + T_Left_Paren; -- to generate message + Fpart_List := P_Formal_Part; -- Otherwise scan out an optional formal part in the usual manner @@ -681,21 +684,21 @@ Sloc (Name_Node)); end if; + Scan; -- past SEPARATE + Stub_Node := New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node)); Set_Specification (Stub_Node, Specification_Node); - -- The specification has been parsed as part of a subprogram - -- declaration, and aspects have already been collected. - if Is_Non_Empty_List (Aspects) then - Set_Parent (Aspects, Stub_Node); - Set_Aspect_Specifications (Stub_Node, Aspects); + Error_Msg + ("aspect specifications must come after SEPARATE", + Sloc (First (Aspects))); end if; - Scan; -- past SEPARATE + P_Aspect_Specifications (Stub_Node, Semicolon => False); + TF_Semicolon; Pop_Scope_Stack; - TF_Semicolon; return Stub_Node; -- Subprogram body or expression function case Index: aspects.adb =================================================================== --- aspects.adb (revision 202451) +++ aspects.adb (working copy) @@ -271,6 +271,31 @@ end if; end Move_Aspects; + --------------------------- + -- Move_Or_Merge_Aspects -- + --------------------------- + + procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is + begin + if Has_Aspects (From) then + + -- Merge the aspects of From into To. Make sure that From has no + -- aspects after the merge takes place. + + if Has_Aspects (To) then + Append_List + (List => Aspect_Specifications (From), + To => Aspect_Specifications (To)); + Remove_Aspects (From); + + -- Otherwise simply move the aspects + + else + Move_Aspects (From => From, To => To); + end if; + end if; + end Move_Or_Merge_Aspects; + ----------------------------------- -- Permits_Aspect_Specifications -- ----------------------------------- @@ -294,6 +319,8 @@ N_Generic_Subprogram_Declaration => True, N_Object_Declaration => True, N_Object_Renaming_Declaration => True, + N_Package_Body => True, + N_Package_Body_Stub => True, N_Package_Declaration => True, N_Package_Instantiation => True, N_Package_Specification => True, @@ -302,6 +329,7 @@ N_Private_Type_Declaration => True, N_Procedure_Instantiation => True, N_Protected_Body => True, + N_Protected_Body_Stub => True, N_Protected_Type_Declaration => True, N_Single_Protected_Declaration => True, N_Single_Task_Declaration => True, @@ -311,6 +339,7 @@ N_Subprogram_Body_Stub => True, N_Subtype_Declaration => True, N_Task_Body => True, + N_Task_Body_Stub => True, N_Task_Type_Declaration => True, others => False); @@ -319,6 +348,18 @@ return Has_Aspect_Specifications_Flag (Nkind (N)); end Permits_Aspect_Specifications; + -------------------- + -- Remove_Aspects -- + -------------------- + + procedure Remove_Aspects (N : Node_Id) is + begin + if Has_Aspects (N) then + Aspect_Specifications_Hash_Table.Remove (N); + Set_Has_Aspects (N, False); + end if; + end Remove_Aspects; + ----------------- -- Same_Aspect -- ----------------- Index: aspects.ads =================================================================== --- aspects.ads (revision 202458) +++ aspects.ads (working copy) @@ -698,16 +698,24 @@ -- Determine whether entity Id has aspect A procedure Move_Aspects (From : Node_Id; To : Node_Id); - -- Moves aspects from 'From' node to 'To' node. Has_Aspects (To) must be - -- False on entry. If Has_Aspects (From) is False, the call has no effect. - -- Otherwise the aspects are moved and on return Has_Aspects (To) is True, - -- and Has_Aspects (From) is False. + -- Relocate the aspect specifications of node From to node To. On entry it + -- is assumed that To does not have aspect specifications. If From has no + -- aspects, the routine has no effect. + procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id); + -- Relocate the aspect specifications of node From to node To. If To has + -- aspects, the aspects of From are added to the aspects of To. If From has + -- no aspects, the routine has no effect. + function Permits_Aspect_Specifications (N : Node_Id) return Boolean; -- Returns True if the node N is a declaration node that permits aspect -- specifications in the grammar. It is possible for other nodes to have -- aspect specifications as a result of Rewrite or Replace calls. + procedure Remove_Aspects (N : Node_Id); + -- Delete the aspect specifications associated with node N. If the node has + -- no aspects, the routine has no effect. + function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean; -- Returns True if A1 and A2 are (essentially) the same aspect. This is not -- a simple equality test because e.g. Post and Postcondition are the same. Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 202451) +++ sem_ch6.adb (working copy) @@ -2680,7 +2680,14 @@ -- a corresponding spec, but for which there may also be a spec_id. if Has_Aspects (N) then - if Present (Spec_Id) then + + -- Aspects that apply to a body stub are relocated to the proper + -- body. Do not emit an error in this case. + + if Present (Spec_Id) + and then Nkind (N) not in N_Body_Stub + and then Nkind (Parent (N)) /= N_Subunit + then Error_Msg_N ("aspect specifications must appear in subprogram declaration", N); Index: par-ch12.adb =================================================================== --- par-ch12.adb (revision 202451) +++ par-ch12.adb (working copy) @@ -74,10 +74,13 @@ -- GENERIC_RENAMING_DECLARATION ::= -- generic package DEFINING_PROGRAM_UNIT_NAME -- renames generic_package_NAME + -- [ASPECT_SPECIFICATIONS]; -- | generic procedure DEFINING_PROGRAM_UNIT_NAME -- renames generic_procedure_NAME + -- [ASPECT_SPECIFICATIONS]; -- | generic function DEFINING_PROGRAM_UNIT_NAME -- renames generic_function_NAME + -- [ASPECT_SPECIFICATIONS]; -- GENERIC_FORMAL_PARAMETER_DECLARATION ::= -- FORMAL_OBJECT_DECLARATION @@ -140,6 +143,8 @@ Scan; -- past RENAMES Set_Defining_Unit_Name (Decl_Node, Def_Unit); Set_Name (Decl_Node, P_Name); + + P_Aspect_Specifications (Decl_Node, Semicolon => False); TF_Semicolon; return Decl_Node; end if; @@ -211,7 +216,6 @@ else Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); - Set_Specification (Gen_Decl, P_Subprogram_Specification); if Nkind (Defining_Unit_Name (Specification (Gen_Decl))) = Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 202459) +++ sem_ch13.adb (working copy) @@ -1781,7 +1781,6 @@ -- Warnings when Aspect_Warnings => - Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Expr), @@ -2434,6 +2433,18 @@ Set_Has_Delayed_Aspects (E); Record_Rep_Item (E, Aspect); + -- When delay is not required and the context is a package body, + -- insert the pragma in the declarations of the body. + + elsif Nkind (N) = N_Package_Body then + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + -- The pragma is added before source declarations + + Prepend_To (Declarations (N), Aitem); + -- When delay is not required and the context is not a compilation -- unit, we simply insert the pragma/attribute definition clause -- in sequence. Index: par-ch3.adb =================================================================== --- par-ch3.adb (revision 202451) +++ par-ch3.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -275,13 +275,14 @@ -- PRIVATE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] - -- is [abstract] [tagged] [limited] private; + -- is [abstract] [tagged] [limited] private + -- [ASPECT_SPECIFICATIONS]; -- PRIVATE_EXTENSION_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is -- [abstract] [limited | synchronized] -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] - -- with private; + -- with private [ASPECT_SPECIFICATIONS]; -- TYPE_DEFINITION ::= -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION @@ -1277,12 +1278,15 @@ -- OBJECT_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : - -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME; + -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER : - -- ACCESS_DEFINITION renames object_NAME; + -- ACCESS_DEFINITION renames object_NAME + -- [ASPECT_SPECIFICATIONS]; -- EXCEPTION_RENAMING_DECLARATION ::= - -- DEFINING_IDENTIFIER : exception renames exception_NAME; + -- DEFINING_IDENTIFIER : exception renames exception_NAME + -- [ASPECT_SPECIFICATIONS]; -- EXCEPTION_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : exception @@ -1669,15 +1673,19 @@ -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] - -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; + -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] - -- ACCESS_DEFINITION [:= EXPRESSION]; + -- ACCESS_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- OBJECT_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : - -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME; + -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER : - -- ACCESS_DEFINITION renames object_NAME; + -- ACCESS_DEFINITION renames object_NAME + -- [ASPECT_SPECIFICATIONS]; Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423) @@ -1893,7 +1901,7 @@ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is -- [abstract] [limited | synchronized] -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] - -- with private; + -- with private [ASPECT_SPECIFICATIONS]; -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION Index: par-ch7.adb =================================================================== --- par-ch7.adb (revision 202451) +++ par-ch7.adb (working copy) @@ -38,28 +38,33 @@ -- renaming declaration or generic instantiation starting with PACKAGE -- PACKAGE_DECLARATION ::= - -- PACKAGE_SPECIFICATION - -- [ASPECT_SPECIFICATIONS]; + -- PACKAGE_SPECIFICATION; -- PACKAGE_SPECIFICATION ::= - -- package DEFINING_PROGRAM_UNIT_NAME is + -- package DEFINING_PROGRAM_UNIT_NAME + -- [ASPECT_SPECIFICATIONS] + -- is -- {BASIC_DECLARATIVE_ITEM} -- [private -- {BASIC_DECLARATIVE_ITEM}] -- end [[PARENT_UNIT_NAME .] IDENTIFIER] -- PACKAGE_BODY ::= - -- package body DEFINING_PROGRAM_UNIT_NAME is + -- package body DEFINING_PROGRAM_UNIT_NAME + -- [ASPECT_SPECIFICATIONS] + -- is -- DECLARATIVE_PART -- [begin -- HANDLED_SEQUENCE_OF_STATEMENTS] -- end [[PARENT_UNIT_NAME .] IDENTIFIER] -- PACKAGE_RENAMING_DECLARATION ::= - -- package DEFINING_IDENTIFIER renames package_NAME; + -- package DEFINING_IDENTIFIER renames package_NAME + -- [ASPECT_SPECIFICATIONS]; -- PACKAGE_BODY_STUB ::= - -- package body DEFINING_IDENTIFIER is separate; + -- package body DEFINING_IDENTIFIER is separate + -- [ASPECT_SPECIFICATIONS]; -- PACKAGE_INSTANTIATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is @@ -141,6 +146,12 @@ Scope.Table (Scope.Last).Sloc := Token_Ptr; Name_Node := P_Defining_Program_Unit_Name; Scope.Table (Scope.Last).Labl := Name_Node; + + if Aspect_Specifications_Present then + Aspect_Sloc := Token_Ptr; + P_Aspect_Specifications (Dummy_Node, Semicolon => False); + end if; + TF_Is; if Separate_Present then @@ -149,16 +160,30 @@ end if; Scan; -- past SEPARATE - TF_Semicolon; - Pop_Scope_Stack; Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc); Set_Defining_Identifier (Package_Node, Name_Node); + if Has_Aspects (Dummy_Node) then + Error_Msg + ("aspect specifications must come after SEPARATE", + Aspect_Sloc); + end if; + + P_Aspect_Specifications (Package_Node, Semicolon => False); + TF_Semicolon; + Pop_Scope_Stack; + else Package_Node := New_Node (N_Package_Body, Package_Sloc); Set_Defining_Unit_Name (Package_Node, Name_Node); + -- Move the aspect specifications to the body node + + if Has_Aspects (Dummy_Node) then + Move_Aspects (From => Dummy_Node, To => Package_Node); + end if; + -- In SPARK, a HIDE directive can be placed at the beginning of a -- package implementation, thus hiding the package body from SPARK -- tool-set. No violation of the SPARK restriction should be @@ -204,6 +229,7 @@ Set_Name (Package_Node, P_Qualified_Simple_Name); No_Constraint; + P_Aspect_Specifications (Package_Node, Semicolon => False); TF_Semicolon; Pop_Scope_Stack;