+2011-08-01 Robert Dewar <dewar@adacore.com>
+
+ * par-endh.adb: Minor reformatting.
+
+2011-08-01 Robert Dewar <dewar@adacore.com>
+
+ * aspects.ads, aspects.adb: Add aspects for library unit pragmas
+ (Pre_Post_Aspects): New subtype.
+ * par-ch12.adb (P_Generic): New syntax for aspects in packages
+ * par-ch13.adb (P_Aspect_Specifications): Add Semicolon parameter
+ * par-ch7.adb (P_Package): Remove Decl parameter
+ (P_Package): Handle new syntax for aspects (before IS)
+ * par-ch9.adb (P_Protected_Definition): Remove Decl parameter, handle
+ new aspect syntax
+ (P_Task_Definition): Remove Decl parameter, handle new aspect syntax
+ * par.adb (P_Aspect_Specifications): Add Semicolon parameter
+ (P_Package): Remove Decl parameter
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Handle library unit
+ aspects
+ * sem_ch7.adb (Analyze_Package_Declaration): Analyze new format aspect
+ specs
+ * sem_util.ads, sem_util.adb (Static_Boolean): New function
+ * sinfo.ads: Document new syntax for aspects in packages etc.
+ * sprint.adb: Handle new syntax of aspects before IS in package
+
+2011-08-01 Thomas Quinot <quinot@adacore.com>
+
+ * atree.ads: Minor reformatting.
+ * sem_prag.adb: Minor reformatting.
+
+2011-08-01 Robert Dewar <dewar@adacore.com>
+
+ * exp_util.adb (Insert_Actions): Fix error in handling Actions for
+ case expr alternative.
+
+2011-08-01 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb: Fix typo.
+
2011-08-01 Geert Bosch <bosch@adacore.com>
* sem_prag.adb (Check_No_Link_Name): New procedure.
N_Object_Declaration => True,
N_Package_Declaration => True,
N_Package_Instantiation => True,
+ N_Package_Specification => True,
N_Private_Extension_Declaration => True,
N_Private_Type_Declaration => True,
N_Procedure_Instantiation => True,
+ N_Protected_Body => True,
N_Protected_Type_Declaration => True,
N_Single_Protected_Declaration => True,
N_Single_Task_Declaration => True,
+ N_Subprogram_Body => True,
N_Subprogram_Declaration => True,
N_Subtype_Declaration => True,
+ N_Task_Body => True,
N_Task_Type_Declaration => True,
others => False);
-- Table used for Same_Aspect, maps aspect to canonical aspect
- Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id := (
- No_Aspect => No_Aspect,
+ Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
+ (No_Aspect => No_Aspect,
Aspect_Ada_2005 => Aspect_Ada_2005,
Aspect_Ada_2012 => Aspect_Ada_2005,
Aspect_Address => Aspect_Address,
Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
Aspect_Inline => Aspect_Inline,
Aspect_Inline_Always => Aspect_Inline,
+ Aspect_All_Calls_Remote => Aspect_All_Calls_Remote,
+ Aspect_Compiler_Unit => Aspect_Compiler_Unit,
+ Aspect_Elaborate_Body => Aspect_Elaborate_Body,
+ Aspect_Preelaborate => Aspect_Preelaborate,
+ Aspect_Preelaborate_05 => Aspect_Preelaborate_05,
+ Aspect_Pure => Aspect_Pure,
+ Aspect_Pure_05 => Aspect_Pure_05,
+ Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
+ Aspect_Remote_Types => Aspect_Remote_Types,
+ Aspect_Shared_Passive => Aspect_Shared_Passive,
+ Aspect_Universal_Data => Aspect_Universal_Data,
Aspect_Input => Aspect_Input,
Aspect_Invariant => Aspect_Invariant,
Aspect_Machine_Radix => Aspect_Machine_Radix,
Aspect_Warnings,
Aspect_Write,
+ -- The following aspects correspond to library unit pragmas
+
+ Aspect_All_Calls_Remote,
+ Aspect_Compiler_Unit, -- GNAT
+ Aspect_Elaborate_Body,
+ Aspect_Preelaborate,
+ Aspect_Preelaborate_05, -- GNAT
+ Aspect_Pure,
+ Aspect_Pure_05, -- GNAT
+ Aspect_Remote_Call_Interface,
+ Aspect_Remote_Types,
+ Aspect_Shared_Passive,
+ Aspect_Universal_Data, -- GNAT
+
-- Remaining aspects have a static boolean value that turns the aspect
-- on or off. They all correspond to pragmas, and the flag Aspect_Cancel
- -- is set on the pragma if the corresponding aspect is False.
+ -- is set on the pragma if the corresponding aspect is False. These are
+ -- also Boolean aspects as defined below.
Aspect_Ada_2005, -- GNAT
Aspect_Ada_2012, -- GNAT
Aspect_Post => True,
others => False);
+ -- The following subtype defines aspects corresponding to library unit
+ -- pragmas, these can only validly appear as aspects for library units,
+ -- and result in a corresponding pragma being inserted immediately after
+ -- the occurrence of the aspect.
+
+ subtype Library_Unit_Aspects is
+ Aspect_Id range Aspect_All_Calls_Remote .. Aspect_Universal_Data;
+
-- The following subtype defines aspects accepting an optional static
-- boolean parameter indicating if the aspect should be active or
-- cancelling. If the parameter is missing the effective value is True,
subtype Boolean_Aspects is
Aspect_Id range Aspect_Ada_2005 .. Aspect_Id'Last;
+ subtype Pre_Post_Aspects is
+ Aspect_Id range Aspect_Post .. Aspect_Precondition;
+
-- The following type is used for indicating allowed expression forms
type Aspect_Expression is
Aspect_Value_Size => Expression,
Aspect_Warnings => Name,
Aspect_Write => Name,
+
+ Library_Unit_Aspects => Optional,
Boolean_Aspects => Optional);
-----------------------------------------
(Name_Ada_2012, Aspect_Ada_2012),
(Name_Address, Aspect_Address),
(Name_Alignment, Aspect_Alignment),
+ (Name_All_Calls_Remote, Aspect_All_Calls_Remote),
(Name_Atomic, Aspect_Atomic),
(Name_Atomic_Components, Aspect_Atomic_Components),
(Name_Bit_Order, Aspect_Bit_Order),
+ (Name_Compiler_Unit, Aspect_Compiler_Unit),
(Name_Component_Size, Aspect_Component_Size),
- (Name_Dynamic_Predicate, Aspect_Dynamic_Predicate),
(Name_Discard_Names, Aspect_Discard_Names),
+ (Name_Dynamic_Predicate, Aspect_Dynamic_Predicate),
+ (Name_Elaborate_Body, Aspect_Elaborate_Body),
(Name_External_Tag, Aspect_External_Tag),
(Name_Favor_Top_Level, Aspect_Favor_Top_Level),
(Name_Inline, Aspect_Inline),
(Name_Precondition, Aspect_Precondition),
(Name_Predicate, Aspect_Predicate),
(Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization),
+ (Name_Preelaborate, Aspect_Preelaborate),
+ (Name_Preelaborate_05, Aspect_Preelaborate_05),
+ (Name_Pure, Aspect_Pure),
+ (Name_Pure_05, Aspect_Pure_05),
(Name_Pure_Function, Aspect_Pure_Function),
(Name_Read, Aspect_Read),
+ (Name_Remote_Call_Interface, Aspect_Remote_Call_Interface),
+ (Name_Remote_Types, Aspect_Remote_Types),
(Name_Shared, Aspect_Shared),
+ (Name_Shared_Passive, Aspect_Shared_Passive),
(Name_Size, Aspect_Size),
(Name_Static_Predicate, Aspect_Static_Predicate),
(Name_Storage_Pool, Aspect_Storage_Pool),
(Name_Type_Invariant, Aspect_Type_Invariant),
(Name_Unchecked_Union, Aspect_Unchecked_Union),
(Name_Universal_Aliasing, Aspect_Universal_Aliasing),
+ (Name_Universal_Data, Aspect_Universal_Data),
(Name_Unmodified, Aspect_Unmodified),
(Name_Unreferenced, Aspect_Unreferenced),
(Name_Unreferenced_Objects, Aspect_Unreferenced_Objects),
pragma Inline (Is_Rewrite_Insertion);
-- Tests whether the given node was marked using Mark_Rewrite_Insertion.
-- This is used in reconstructing the original tree (where such nodes are
- -- to be eliminated from the reconstructed tree).
+ -- to be eliminated).
procedure Rewrite (Old_Node, New_Node : Node_Id);
-- This is used when a complete subtree is to be replaced. Old_Node is the
package Unchecked_Access is
- -- Functions to allow interpretation of Union_Id values as Uint
- -- and Ureal values
+ -- Functions to allow interpretation of Union_Id values as Uint and
+ -- Ureal values
function To_Union is new Unchecked_Conversion (Uint, Union_Id);
function To_Union is new Unchecked_Conversion (Ureal, Union_Id);
function From_Union is new Unchecked_Conversion (Union_Id, Uint);
function From_Union is new Unchecked_Conversion (Union_Id, Ureal);
- -- Functions to fetch contents of indicated field. It is an error
- -- to attempt to read the value of a field which is not present.
+ -- Functions to fetch contents of indicated field. It is an error to
+ -- attempt to read the value of a field which is not present.
function Field1 (N : Node_Id) return Union_Id;
pragma Inline (Field1);
function Str3 (N : Node_Id) return String_Id;
pragma Inline (Str3);
- -- Note: the following Uintnn functions have a special test for
- -- the Field value being Empty. If an Empty value is found then
- -- Uint_0 is returned. This avoids the rather tricky requirement
- -- of initializing all Uint fields in nodes and entities.
+ -- Note: the following Uintnn functions have a special test for the
+ -- Field value being Empty. If an Empty value is found then Uint_0 is
+ -- returned. This avoids the rather tricky requirement of initializing
+ -- all Uint fields in nodes and entities.
function Uint2 (N : Node_Id) return Uint;
pragma Inline (Uint2);
procedure Set_Flag254 (N : Node_Id; Val : Boolean);
pragma Inline (Set_Flag254);
- -- The following versions of Set_Noden also set the parent
- -- pointer of the referenced node if it is non_Empty
+ -- The following versions of Set_Noden also set the parent pointer of
+ -- the referenced node if it is not Empty.
procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Node1_With_Parent);
pragma Inline (Set_Node5_With_Parent);
-- The following versions of Set_Listn also set the parent pointer of
- -- the referenced node if it is non_Empty. The procedures for List6
- -- to List12 can only be applied to nodes which have an extension.
+ -- the referenced node if it is not Empty.
procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id);
pragma Inline (Set_List1_With_Parent);
(Last (Actions (P)), Ins_Actions);
else
Set_Actions (P, Ins_Actions);
- Analyze_List (Then_Actions (P));
+ Analyze_List (Actions (P));
end if;
return;
if Token = Tok_Package then
Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc);
- Set_Specification (Gen_Decl, P_Package (Pf_Spcn, Gen_Decl));
+ Set_Specification (Gen_Decl, P_Package (Pf_Spcn));
else
Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc);
-- Error recovery: cannot raise Error_Resync
- procedure P_Aspect_Specifications (Decl : Node_Id) is
+ procedure P_Aspect_Specifications
+ (Decl : Node_Id;
+ Semicolon : Boolean := True)
+ is
Aspects : List_Id;
Aspect : Node_Id;
A_Id : Aspect_Id;
-- Check if aspect specification present
if not Aspect_Specifications_Present then
- TF_Semicolon;
+ if Semicolon then
+ TF_Semicolon;
+ end if;
+
return;
end if;
if Token /= Tok_Identifier then
Error_Msg_SC ("aspect identifier expected");
- Resync_Past_Semicolon;
+
+ if Semicolon then
+ Resync_Past_Semicolon;
+ end if;
+
return;
end if;
OK := False;
else
- Resync_Past_Semicolon;
+ if Semicolon then
+ Resync_Past_Semicolon;
+ end if;
+
return;
end if;
-- Test case of missing aspect definition
- if Token = Tok_Comma or else Token = Tok_Semicolon then
+ if Token = Tok_Comma
+ or else Token = Tok_Semicolon
+ or else (not Semicolon and then Token /= Tok_Arrow)
+ then
if Aspect_Argument (A_Id) /= Optional then
Error_Msg_Node_1 := Aspect;
Error_Msg_AP ("aspect& requires an aspect definition");
if Token = Tok_Comma then
Scan; -- past comma
+
+ -- Must be terminator character
+
else
- T_Semicolon;
+ if Semicolon then
+ T_Semicolon;
+ end if;
+
exit;
end if;
end if;
-- Error recovery: cannot raise Error_Resync
- function P_Package
- (Pf_Flags : Pf_Rec;
- Decl : Node_Id := Empty) return Node_Id
- is
+ function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
Package_Node : Node_Id;
Specification_Node : Node_Id;
Name_Node : Node_Id;
Package_Sloc : Source_Ptr;
+ Dummy_Node : constant Node_Id :=
+ New_Node (N_Package_Specification, Token_Ptr);
+ -- Dummy node to attach aspect specifications to until we properly
+ -- figure out where they eventually belong.
+
begin
Push_Scope_Stack;
Scope.Table (Scope.Last).Etyp := E_Name;
Parse_Decls_Begin_End (Package_Node);
end if;
- return Package_Node;
-
-- Cases other than Package_Body
else
No_Constraint;
TF_Semicolon;
Pop_Scope_Stack;
- return Package_Node;
+
+ -- Generic package instantiation or package declaration
else
+ P_Aspect_Specifications (Dummy_Node, Semicolon => False);
TF_Is;
-- Case of generic instantiation
Scan; -- past NEW
Package_Node :=
- New_Node (N_Package_Instantiation, Package_Sloc);
+ New_Node (N_Package_Instantiation, Package_Sloc);
Set_Defining_Unit_Name (Package_Node, Name_Node);
Set_Name (Package_Node, P_Qualified_Simple_Name);
Set_Generic_Associations
(Package_Node, P_Generic_Actual_Part_Opt);
- P_Aspect_Specifications (Package_Node);
+ P_Aspect_Specifications (Error);
Pop_Scope_Stack;
-- Case of package declaration or package specification
Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
end if;
- if Nkind (Package_Node) = N_Package_Declaration then
- End_Statements (Specification_Node, Package_Node);
- else
- End_Statements (Specification_Node, Decl);
- end if;
+ End_Statements (Specification_Node);
end if;
-
- return Package_Node;
end if;
end if;
+
+ Move_Aspects (From => Dummy_Node, To => Package_Node);
+ return Package_Node;
end P_Package;
------------------------------
function P_Entry_Body_Formal_Part return Node_Id;
function P_Entry_Declaration return Node_Id;
function P_Entry_Index_Specification return Node_Id;
+ function P_Protected_Definition return Node_Id;
function P_Protected_Operation_Declaration_Opt return Node_Id;
function P_Protected_Operation_Items return List_Id;
function P_Task_Items return List_Id;
-
- function P_Protected_Definition (Decl : Node_Id) return Node_Id;
- -- Parses protected definition and following aspect specifications if
- -- present. The argument is the declaration node to which the aspect
- -- specifications are to be attached.
-
- function P_Task_Definition (Decl : Node_Id) return Node_Id;
- -- Parses task definition and following aspect specifications if present.
- -- The argument is the declaration node to which the aspect specifications
- -- are to be attached.
+ function P_Task_Definition return Node_Id;
-----------------------------
-- 9.1 Task (also 10.1.3) --
-- TASK_TYPE_DECLARATION ::=
-- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- [is [new INTERFACE_LIST with] TASK_DEFINITION]
- -- [ASPECT_SPECIFICATIONS];
+ -- [ASPECT_SPECIFICATIONS]
+ -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
-- SINGLE_TASK_DECLARATION ::=
-- task DEFINING_IDENTIFIER
- -- [is [new INTERFACE_LIST with] TASK_DEFINITION]
- -- [ASPECT_SPECIFICATIONS];
+ -- [ASPECT_SPECIFICATIONS]
+ -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
-- TASK_BODY ::=
-- task body DEFINING_IDENTIFIER is
end if;
end if;
- -- If we have aspect definitions present here, then we do not have
- -- a task definition present.
+ -- Scan aspect specifications, don't eat the semicolon, since it
+ -- might not be there if we have an IS.
- if Aspect_Specifications_Present then
- P_Aspect_Specifications (Task_Node);
+ P_Aspect_Specifications (Task_Node, Semicolon => False);
-- Parse optional task definition. Note that P_Task_Definition scans
-- out the semicolon and possible aspect specifications as well as
-- the task definition itself.
- elsif Token = Tok_Semicolon then
+ if Token = Tok_Semicolon then
- -- A little check, if the next token after semicolon is
- -- Entry, then surely the semicolon should really be IS
+ -- A little check, if the next token after semicolon is Entry,
+ -- then surely the semicolon should really be IS
Scan; -- past semicolon
if Token = Tok_Entry then
Error_Msg_SP -- CODEFIX
("|"";"" should be IS");
- Set_Task_Definition (Task_Node, P_Task_Definition (Task_Node));
+ Set_Task_Definition (Task_Node, P_Task_Definition);
else
Pop_Scope_Stack; -- Remove unused entry
end if;
end if;
end if;
- Set_Task_Definition (Task_Node, P_Task_Definition (Task_Node));
+ Set_Task_Definition (Task_Node, P_Task_Definition);
end if;
return Task_Node;
-- Error recovery: cannot raise Error_Resync
- function P_Task_Definition (Decl : Node_Id) return Node_Id is
+ function P_Task_Definition return Node_Id is
Def_Node : Node_Id;
begin
end loop;
end if;
- End_Statements (Def_Node, Decl);
+ End_Statements (Def_Node);
return Def_Node;
end P_Task_Definition;
-- PROTECTED_TYPE_DECLARATION ::=
-- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION
- -- [ASPECT_SPECIFICATIONS];
+ -- [ASPECT_SPECIFICATIONS]
+ -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- SINGLE_PROTECTED_DECLARATION ::=
-- protected DEFINING_IDENTIFIER
+ -- [ASPECT_SPECIFICATIONS]
-- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
- -- [ASPECT_SPECIFICATIONS];
-- PROTECTED_BODY ::=
-- protected body DEFINING_IDENTIFIER is
Scope.Table (Scope.Last).Labl := Name_Node;
end if;
+ P_Aspect_Specifications (Protected_Node, Semicolon => False);
+
-- Check for semicolon not followed by IS, this is something like
-- protected type r;
Scan; -- past WITH
end if;
- Set_Protected_Definition
- (Protected_Node, P_Protected_Definition (Protected_Node));
+ Set_Protected_Definition (Protected_Node, P_Protected_Definition);
return Protected_Node;
end if;
end P_Protected;
-- Error recovery: cannot raise Error_Resync
- function P_Protected_Definition (Decl : Node_Id) return Node_Id is
+ function P_Protected_Definition return Node_Id is
Def_Node : Node_Id;
Item_Node : Node_Id;
end loop Declaration_Loop;
end loop Private_Loop;
- End_Statements (Def_Node, Decl);
+ End_Statements (Def_Node);
return Def_Node;
end P_Protected_Definition;
procedure End_Statements
(Parent : Node_Id := Empty;
- Decl : Node_Id := Empty) is
+ Decl : Node_Id := Empty)
+ is
begin
-- This loop runs more than once in the case where Check_End rejects
-- the END sequence, as indicated by Check_End returning False.
-------------
package Ch7 is
- function P_Package
- (Pf_Flags : Pf_Rec;
- Decl : Node_Id := Empty) return Node_Id;
+ function P_Package (Pf_Flags : Pf_Rec) return Node_Id;
-- Scans out any construct starting with the keyword PACKAGE. The
-- parameter indicates which possible kinds of construct (body, spec,
- -- instantiation etc.) are permissible in the current context. Decl
- -- is set in the specification case to request that if there are aspect
- -- specifications present, they be associated with this declaration.
+ -- instantiation etc.) are permissible in the current context.
end Ch7;
-------------
-- rather more generous in considering something ill-formed to be an
-- attempt at an aspect specification. The default is more strict for
-- Ada versions before Ada 2012 (where aspect specifications are not
- -- permitted).
-
- procedure P_Aspect_Specifications (Decl : Node_Id);
- -- This subprogram is called with the current token pointing to either a
- -- WITH keyword starting an aspect specification, or a semicolon. In the
- -- former case, the aspect specifications are scanned out including the
- -- terminating semicolon, the Has_Aspect_Specifications flag is set in
- -- the given declaration node, and the list of aspect specifications is
- -- constructed and associated with this declaration node using a call to
- -- Set_Aspect_Specifications. If no WITH keyword is present, then this
- -- call has no effect other than scanning out the semicolon. If Decl is
- -- Error on entry, any scanned aspect specifications are ignored and a
- -- message is output saying aspect specifications not permitted here.
+ -- permitted). Note: this routine never checks the terminator token
+ -- for aspects so it does not matter whether the aspect speficiations
+ -- are terminated by semicolon or some other character
+
+ procedure P_Aspect_Specifications
+ (Decl : Node_Id;
+ Semicolon : Boolean := True);
+ -- This procedure scans out a series of aspect spefications. If argument
+ -- Semicolon is True, a terminating semicolon is also scanned. If this
+ -- argument is False, the scan pointer is left pointing past the aspects
+ -- and the caller must check for a proper terminator.
+ -- left pointing past the aspects, presumably pointing to a terminator.
+ --
+ -- P_Aspect_Specification is called with the current token pointing to
+ -- either a WITH keyword starting an aspect specification, or an
+ -- instance of the terminator token. In the former case, the aspect
+ -- specifications are scanned out including the terminator token if it
+ -- it is a semicolon, and the Has_Aspect_Specifications flag is set in
+ -- the given declaration node. A list of aspects is built and stored for
+ -- this declaration node using a call to Set_Aspect_Specifications. If
+ -- no WITH keyword is present, then this call has no effect other than
+ -- scanning out the terminator if it is a semicolon. If Decl is Error on
+ -- entry, any scanned aspect specifications are ignored and a message is
+ -- output saying aspect specifications not permitted here.
function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id;
-- Function to parse a code statement. The caller has scanned out
and then Is_Private_Type (Designated_Type (T))
and then not Has_Private_View (N)
and then Present (Full_View (Designated_Type (T)))
- and then Used_As_Generic_Actual (T)
then
Switch_View (Designated_Type (T));
Set_Is_Delayed_Aspect (Aspect);
end if;
+ -- Library unit aspects. These are boolean aspects, but we
+ -- always evaluate the expression right away if it is present
+ -- and just ignore the aspect if the expression is False. We
+ -- never delay expression evaluation in this case.
+
+ when Library_Unit_Aspects =>
+ if Present (Expr)
+ and then Is_False (Static_Boolean (Expr))
+ then
+ goto Continue;
+ end if;
+
+ -- Build corresponding pragma node
+
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (Ent),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Chars (Id)));
+
+ -- This requires special handling in the case of a package
+ -- declaration, the pragma needs to be inserted in the list
+ -- of declarations for the associated package. There is no
+ -- issue of visibility delay for these aspects.
+
+ if Nkind (N) = N_Package_Declaration then
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ Error_Msg_N
+ ("incorrect context for library unit aspect&", Id);
+ else
+ Prepend
+ (Aitem, Visible_Declarations (Specification (N)));
+ end if;
+
+ goto Continue;
+ end if;
+
+ -- If not package declaration, no delay is required
+
+ Delay_Required := False;
+
-- Aspects corresponding to attribute definition clauses
when Aspect_Address |
-- required pragma placement. The processing for the pragmas
-- takes care of the required delay.
- when Aspect_Pre |
- Aspect_Precondition |
- Aspect_Post |
- Aspect_Postcondition =>
- declare
+ when Pre_Post_Aspects => declare
Pname : Name_Id;
begin
-- If no delay required, insert the pragma/clause in the tree
else
- -- For Pre/Post cases, insert immediately after the entity
- -- declaration, since that is the required pragma placement.
+ -- If this is a compilation unit, we will put the pragma in
+ -- the Pragmas_After list of the N_Compilation_Unit_Aux node.
- if A_Id = Aspect_Pre or else
- A_Id = Aspect_Post or else
- A_Id = Aspect_Precondition or else
- A_Id = Aspect_Postcondition
- then
- Insert_After (N, Aitem);
+ if Nkind (Parent (Ins_Node)) = N_Compilation_Unit then
+ declare
+ Aux : constant Node_Id :=
+ Aux_Decls_Node (Parent (Ins_Node));
+
+ begin
+ pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux);
+
+ if No (Pragmas_After (Aux)) then
+ Set_Pragmas_After (Aux, Empty_List);
+ end if;
+
+ -- For Pre_Post put at start of list, otherwise at end
+
+ if A_Id in Pre_Post_Aspects then
+ Prepend (Aitem, Pragmas_After (Aux));
+ else
+ Append (Aitem, Pragmas_After (Aux));
+ end if;
+ end;
- -- For all other cases, insert in sequence
+ -- Here if not compilation unit case
else
- Insert_After (Ins_Node, Aitem);
- Ins_Node := Aitem;
+ -- For Pre/Post cases, insert immediately after the entity
+ -- declaration, since that is the required pragma placement.
+
+ if A_Id in Pre_Post_Aspects then
+ Insert_After (N, Aitem);
+
+ -- For all other cases, insert in sequence
+
+ else
+ Insert_After (Ins_Node, Aitem);
+ Ins_Node := Aitem;
+ end if;
end if;
end if;
end;
when No_Aspect =>
raise Program_Error;
+ -- Library unit aspects should be impossible (never delayed)
+
+ when Library_Unit_Aspects =>
+ raise Program_Error;
+
-- Aspects taking an optional boolean argument. Note that we will
-- never be called with an empty expression, because such aspects
-- never need to be delayed anyway.
-- True when this package declaration is not a nested declaration
begin
+ -- Analye aspect specifications immediately, since we need to recognize
+ -- things like Pure early enough to diagnose violations during analysis.
+
+ Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+
-- Ada 2005 (AI-217): Check if the package has been erroneously named
-- in a limited-with clause of its own context. In this case the error
-- has been previously notified by Analyze_Context.
-- package Pkg is ...
if From_With_Type (Id) then
- goto Leave;
+ return;
end if;
if Debug_Flag_C then
Write_Location (Sloc (N));
Write_Eol;
end if;
-
- <<Leave>>
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
end Analyze_Package_Declaration;
-----------------------------------
-- Preset arguments
Arg_Count := 0;
- Arg1 := Empty;
- Arg2 := Empty;
- Arg3 := Empty;
- Arg4 := Empty;
+ Arg1 := Empty;
+ Arg2 := Empty;
+ Arg3 := Empty;
+ Arg4 := Empty;
if Present (Pragma_Argument_Associations (N)) then
Arg_Count := List_Length (Pragma_Argument_Associations (N));
end Set_Size_Info;
--------------------
+ -- Static_Boolean --
+ --------------------
+
+ function Static_Boolean (N : Node_Id) return Uint is
+ begin
+ Analyze_And_Resolve (N, Standard_Boolean);
+
+ if N = Error
+ or else Error_Posted (N)
+ or else Etype (N) = Any_Type
+ then
+ return No_Uint;
+ end if;
+
+ if Is_Static_Expression (N) then
+ if not Raises_Constraint_Error (N) then
+ return Expr_Value (N);
+ else
+ return No_Uint;
+ end if;
+
+ elsif Etype (N) = Any_Type then
+ return No_Uint;
+
+ else
+ Flag_Non_Static_Expr
+ ("static boolean expression required here", N);
+ return No_Uint;
+ end if;
+ end Static_Boolean;
+
+ --------------------
-- Static_Integer --
--------------------
function Scope_Is_Transient return Boolean;
-- True if the current scope is transient
+ function Static_Boolean (N : Node_Id) return Uint;
+ -- This function analyzes the given expression node and then resolves it
+ -- as Standard.Boolean. If the result is static, then Uint_1 or Uint_0 is
+ -- returned corresponding to the value, otherwise an error message is
+ -- output and No_Uint is returned.
+
function Static_Integer (N : Node_Id) return Uint;
-- This function analyzes the given expression node and then resolves it
-- as any integer type. If the result is static, then the value of the
------------------------------
-- PACKAGE_DECLARATION ::=
- -- PACKAGE_SPECIFICATION
- -- [ASPECT_SPECIFICATIONS];
+ -- PACKAGE_SPECIFICATION;
-- Note: the activation chain entity for a package spec is used for
-- all tasks declared in the package spec, or in the package body.
--------------------------------
-- PACKAGE_SPECIFICATION ::=
- -- package DEFINING_PROGRAM_UNIT_NAME is
+ -- package DEFINING_PROGRAM_UNIT_NAME
+ -- [ASPECT_SPECIFICATIONS]
+ -- is
-- {BASIC_DECLARATIVE_ITEM}
-- [private
-- {BASIC_DECLARATIVE_ITEM}]
-----------------------
-- 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]
-- TASK_TYPE_DECLARATION ::=
-- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- [is [new INTERFACE_LIST with] TASK_DEFINITION]
- -- [ASPECT_SPECIFICATIONS];
+ -- [ASPECT_SPECIFICATIONS]
+ -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
-- N_Task_Type_Declaration
-- Sloc points to TASK
-- SINGLE_TASK_DECLARATION ::=
-- task DEFINING_IDENTIFIER
- -- [is [new INTERFACE_LIST with] TASK_DEFINITION]
- -- [ASPECT_SPECIFICATIONS];
+ -- [ASPECT_SPECIFICATIONS]
+ -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
-- N_Single_Task_Declaration
-- Sloc points to TASK
--------------------
-- TASK_BODY ::=
- -- task body task_DEFINING_IDENTIFIER is
+ -- task body task_DEFINING_IDENTIFIER
+ -- [ASPECT_SPECIFICATIONS]
+ -- is
-- DECLARATIVE_PART
-- begin
-- HANDLED_SEQUENCE_OF_STATEMENTS
-- PROTECTED_TYPE_DECLARATION ::=
-- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION
- -- {ASPECT_SPECIFICATIONS];
+ -- [ASPECT_SPECIFICATIONS]
+ -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- Note: protected type declarations are not permitted in Ada 83 mode
-- SINGLE_PROTECTED_DECLARATION ::=
-- protected DEFINING_IDENTIFIER
- -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION
- -- [ASPECT_SPECIFICATIONS];
+ -- [ASPECT_SPECIFICATIONS]
+ -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- Note: single protected declarations are not allowed in Ada 83 mode
-------------------------
-- PROTECTED_BODY ::=
- -- protected body DEFINING_IDENTIFIER is
+ -- protected body DEFINING_IDENTIFIER
+ -- [ASPECT_SPECIFICATIONS];
+ -- is
-- {PROTECTED_OPERATION_ITEM}
-- end [protected_IDENTIFIER];
procedure Sprint_And_List (List : List_Id);
-- Print the given list with items separated by vertical "and"
- procedure Sprint_Aspect_Specifications (Node : Node_Id);
+ procedure Sprint_Aspect_Specifications
+ (Node : Node_Id;
+ Semicolon : Boolean);
-- Node is a declaration node that has aspect specifications (Has_Aspects
- -- flag set True). It is called after outputting the terminating semicolon
- -- for the related node. The effect is to remove the semicolon and print
- -- the aspect specifications, followed by a terminating semicolon.
+ -- flag set True). It outputs the aspect specifications. For the case
+ -- of Semicolon = True, it is called after outputting the terminating
+ -- semicolon for the related node. The effect is to remove the semicolon
+ -- and print the aspect specifications followed by a terminating semicolon.
+ -- For the case of Semicolon False, no semicolon is removed or output, and
+ -- all the aspects are printed on a single line.
procedure Sprint_Bar_List (List : List_Id);
-- Print the given list with items separated by vertical bars
-- Sprint_Aspect_Specifications --
----------------------------------
- procedure Sprint_Aspect_Specifications (Node : Node_Id) is
+ procedure Sprint_Aspect_Specifications
+ (Node : Node_Id;
+ Semicolon : Boolean)
+ is
AS : constant List_Id := Aspect_Specifications (Node);
A : Node_Id;
begin
- Write_Erase_Char (';');
- Indent := Indent + 2;
- Write_Indent;
- Write_Str ("with ");
- Indent := Indent + 5;
+ if Semicolon then
+ Write_Erase_Char (';');
+ Indent := Indent + 2;
+ Write_Indent;
+ Write_Str ("with ");
+ Indent := Indent + 5;
+
+ else
+ Write_Str (" with ");
+ end if;
A := First (AS);
loop
exit when No (A);
Write_Char (',');
- Write_Indent;
+
+ if Semicolon then
+ Write_Indent;
+ end if;
end loop;
- Indent := Indent - 7;
- Write_Char (';');
+ if Semicolon then
+ Indent := Indent - 7;
+ Write_Char (';');
+ end if;
end Sprint_Aspect_Specifications;
---------------------
when N_Package_Specification =>
Write_Str_With_Col_Check_Sloc ("package ");
Sprint_Node (Defining_Unit_Name (Node));
+
+ if Nkind (Parent (Node)) = N_Package_Declaration
+ and then Has_Aspects (Parent (Node))
+ then
+ Sprint_Aspect_Specifications
+ (Parent (Node), Semicolon => False);
+ end if;
+
Write_Str (" is");
Sprint_Indented_List (Visible_Declarations (Node));
end if;
end case;
- if Has_Aspects (Node) then
- Sprint_Aspect_Specifications (Node);
+ -- Print aspects, except for special case of package declaration,
+ -- where the aspects are printed inside the package specification.
+
+ if Has_Aspects (Node) and Nkind (Node) /= N_Package_Declaration then
+ Sprint_Aspect_Specifications (Node, Semicolon => True);
end if;
if Nkind (Node) in N_Subexpr
OSDN Git Service
