===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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.
===================================================================
@@ -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);
===================================================================
@@ -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
===================================================================
@@ -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 --
-----------------
===================================================================
@@ -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.
===================================================================
@@ -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);
===================================================================
@@ -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))) =
===================================================================
@@ -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.
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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
===================================================================
@@ -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;