OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r177027
This commit is contained in:
Arnaud Charlet 2011-08-01 14:50:07 +02:00
parent 9eea4346af
commit 1c54829e23
19 changed files with 400 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/ada/ChangeLog
View File

@ -1,3 +1,42 @@
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.

19
gcc/ada/aspects.adb
View File

@ -143,14 +143,18 @@ package body Aspects is
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);
@ -165,8 +169,8 @@ package body Aspects is
-- 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,
@ -181,6 +185,17 @@ package body Aspects is
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,

43
gcc/ada/aspects.ads
View File

@ -73,9 +73,24 @@ package Aspects is
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
@ -109,6 +124,14 @@ package Aspects is
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,
@ -119,6 +142,9 @@ package Aspects is
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
@ -158,6 +184,8 @@ package Aspects is
Aspect_Value_Size => Expression,
Aspect_Warnings => Name,
Aspect_Write => Name,
Library_Unit_Aspects => Optional,
Boolean_Aspects => Optional);
-----------------------------------------
@ -176,12 +204,15 @@ package Aspects is
(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),
@ -199,9 +230,16 @@ package Aspects is
(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),
@ -212,6 +250,7 @@ package Aspects is
(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),

25
gcc/ada/atree.ads
View File

@ -821,7 +821,7 @@ package Atree is
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
@ -889,8 +889,8 @@ package Atree is
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);
@ -898,8 +898,8 @@ package Atree is
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);
@ -1150,10 +1150,10 @@ package Atree is
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);
@ -3023,8 +3023,8 @@ package Atree is
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);
@ -3042,8 +3042,7 @@ package Atree is
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);

2
gcc/ada/exp_util.adb
View File

@ -2520,7 +2520,7 @@ package body Exp_Util is
(Last (Actions (P)), Ins_Actions);
else
Set_Actions (P, Ins_Actions);
Analyze_List (Then_Actions (P));
Analyze_List (Actions (P));
end if;
return;

2
gcc/ada/par-ch12.adb
View File

@ -202,7 +202,7 @@ package body Ch12 is
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);

34
gcc/ada/par-ch13.adb
View File

@ -381,7 +381,10 @@ package body Ch13 is
-- 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;
@ -392,7 +395,10 @@ package body Ch13 is
-- Check if aspect specification present
if not Aspect_Specifications_Present then
TF_Semicolon;
if Semicolon then
TF_Semicolon;
end if;
return;
end if;
@ -411,7 +417,11 @@ package body Ch13 is
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;
@ -454,7 +464,10 @@ package body Ch13 is
OK := False;
else
Resync_Past_Semicolon;
if Semicolon then
Resync_Past_Semicolon;
end if;
return;
end if;
@ -495,7 +508,10 @@ package body Ch13 is
-- 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");
@ -527,8 +543,14 @@ package body Ch13 is
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;

31
gcc/ada/par-ch7.adb
View File

@ -92,15 +92,17 @@ package body Ch7 is
-- 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;
@ -147,8 +149,6 @@ package body Ch7 is
Parse_Decls_Begin_End (Package_Node);
end if;
return Package_Node;
-- Cases other than Package_Body
else
@ -174,9 +174,11 @@ package body Ch7 is
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
@ -190,12 +192,12 @@ package body Ch7 is
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
@ -249,16 +251,13 @@ package body Ch7 is
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;
------------------------------

56
gcc/ada/par-ch9.adb
View File

@ -40,19 +40,11 @@ package body Ch9 is
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) --
@ -60,13 +52,13 @@ package body Ch9 is
-- 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
@ -153,27 +145,26 @@ package body Ch9 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;
@ -214,7 +205,7 @@ package body Ch9 is
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;
@ -253,7 +244,7 @@ package body Ch9 is
-- 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
@ -273,7 +264,7 @@ package body Ch9 is
end loop;
end if;
End_Statements (Def_Node, Decl);
End_Statements (Def_Node);
return Def_Node;
end P_Task_Definition;
@ -367,13 +358,13 @@ package body Ch9 is
-- 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
@ -464,6 +455,8 @@ package body Ch9 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;
@ -525,8 +518,7 @@ package body Ch9 is
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;
@ -561,7 +553,7 @@ package body Ch9 is
-- 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;
@ -607,7 +599,7 @@ package body Ch9 is
end loop Declaration_Loop;
end loop Private_Loop;
End_Statements (Def_Node, Decl);
End_Statements (Def_Node);
return Def_Node;
end P_Protected_Definition;

3
gcc/ada/par-endh.adb
View File

@ -654,7 +654,8 @@ package body Endh is
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.

43
gcc/ada/par.adb
View File

@ -762,14 +762,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-------------
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;
-------------
@ -863,19 +859,30 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- 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).
-- 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);
-- 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.
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

1
gcc/ada/sem_ch12.adb
View File

@ -5501,7 +5501,6 @@ package body Sem_Ch12 is
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));

98
gcc/ada/sem_ch13.adb
View File

@ -843,6 +843,47 @@ package body Sem_Ch13 is
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 |
@ -932,11 +973,7 @@ package body Sem_Ch13 is
-- 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
@ -1115,21 +1152,45 @@ package body Sem_Ch13 is
-- 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));
-- For all other cases, insert in sequence
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;
-- 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;
@ -5085,6 +5146,11 @@ package body Sem_Ch13 is
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.

10
gcc/ada/sem_ch7.adb
View File

@ -760,6 +760,11 @@ package body Sem_Ch7 is
-- 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.
@ -768,7 +773,7 @@ package body Sem_Ch7 is
-- package Pkg is ...
if From_With_Type (Id) then
goto Leave;
return;
end if;
if Debug_Flag_C then
@ -842,9 +847,6 @@ package body Sem_Ch7 is
Write_Location (Sloc (N));
Write_Eol;
end if;
<<Leave>>
Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
end Analyze_Package_Declaration;
-----------------------------------

8
gcc/ada/sem_prag.adb
View File

@ -5689,10 +5689,10 @@ package body Sem_Prag is
-- 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));

32
gcc/ada/sem_util.adb
View File

@ -11227,6 +11227,38 @@ package body Sem_Util is
Set_Alignment (T1, Alignment (T2));
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 --
--------------------

6
gcc/ada/sem_util.ads
View File

@ -1280,6 +1280,12 @@ package Sem_Util is
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

35
gcc/ada/sinfo.ads
View File

@ -4773,8 +4773,7 @@ package Sinfo is
------------------------------
-- 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.
@ -4791,7 +4790,9 @@ package Sinfo is
--------------------------------
-- PACKAGE_SPECIFICATION ::=
-- package DEFINING_PROGRAM_UNIT_NAME is
-- package DEFINING_PROGRAM_UNIT_NAME
-- [ASPECT_SPECIFICATIONS]
-- is
-- {BASIC_DECLARATIVE_ITEM}
-- [private
-- {BASIC_DECLARATIVE_ITEM}]
@ -4812,7 +4813,9 @@ package Sinfo is
-----------------------
-- 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]
@ -5023,8 +5026,8 @@ package Sinfo is
-- 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
@ -5041,8 +5044,8 @@ package Sinfo is
-- 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
@ -5086,7 +5089,9 @@ package Sinfo is
--------------------
-- TASK_BODY ::=
-- task body task_DEFINING_IDENTIFIER is
-- task body task_DEFINING_IDENTIFIER
-- [ASPECT_SPECIFICATIONS]
-- is
-- DECLARATIVE_PART
-- begin
-- HANDLED_SEQUENCE_OF_STATEMENTS
@ -5110,8 +5115,8 @@ package Sinfo is
-- 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
@ -5130,8 +5135,8 @@ package Sinfo is
-- 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
@ -5179,7 +5184,9 @@ package Sinfo is
-------------------------
-- PROTECTED_BODY ::=
-- protected body DEFINING_IDENTIFIER is
-- protected body DEFINING_IDENTIFIER
-- [ASPECT_SPECIFICATIONS];
-- is
-- {PROTECTED_OPERATION_ITEM}
-- end [protected_IDENTIFIER];

59
gcc/ada/sprint.adb
View File

@ -183,11 +183,16 @@ package body Sprint is
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
@ -630,16 +635,24 @@ package body Sprint is
-- 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
@ -658,11 +671,16 @@ package body Sprint is
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;
---------------------
@ -2411,6 +2429,14 @@ package body Sprint is
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));
@ -3176,8 +3202,11 @@ package body Sprint is
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