Commit c0cdbd39 by Arnaud Charlet

[multiple changes]

2014-02-20  Robert Dewar  <dewar@adacore.com>

	* s-os_lib.ads (Rename_File): Minor commment addition.

2014-02-20  Thomas Quinot  <quinot@adacore.com>

	* einfo.ads: Minor reformatting.

2014-02-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* aspects.adb (Exchange_Aspects): New routine.
	* aspects.ads (Exchange_Aspects): New routine.
	* atree.adb (Rewrite): Do not check whether the save node has
	aspects as it never will, instead check the node about to be clobbered.
	* einfo.adb (Write_Field25_Name): Abstract_States can appear in
	entities of generic packages.
	* sem_ch6.adb (Analyze_Expression_Function): Fix the parent
	pointer of an aspect specification list after rewriting takes place.
	* sem_ch7.adb (Analyze_Package_Body_Helper): Swap the aspect
	specifications of the generic template and the copy used for analysis.
	* sem_ch12.adb (Analyze_Generic_Package_Declaration): Swap
	the aspect specifications of the generic template and the
	copy used for analysis.
	(Analyze_Package_Instantiation): Propagate the aspect specifications
	from the generic template to the instantiation.
	(Build_Instance_Compilation_Unit_Nodes): Propagate the aspect
	specifications from the generic template to the instantiation.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Handle aspects
	Abstract_State, Initializes and Initial_Condition when they
	apply to a package instantiation.

2014-02-20  Robert Dewar  <dewar@adacore.com>

	* stringt.adb: Add call to Initialize in package initialization.

From-SVN: r207946
parent fe4552f4
2014-02-20 Robert Dewar <dewar@adacore.com> 2014-02-20 Robert Dewar <dewar@adacore.com>
* s-os_lib.ads (Rename_File): Minor commment addition.
2014-02-20 Thomas Quinot <quinot@adacore.com>
* einfo.ads: Minor reformatting.
2014-02-20 Hristian Kirtchev <kirtchev@adacore.com>
* aspects.adb (Exchange_Aspects): New routine.
* aspects.ads (Exchange_Aspects): New routine.
* atree.adb (Rewrite): Do not check whether the save node has
aspects as it never will, instead check the node about to be clobbered.
* einfo.adb (Write_Field25_Name): Abstract_States can appear in
entities of generic packages.
* sem_ch6.adb (Analyze_Expression_Function): Fix the parent
pointer of an aspect specification list after rewriting takes place.
* sem_ch7.adb (Analyze_Package_Body_Helper): Swap the aspect
specifications of the generic template and the copy used for analysis.
* sem_ch12.adb (Analyze_Generic_Package_Declaration): Swap
the aspect specifications of the generic template and the
copy used for analysis.
(Analyze_Package_Instantiation): Propagate the aspect specifications
from the generic template to the instantiation.
(Build_Instance_Compilation_Unit_Nodes): Propagate the aspect
specifications from the generic template to the instantiation.
* sem_ch13.adb (Analyze_Aspect_Specifications): Handle aspects
Abstract_State, Initializes and Initial_Condition when they
apply to a package instantiation.
2014-02-20 Robert Dewar <dewar@adacore.com>
* stringt.adb: Add call to Initialize in package initialization.
2014-02-20 Robert Dewar <dewar@adacore.com>
* a-crbtgk.adb, a-cihama.adb, a-coinve.adb, a-ciorse.adb, a-crbtgo.adb, * a-crbtgk.adb, a-cihama.adb, a-coinve.adb, a-ciorse.adb, a-crbtgo.adb,
a-cidlli.adb, a-cimutr.adb, a-cihase.adb, a-cohama.adb, a-coorse.adb, a-cidlli.adb, a-cimutr.adb, a-cihase.adb, a-cohama.adb, a-coorse.adb,
a-chtgke.adb, a-chtgop.adb, a-comutr.adb, a-ciorma.adb, a-cobove.adb, a-chtgke.adb, a-chtgop.adb, a-comutr.adb, a-ciorma.adb, a-cobove.adb,
......
...@@ -174,6 +174,31 @@ package body Aspects is ...@@ -174,6 +174,31 @@ package body Aspects is
return True; return True;
end Aspects_On_Body_Or_Stub_OK; end Aspects_On_Body_Or_Stub_OK;
----------------------
-- Exchange_Aspects --
----------------------
procedure Exchange_Aspects (N1 : Node_Id; N2 : Node_Id) is
begin
pragma Assert
(Permits_Aspect_Specifications (N1)
and then Permits_Aspect_Specifications (N2));
-- Perform the exchange only when both nodes have lists to be swapped
if Has_Aspects (N1) and then Has_Aspects (N2) then
declare
L1 : constant List_Id := Aspect_Specifications (N1);
L2 : constant List_Id := Aspect_Specifications (N2);
begin
Set_Parent (L1, N2);
Set_Parent (L2, N1);
Aspect_Specifications_Hash_Table.Set (N1, L2);
Aspect_Specifications_Hash_Table.Set (N2, L1);
end;
end if;
end Exchange_Aspects;
----------------- -----------------
-- Find_Aspect -- -- Find_Aspect --
----------------- -----------------
......
...@@ -786,6 +786,11 @@ package Aspects is ...@@ -786,6 +786,11 @@ package Aspects is
-- N denotes a body [stub] with aspects. Determine whether all aspects of N -- N denotes a body [stub] with aspects. Determine whether all aspects of N
-- are allowed to appear on a body [stub]. -- are allowed to appear on a body [stub].
procedure Exchange_Aspects (N1 : Node_Id; N2 : Node_Id);
-- Exchange the aspect specifications of two nodes. If either node lacks an
-- aspect specification list, the routine has no effect. It is assumed that
-- both nodes can support aspects.
function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id; function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id;
-- Find the aspect specification of aspect A associated with entity I. -- Find the aspect specification of aspect A associated with entity I.
-- Return Empty if Id does not have the requested aspect. -- Return Empty if Id does not have the requested aspect.
......
...@@ -1870,8 +1870,7 @@ package body Atree is ...@@ -1870,8 +1870,7 @@ package body Atree is
-- Both the old and new copies of the node will share the same list -- Both the old and new copies of the node will share the same list
-- of aspect specifications if aspect specifications are present. -- of aspect specifications if aspect specifications are present.
if Has_Aspects (Sav_Node) then if Old_Has_Aspects then
Set_Has_Aspects (Sav_Node, False);
Set_Aspect_Specifications Set_Aspect_Specifications
(Sav_Node, Aspect_Specifications (Old_Node)); (Sav_Node, Aspect_Specifications (Old_Node));
end if; end if;
......
...@@ -9290,7 +9290,8 @@ package body Einfo is ...@@ -9290,7 +9290,8 @@ package body Einfo is
procedure Write_Field25_Name (Id : Entity_Id) is procedure Write_Field25_Name (Id : Entity_Id) is
begin begin
case Ekind (Id) is case Ekind (Id) is
when E_Package => when E_Generic_Package |
E_Package =>
Write_Str ("Abstract_States"); Write_Str ("Abstract_States");
when E_Variable => when E_Variable =>
......
...@@ -3622,13 +3622,12 @@ package Einfo is ...@@ -3622,13 +3622,12 @@ package Einfo is
-- in a Relative_Deadline pragma for a task type. -- in a Relative_Deadline pragma for a task type.
-- Renamed_Entity (Node18) -- Renamed_Entity (Node18)
-- Defined in exceptions, packages, subprograms and generic units. Set -- Defined in exceptions, packages, subprograms, and generic units. Set
-- for entities that are defined by a renaming declaration. Denotes the -- for entities that are defined by a renaming declaration. Denotes the
-- renamed entity, or transitively the ultimate renamed entity if -- renamed entity, or transitively the ultimate renamed entity if
-- there is a chain of renaming declarations. Empty if no renaming. -- there is a chain of renaming declarations. Empty if no renaming.
-- Renamed_In_Spec (Flag231) -- Renamed_In_Spec (Flag231)
-- Defined in package entities. If a package renaming occurs within -- Defined in package entities. If a package renaming occurs within
-- a package spec, then this flag is set on the renamed package. The -- a package spec, then this flag is set on the renamed package. The
-- purpose is to prevent a warning about unused entities in the renamed -- purpose is to prevent a warning about unused entities in the renamed
......
...@@ -301,7 +301,9 @@ package System.OS_Lib is ...@@ -301,7 +301,9 @@ package System.OS_Lib is
New_Name : String; New_Name : String;
Success : out Boolean); Success : out Boolean);
-- Rename a file. Success is set True or False indicating if the rename is -- Rename a file. Success is set True or False indicating if the rename is
-- successful or not. -- successful or not. Note that on some Systems (notably Windows), if there
-- is already an existing file with the name New_Name, that is one of the
-- conditions that can cause failure.
-- The following defines the mode for the Copy_File procedure below. Note -- The following defines the mode for the Copy_File procedure below. Note
-- that "time stamps and other file attributes" in the descriptions below -- that "time stamps and other file attributes" in the descriptions below
......
...@@ -3019,6 +3019,11 @@ package body Sem_Ch12 is ...@@ -3019,6 +3019,11 @@ package body Sem_Ch12 is
New_N := Copy_Generic_Node (N, Empty, Instantiating => False); New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Set_Parent_Spec (New_N, Save_Parent); Set_Parent_Spec (New_N, Save_Parent);
Rewrite (N, New_N); Rewrite (N, New_N);
-- Once the contents of the generic copy and the template are swapped,
-- do the same for their respective aspect specifications.
Exchange_Aspects (N, New_N);
Id := Defining_Entity (N); Id := Defining_Entity (N);
Generate_Definition (Id); Generate_Definition (Id);
...@@ -3088,7 +3093,6 @@ package body Sem_Ch12 is ...@@ -3088,7 +3093,6 @@ package body Sem_Ch12 is
Check_References (Id); Check_References (Id);
end if; end if;
end if; end if;
end Analyze_Generic_Package_Declaration; end Analyze_Generic_Package_Declaration;
-------------------------------------------- --------------------------------------------
...@@ -3598,7 +3602,7 @@ package body Sem_Ch12 is ...@@ -3598,7 +3602,7 @@ package body Sem_Ch12 is
Make_Package_Renaming_Declaration (Loc, Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name => Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Gen_Unit)), Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
Name => New_Occurrence_Of (Act_Decl_Id, Loc)); Name => New_Occurrence_Of (Act_Decl_Id, Loc));
Append (Unit_Renaming, Renaming_List); Append (Unit_Renaming, Renaming_List);
...@@ -3616,6 +3620,14 @@ package body Sem_Ch12 is ...@@ -3616,6 +3620,14 @@ package body Sem_Ch12 is
Make_Package_Declaration (Loc, Make_Package_Declaration (Loc,
Specification => Act_Spec); Specification => Act_Spec);
-- Propagate the aspect specifications from the package declaration
-- template to the instantiated version of the package declaration.
if Has_Aspects (Act_Tree) then
Set_Aspect_Specifications (Act_Decl,
New_Copy_List_Tree (Aspect_Specifications (Act_Tree)));
end if;
-- Save the instantiation node, for subsequent instantiation of the -- Save the instantiation node, for subsequent instantiation of the
-- body, if there is one and we are generating code for the current -- body, if there is one and we are generating code for the current
-- unit. Mark unit as having a body (avoids premature error message). -- unit. Mark unit as having a body (avoids premature error message).
...@@ -5007,7 +5019,7 @@ package body Sem_Ch12 is ...@@ -5007,7 +5019,7 @@ package body Sem_Ch12 is
Unit => Act_Decl, Unit => Act_Decl,
Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N))); Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N)));
Set_Parent_Spec (Act_Decl, Parent_Spec (N)); Set_Parent_Spec (Act_Decl, Parent_Spec (N));
-- The new compilation unit is linked to its body, but both share the -- The new compilation unit is linked to its body, but both share the
-- same file, so we do not set Body_Required on the new unit so as not -- same file, so we do not set Body_Required on the new unit so as not
...@@ -5018,6 +5030,15 @@ package body Sem_Ch12 is ...@@ -5018,6 +5030,15 @@ package body Sem_Ch12 is
-- compilation unit of the instance, since this is the main unit. -- compilation unit of the instance, since this is the main unit.
Rewrite (N, Act_Body); Rewrite (N, Act_Body);
-- Propagate the aspect specifications from the package body template to
-- the instantiated version of the package body.
if Has_Aspects (Act_Body) then
Set_Aspect_Specifications
(N, New_Copy_List_Tree (Aspect_Specifications (Act_Body)));
end if;
Body_Cunit := Parent (N); Body_Cunit := Parent (N);
-- The two compilation unit nodes are linked by the Library_Unit field -- The two compilation unit nodes are linked by the Library_Unit field
......
...@@ -2008,13 +2008,22 @@ package body Sem_Ch13 is ...@@ -2008,13 +2008,22 @@ package body Sem_Ch13 is
-- immediately. -- immediately.
when Aspect_Abstract_State => Abstract_State : declare when Aspect_Abstract_State => Abstract_State : declare
Decls : List_Id; Context : Node_Id := N;
Decls : List_Id;
begin begin
if Nkind_In (N, N_Generic_Package_Declaration, -- When aspect Abstract_State appears on a generic package,
N_Package_Declaration) -- it is propageted to the package instance. The context in
-- this case is the instance spec.
if Nkind (Context) = N_Package_Instantiation then
Context := Instance_Spec (Context);
end if;
if Nkind_In (Context, N_Generic_Package_Declaration,
N_Package_Declaration)
then then
Decls := Visible_Declarations (Specification (N)); Decls := Visible_Declarations (Specification (Context));
Make_Aitem_Pragma Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List ( (Pragma_Argument_Associations => New_List (
...@@ -2025,7 +2034,7 @@ package body Sem_Ch13 is ...@@ -2025,7 +2034,7 @@ package body Sem_Ch13 is
if No (Decls) then if No (Decls) then
Decls := New_List; Decls := New_List;
Set_Visible_Declarations (N, Decls); Set_Visible_Declarations (Context, Decls);
end if; end if;
Prepend_To (Decls, Aitem); Prepend_To (Decls, Aitem);
...@@ -2084,13 +2093,22 @@ package body Sem_Ch13 is ...@@ -2084,13 +2093,22 @@ package body Sem_Ch13 is
-- it must be evaluated at the end of the said declarations. -- it must be evaluated at the end of the said declarations.
when Aspect_Initial_Condition => Initial_Condition : declare when Aspect_Initial_Condition => Initial_Condition : declare
Decls : List_Id; Context : Node_Id := N;
Decls : List_Id;
begin begin
if Nkind_In (N, N_Generic_Package_Declaration, -- When aspect Abstract_State appears on a generic package,
N_Package_Declaration) -- it is propageted to the package instance. The context in
-- this case is the instance spec.
if Nkind (Context) = N_Package_Instantiation then
Context := Instance_Spec (Context);
end if;
if Nkind_In (Context, N_Generic_Package_Declaration,
N_Package_Declaration)
then then
Decls := Visible_Declarations (Specification (N)); Decls := Visible_Declarations (Specification (Context));
Make_Aitem_Pragma Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List ( (Pragma_Argument_Associations => New_List (
...@@ -2104,7 +2122,7 @@ package body Sem_Ch13 is ...@@ -2104,7 +2122,7 @@ package body Sem_Ch13 is
if No (Decls) then if No (Decls) then
Decls := New_List; Decls := New_List;
Set_Visible_Declarations (N, Decls); Set_Visible_Declarations (Context, Decls);
end if; end if;
Prepend_To (Decls, Aitem); Prepend_To (Decls, Aitem);
...@@ -2125,13 +2143,22 @@ package body Sem_Ch13 is ...@@ -2125,13 +2143,22 @@ package body Sem_Ch13 is
-- said declarations. -- said declarations.
when Aspect_Initializes => Initializes : declare when Aspect_Initializes => Initializes : declare
Decls : List_Id; Context : Node_Id := N;
Decls : List_Id;
begin begin
if Nkind_In (N, N_Generic_Package_Declaration, -- When aspect Abstract_State appears on a generic package,
N_Package_Declaration) -- it is propageted to the package instance. The context in
-- this case is the instance spec.
if Nkind (Context) = N_Package_Instantiation then
Context := Instance_Spec (Context);
end if;
if Nkind_In (Context, N_Generic_Package_Declaration,
N_Package_Declaration)
then then
Decls := Visible_Declarations (Specification (N)); Decls := Visible_Declarations (Specification (Context));
Make_Aitem_Pragma Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List ( (Pragma_Argument_Associations => New_List (
...@@ -2144,7 +2171,7 @@ package body Sem_Ch13 is ...@@ -2144,7 +2171,7 @@ package body Sem_Ch13 is
if No (Decls) then if No (Decls) then
Decls := New_List; Decls := New_List;
Set_Visible_Declarations (N, Decls); Set_Visible_Declarations (Context, Decls);
end if; end if;
Prepend_To (Decls, Aitem); Prepend_To (Decls, Aitem);
......
...@@ -374,6 +374,13 @@ package body Sem_Ch6 is ...@@ -374,6 +374,13 @@ package body Sem_Ch6 is
Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True); Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True);
Rewrite (N, New_Body); Rewrite (N, New_Body);
-- Correct the parent pointer of the aspect specification list to
-- reference the rewritten node.
if Has_Aspects (N) then
Set_Parent (Aspect_Specifications (N), N);
end if;
-- Propagate any pragmas that apply to the expression function to the -- Propagate any pragmas that apply to the expression function to the
-- proper body when the expression function acts as a completion. -- proper body when the expression function acts as a completion.
-- Aspects are automatically transfered because of node rewriting. -- Aspects are automatically transfered because of node rewriting.
...@@ -429,6 +436,14 @@ package body Sem_Ch6 is ...@@ -429,6 +436,14 @@ package body Sem_Ch6 is
Make_Subprogram_Declaration (Loc, Specification => Spec); Make_Subprogram_Declaration (Loc, Specification => Spec);
Rewrite (N, New_Decl); Rewrite (N, New_Decl);
-- Correct the parent pointer of the aspect specification list to
-- reference the rewritten node.
if Has_Aspects (N) then
Set_Parent (Aspect_Specifications (N), N);
end if;
Analyze (N); Analyze (N);
Set_Is_Inlined (Defining_Entity (New_Decl)); Set_Is_Inlined (Defining_Entity (New_Decl));
......
...@@ -327,6 +327,11 @@ package body Sem_Ch7 is ...@@ -327,6 +327,11 @@ package body Sem_Ch7 is
New_N := Copy_Generic_Node (N, Empty, Instantiating => False); New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Rewrite (N, New_N); Rewrite (N, New_N);
-- Once the contents of the generic copy and the template are
-- swapped, do the same for their respective aspect specifications.
Exchange_Aspects (N, New_N);
-- Update Body_Id to point to the copied node for the remainder of -- Update Body_Id to point to the copied node for the remainder of
-- the processing. -- the processing.
......
...@@ -475,6 +475,7 @@ package body Stringt is ...@@ -475,6 +475,7 @@ package body Stringt is
-- Setup the null string -- Setup the null string
begin begin
Initialize;
Start_String; Start_String;
Null_String_Id := End_String; Null_String_Id := End_String;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment