Skip to content

R
riscv-gcc-1
Commit afbcdf5e by Arnaud Charlet
Options

[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
Showing with 98 additions and 81 deletions
gcc/ada/ChangeLog
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.
2010-10-07 Robert Dewar <dewar@adacore.com>
......
gcc/ada/exp_ch11.adb
......@@ -1265,7 +1265,7 @@ package body Exp_Ch11 is
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
Strval => Full_Qualified_Name (Id))));
Strval => Fully_Qualified_Name_String (Id))));
Set_Is_Statically_Allocated (Exname);
......
gcc/ada/exp_disp.adb
......@@ -4483,8 +4483,7 @@ package body Exp_Disp is
end loop;
end if;
-- Get the _tag entity and the number of primitives of its dispatch
-- table.
-- Get the _tag entity and number of primitives of its dispatch table
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
......@@ -4654,7 +4653,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
Full_Qualified_Name (First_Subtype (Typ)))));
Fully_Qualified_Name_String (First_Subtype (Typ)))));
Set_Is_Statically_Allocated (Exname);
Set_Is_True_Constant (Exname);
......@@ -4768,7 +4767,7 @@ package body Exp_Disp is
New_External_Name (Tname, 'A'));
Full_Name : constant String_Id :=
Full_Qualified_Name (First_Subtype (Typ));
Fully_Qualified_Name_String (First_Subtype (Typ));
Str1_Id : String_Id;
Str2_Id : String_Id;
......
gcc/ada/exp_dist.adb
......@@ -5541,7 +5541,7 @@ package body Exp_Dist is
-- Name
Make_String_Literal (Loc,
Full_Qualified_Name (Desig)),
Fully_Qualified_Name_String (Desig)),
-- Handler
......@@ -5887,7 +5887,7 @@ package body Exp_Dist is
Unchecked_Convert_To (RTE (RE_Address),
New_Occurrence_Of (RACW_Parameter, Loc)),
Make_String_Literal (Loc,
Strval => Full_Qualified_Name
Strval => Fully_Qualified_Name_String
(Etype (Designated_Type (RACW_Type)))),
Build_Stub_Tag (Loc, RACW_Type),
New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
......@@ -6083,7 +6083,7 @@ package body Exp_Dist is
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Object),
Make_String_Literal (Loc,
Strval => Full_Qualified_Name
Strval => Fully_Qualified_Name_String
(Etype (Designated_Type (RACW_Type)))),
Build_Stub_Tag (Loc, RACW_Type),
New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
......
gcc/ada/exp_util.adb
......@@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
......@@ -1753,6 +1754,62 @@ package body Exp_Util is
Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
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 --
------------------------
......
gcc/ada/exp_util.ads
......@@ -403,6 +403,10 @@ package Exp_Util is
-- Force_Evaluation further guarantees that all evaluations will yield
-- 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);
-- If polling is active, then a call to the Poll routine is built,
-- and then inserted before the given node N and analyzed.
......
gcc/ada/rtsfind.ads
......@@ -536,7 +536,8 @@ package Rtsfind is
RO_RT_Delay_Until, -- 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_Stream_Element, -- Ada.Streams
......@@ -1707,6 +1708,7 @@ package Rtsfind is
RO_RT_Delay_Until => 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_Root_Stream_Type => Ada_Streams,
......
gcc/ada/sem_ch10.adb
......@@ -1419,8 +1419,8 @@ package body Sem_Ch10 is
P := Parent_Spec (Unit (N));
loop
if Unit (P) = Lib_U then
Error_Msg_N ("limited with_clause of immediate "
& "ancestor not allowed", Item);
Error_Msg_N ("limited with_clause cannot "
& "name ancestor", Item);
exit;
end if;
......
gcc/ada/sem_res.adb
......@@ -5554,6 +5554,13 @@ package body Sem_Res is
Check_Potentially_Blocking_Operation (N);
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
-- 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
......
gcc/ada/sem_util.adb
......@@ -3468,71 +3468,6 @@ package body Sem_Util is
end if;
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 --
-----------------------
......
gcc/ada/sem_util.ads
......@@ -379,11 +379,6 @@ package Sem_Util is
-- is always the expression (not the N_Parameter_Association nodes,
-- 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
(Typ : Entity_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