Commit afbcdf5e by Arnaud Charlet

[multiple changes]

2010-10-07  Robert Dewar  <dewar@adacore.com>

	* exp_disp.adb, exp_dist.adb, exp_util.ads, exp_util.adb,
	exp_ch11.adb: Rename Full_Qualified_Name to Fully_Qualified_Name_String
	* sem_util.adb, sem_util.ads (Full_Qualified_Name): Moved to
	Exp_Util.Fully_Qualified_Name_String.

2010-10-07  Robert Dewar  <dewar@adacore.com>

	* rtsfind.ads: Add entry for Ada.Real_Time.Timing_Events.Set_Handler
	* sem_res.adb (Resolve_Call): A call to
	Ada.Real_Time.Timing_Events.Set_Handler violates restriction
	No_Relative_Delay (AI-0211).

2010-10-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb: Small change in error message.

From-SVN: r165092
parent dc017afa
2010-10-07 Robert Dewar <dewar@adacore.com> 2010-10-07 Robert Dewar <dewar@adacore.com>
* exp_disp.adb, exp_dist.adb, exp_util.ads, exp_util.adb,
exp_ch11.adb: Rename Full_Qualified_Name to Fully_Qualified_Name_String
* sem_util.adb, sem_util.ads (Full_Qualified_Name): Moved to
Exp_Util.Fully_Qualified_Name_String.
2010-10-07 Robert Dewar <dewar@adacore.com>
* rtsfind.ads: Add entry for Ada.Real_Time.Timing_Events.Set_Handler
* sem_res.adb (Resolve_Call): A call to
Ada.Real_Time.Timing_Events.Set_Handler violates restriction
No_Relative_Delay (AI-0211).
2010-10-07 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb: Small change in error message.
2010-10-07 Robert Dewar <dewar@adacore.com>
* tbuild.ads: Minor reformatting. * tbuild.ads: Minor reformatting.
2010-10-07 Robert Dewar <dewar@adacore.com> 2010-10-07 Robert Dewar <dewar@adacore.com>
......
...@@ -1265,7 +1265,7 @@ package body Exp_Ch11 is ...@@ -1265,7 +1265,7 @@ package body Exp_Ch11 is
Object_Definition => New_Occurrence_Of (Standard_String, Loc), Object_Definition => New_Occurrence_Of (Standard_String, Loc),
Expression => Expression =>
Make_String_Literal (Loc, Make_String_Literal (Loc,
Strval => Full_Qualified_Name (Id)))); Strval => Fully_Qualified_Name_String (Id))));
Set_Is_Statically_Allocated (Exname); Set_Is_Statically_Allocated (Exname);
......
...@@ -4483,8 +4483,7 @@ package body Exp_Disp is ...@@ -4483,8 +4483,7 @@ package body Exp_Disp is
end loop; end loop;
end if; end if;
-- Get the _tag entity and the number of primitives of its dispatch -- Get the _tag entity and number of primitives of its dispatch table
-- table.
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
...@@ -4654,7 +4653,7 @@ package body Exp_Disp is ...@@ -4654,7 +4653,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (Standard_String, Loc), Object_Definition => New_Reference_To (Standard_String, Loc),
Expression => Expression =>
Make_String_Literal (Loc, Make_String_Literal (Loc,
Full_Qualified_Name (First_Subtype (Typ))))); Fully_Qualified_Name_String (First_Subtype (Typ)))));
Set_Is_Statically_Allocated (Exname); Set_Is_Statically_Allocated (Exname);
Set_Is_True_Constant (Exname); Set_Is_True_Constant (Exname);
...@@ -4768,7 +4767,7 @@ package body Exp_Disp is ...@@ -4768,7 +4767,7 @@ package body Exp_Disp is
New_External_Name (Tname, 'A')); New_External_Name (Tname, 'A'));
Full_Name : constant String_Id := Full_Name : constant String_Id :=
Full_Qualified_Name (First_Subtype (Typ)); Fully_Qualified_Name_String (First_Subtype (Typ));
Str1_Id : String_Id; Str1_Id : String_Id;
Str2_Id : String_Id; Str2_Id : String_Id;
......
...@@ -5541,7 +5541,7 @@ package body Exp_Dist is ...@@ -5541,7 +5541,7 @@ package body Exp_Dist is
-- Name -- Name
Make_String_Literal (Loc, Make_String_Literal (Loc,
Full_Qualified_Name (Desig)), Fully_Qualified_Name_String (Desig)),
-- Handler -- Handler
...@@ -5887,7 +5887,7 @@ package body Exp_Dist is ...@@ -5887,7 +5887,7 @@ package body Exp_Dist is
Unchecked_Convert_To (RTE (RE_Address), Unchecked_Convert_To (RTE (RE_Address),
New_Occurrence_Of (RACW_Parameter, Loc)), New_Occurrence_Of (RACW_Parameter, Loc)),
Make_String_Literal (Loc, Make_String_Literal (Loc,
Strval => Full_Qualified_Name Strval => Fully_Qualified_Name_String
(Etype (Designated_Type (RACW_Type)))), (Etype (Designated_Type (RACW_Type)))),
Build_Stub_Tag (Loc, RACW_Type), Build_Stub_Tag (Loc, RACW_Type),
New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
...@@ -6083,7 +6083,7 @@ package body Exp_Dist is ...@@ -6083,7 +6083,7 @@ package body Exp_Dist is
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Object), Unchecked_Convert_To (RTE (RE_Address), Object),
Make_String_Literal (Loc, Make_String_Literal (Loc,
Strval => Full_Qualified_Name Strval => Fully_Qualified_Name_String
(Etype (Designated_Type (RACW_Type)))), (Etype (Designated_Type (RACW_Type)))),
Build_Stub_Tag (Loc, RACW_Type), Build_Stub_Tag (Loc, RACW_Type),
New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
......
...@@ -24,6 +24,7 @@ ...@@ -24,6 +24,7 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Atree; use Atree; with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks; with Checks; use Checks;
with Debug; use Debug; with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
...@@ -1753,6 +1754,62 @@ package body Exp_Util is ...@@ -1753,6 +1754,62 @@ package body Exp_Util is
Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True); Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
end Force_Evaluation; end Force_Evaluation;
---------------------------------
-- Fully_Qualified_Name_String --
---------------------------------
function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
procedure Internal_Full_Qualified_Name (E : Entity_Id);
-- Compute recursively the qualified name without NUL at the end, adding
-- it to the currently started string being generated
----------------------------------
-- Internal_Full_Qualified_Name --
----------------------------------
procedure Internal_Full_Qualified_Name (E : Entity_Id) is
Ent : Entity_Id;
begin
-- Deal properly with child units
if Nkind (E) = N_Defining_Program_Unit_Name then
Ent := Defining_Identifier (E);
else
Ent := E;
end if;
-- Compute qualification recursively (only "Standard" has no scope)
if Present (Scope (Scope (Ent))) then
Internal_Full_Qualified_Name (Scope (Ent));
Store_String_Char (Get_Char_Code ('.'));
end if;
-- Every entity should have a name except some expanded blocks
-- don't bother about those.
if Chars (Ent) = No_Name then
return;
end if;
-- Generates the entity name in upper case
Get_Decoded_Name_String (Chars (Ent));
Set_All_Upper_Case;
Store_String_Chars (Name_Buffer (1 .. Name_Len));
return;
end Internal_Full_Qualified_Name;
-- Start of processing for Full_Qualified_Name
begin
Start_String;
Internal_Full_Qualified_Name (E);
Store_String_Char (Get_Char_Code (ASCII.NUL));
return End_String;
end Fully_Qualified_Name_String;
------------------------ ------------------------
-- Generate_Poll_Call -- -- Generate_Poll_Call --
------------------------ ------------------------
......
...@@ -403,6 +403,10 @@ package Exp_Util is ...@@ -403,6 +403,10 @@ package Exp_Util is
-- Force_Evaluation further guarantees that all evaluations will yield -- Force_Evaluation further guarantees that all evaluations will yield
-- the same result. -- the same result.
function Fully_Qualified_Name_String (E : Entity_Id) return String_Id;
-- Generates the string literal corresponding to the fully qualified name
-- of entity E with an ASCII.NUL appended at the end of the name.
procedure Generate_Poll_Call (N : Node_Id); procedure Generate_Poll_Call (N : Node_Id);
-- If polling is active, then a call to the Poll routine is built, -- If polling is active, then a call to the Poll routine is built,
-- and then inserted before the given node N and analyzed. -- and then inserted before the given node N and analyzed.
......
...@@ -536,7 +536,8 @@ package Rtsfind is ...@@ -536,7 +536,8 @@ package Rtsfind is
RO_RT_Delay_Until, -- Ada.Real_Time.Delays RO_RT_Delay_Until, -- Ada.Real_Time.Delays
RO_RT_To_Duration, -- Ada.Real_Time.Delays RO_RT_To_Duration, -- Ada.Real_Time.Delays
RE_Timing_Event, -- Ada_Real_Time_Timing_Events RE_Set_Handler, -- Ada_Real_Time.Timing_Events
RE_Timing_Event, -- Ada_Real_Time.Timing_Events
RE_Root_Stream_Type, -- Ada.Streams RE_Root_Stream_Type, -- Ada.Streams
RE_Stream_Element, -- Ada.Streams RE_Stream_Element, -- Ada.Streams
...@@ -1707,6 +1708,7 @@ package Rtsfind is ...@@ -1707,6 +1708,7 @@ package Rtsfind is
RO_RT_Delay_Until => Ada_Real_Time_Delays, RO_RT_Delay_Until => Ada_Real_Time_Delays,
RO_RT_To_Duration => Ada_Real_Time_Delays, RO_RT_To_Duration => Ada_Real_Time_Delays,
RE_Set_Handler => Ada_Real_Time_Timing_Events,
RE_Timing_Event => Ada_Real_Time_Timing_Events, RE_Timing_Event => Ada_Real_Time_Timing_Events,
RE_Root_Stream_Type => Ada_Streams, RE_Root_Stream_Type => Ada_Streams,
......
...@@ -1419,8 +1419,8 @@ package body Sem_Ch10 is ...@@ -1419,8 +1419,8 @@ package body Sem_Ch10 is
P := Parent_Spec (Unit (N)); P := Parent_Spec (Unit (N));
loop loop
if Unit (P) = Lib_U then if Unit (P) = Lib_U then
Error_Msg_N ("limited with_clause of immediate " Error_Msg_N ("limited with_clause cannot "
& "ancestor not allowed", Item); & "name ancestor", Item);
exit; exit;
end if; end if;
......
...@@ -5554,6 +5554,13 @@ package body Sem_Res is ...@@ -5554,6 +5554,13 @@ package body Sem_Res is
Check_Potentially_Blocking_Operation (N); Check_Potentially_Blocking_Operation (N);
end if; end if;
-- A call to Ada.Real_Time.Timing_Events.Set_Handler violates
-- restriction No_Relative_Delay (AI-0211).
if Is_RTE (Nam, RE_Set_Handler) then
Check_Restriction (No_Relative_Delay, N);
end if;
-- Issue an error for a call to an eliminated subprogram. We skip this -- Issue an error for a call to an eliminated subprogram. We skip this
-- in a spec expression, e.g. a call in a default parameter value, since -- in a spec expression, e.g. a call in a default parameter value, since
-- we are not really doing a call at this time. That's important because -- we are not really doing a call at this time. That's important because
......
...@@ -3468,71 +3468,6 @@ package body Sem_Util is ...@@ -3468,71 +3468,6 @@ package body Sem_Util is
end if; end if;
end First_Actual; end First_Actual;
-------------------------
-- Full_Qualified_Name --
-------------------------
function Full_Qualified_Name (E : Entity_Id) return String_Id is
Res : String_Id;
pragma Warnings (Off, Res);
function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
-- Compute recursively the qualified name without NUL at the end
----------------------------------
-- Internal_Full_Qualified_Name --
----------------------------------
function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
Ent : Entity_Id := E;
Parent_Name : String_Id := No_String;
begin
-- Deals properly with child units
if Nkind (Ent) = N_Defining_Program_Unit_Name then
Ent := Defining_Identifier (Ent);
end if;
-- Compute qualification recursively (only "Standard" has no scope)
if Present (Scope (Scope (Ent))) then
Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
end if;
-- Every entity should have a name except some expanded blocks
-- don't bother about those.
if Chars (Ent) = No_Name then
return Parent_Name;
end if;
-- Add a period between Name and qualification
if Parent_Name /= No_String then
Start_String (Parent_Name);
Store_String_Char (Get_Char_Code ('.'));
else
Start_String;
end if;
-- Generates the entity name in upper case
Get_Decoded_Name_String (Chars (Ent));
Set_All_Upper_Case;
Store_String_Chars (Name_Buffer (1 .. Name_Len));
return End_String;
end Internal_Full_Qualified_Name;
-- Start of processing for Full_Qualified_Name
begin
Res := Internal_Full_Qualified_Name (E);
Store_String_Char (Get_Char_Code (ASCII.NUL));
return End_String;
end Full_Qualified_Name;
----------------------- -----------------------
-- Gather_Components -- -- Gather_Components --
----------------------- -----------------------
......
...@@ -379,11 +379,6 @@ package Sem_Util is ...@@ -379,11 +379,6 @@ package Sem_Util is
-- is always the expression (not the N_Parameter_Association nodes, -- is always the expression (not the N_Parameter_Association nodes,
-- even if named association is used). -- even if named association is used).
function Full_Qualified_Name (E : Entity_Id) return String_Id;
-- Generates the string literal corresponding to the E's full qualified
-- name in upper case. An ASCII.NUL is appended as the last character.
-- The names in the string are generated by Namet.Get_Decoded_Name_String.
procedure Gather_Components procedure Gather_Components
(Typ : Entity_Id; (Typ : Entity_Id;
Comp_List : Node_Id; Comp_List : Node_Id;
......
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