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

[multiple changes]

Browse Source 
2012-02-22  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): Minor reformatting. Simplify the
	entry point for renamings. Detect a case where a source object has
	been transformed into a class-wide renaming of a call to
	Ada.Tags.Displace.
	* exp_util.adb (Is_Displacement_Of_Ctrl_Function_Result): New routine.
	(Is_Finalizable_Transient): Minor reformatting.
	(Is_Tag_To_Class_Wide_Conversion): Minor reformatting.
	(Requires_Cleanup_Actions): Minor reformatting. Simplify the
	entry point for renamings. Detect a case where a source object
	has been transformed into a class-wide renaming of a call to
	Ada.Tags.Displace.
	* exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): New routine.
	(Is_Tag_To_Class_Wide_Conversion): Minor reformatting.

2012-02-22  Ed Schonberg  <schonberg@adacore.com>

	* lib-load.adb (Load_Unit): If the prefix of the name in a
	with-clause is a renaming, add a with-clause on the original unit.
	* sem_ch10.adb (Build_Unit_Name): Remove code made obsolete by
	new handling of renamings in with-clauses.

From-SVN: r184478
This commit is contained in:
Arnaud Charlet 2012-02-22 15:06:51 +01:00
parent 31af889996
commit aab0813011
5 changed files with 152 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/ada/exp_ch7.adb
View File

@ -1816,7 +1816,7 @@ package body Exp_Ch7 is
and then Needs_Finalization (Obj_Typ)
and then not (Ekind (Obj_Id) = E_Constant
and then not Has_Completion (Obj_Id))
and then not Is_Tag_To_CW_Conversion (Obj_Id)
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
then
Processing_Actions;
@ -1894,10 +1894,7 @@ package body Exp_Ch7 is
-- Specific cases of object renamings
elsif Nkind (Decl) = N_Object_Renaming_Declaration
and then Nkind (Name (Decl)) = N_Explicit_Dereference
and then Nkind (Prefix (Name (Decl))) = N_Identifier
then
elsif Nkind (Decl) = N_Object_Renaming_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
@ -1919,6 +1916,19 @@ package body Exp_Ch7 is
and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
then
Processing_Actions (Has_No_Init => True);
-- Detect a case where a source object has been initialized by
-- a controlled function call which was later rewritten as a
-- class-wide conversion of Ada.Tags.Displace.
-- Obj : Class_Wide_Type := Function_Call (...);
-- Temp : ... := Function_Call (...)'reference;
-- Obj : Class_Wide_Type renames
-- (... Ada.Tags.Displace (Temp));
elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
Processing_Actions (Has_No_Init => True);
end if;
-- Inspect the freeze node of an access-to-controlled type and

120
gcc/ada/exp_util.adb
View File

@ -3940,6 +3940,92 @@ package body Exp_Util is
return True;
end Is_All_Null_Statements;
---------------------------------------------
-- Is_Displacement_Of_Ctrl_Function_Result --
---------------------------------------------
function Is_Displacement_Of_Ctrl_Function_Result
(Obj_Id : Entity_Id) return Boolean
is
function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean;
-- Determine whether object declaration N is initialized by a controlled
-- function call.
function Is_Displace_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node is a call to Ada.Tags.Displace.
-- The call might be nested within other actions such as conversions.
----------------------------------
-- Initialized_By_Ctrl_Function --
----------------------------------
function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is
Expr : constant Node_Id := Original_Node (Expression (N));
begin
return
Nkind (Expr) = N_Function_Call
and then Needs_Finalization (Etype (Expr));
end Initialized_By_Ctrl_Function;
----------------------
-- Is_Displace_Call --
----------------------
function Is_Displace_Call (N : Node_Id) return Boolean is
Call : Node_Id := N;
begin
-- Strip various actions which may precede a call to Displace
loop
if Nkind (Call) = N_Explicit_Dereference then
Call := Prefix (Call);
elsif Nkind_In (Call, N_Type_Conversion,
N_Unchecked_Type_Conversion)
then
Call := Expression (Call);
else
exit;
end if;
end loop;
return
Nkind (Call) = N_Function_Call
and then Is_RTE (Entity (Name (Call)), RE_Displace);
end Is_Displace_Call;
-- Local variables
Decl : constant Node_Id := Parent (Obj_Id);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
Orig_Decl : constant Node_Id := Original_Node (Decl);
-- Start of processing for Is_Displacement_Of_Ctrl_Function_Result
begin
-- Detect the following case:
-- Obj : Class_Wide_Type := Function_Call (...);
-- which is rewritten into:
-- Temp : ... := Function_Call (...)'reference;
-- Obj : Class_Wide_Type renames (... Ada.Tags.Displace (Temp));
-- when the return type of the function and the class-wide type require
-- dispatch table pointer displacement.
return
Nkind (Decl) = N_Object_Renaming_Declaration
and then Nkind (Orig_Decl) = N_Object_Declaration
and then Comes_From_Source (Orig_Decl)
and then Initialized_By_Ctrl_Function (Orig_Decl)
and then Is_Class_Wide_Type (Obj_Typ)
and then Is_Displace_Call (Renamed_Object (Obj_Id));
end Is_Displacement_Of_Ctrl_Function_Result;
------------------------------
-- Is_Finalizable_Transient --
------------------------------
@ -4321,7 +4407,7 @@ package body Exp_Util is
-- Do not consider conversions of tags to class-wide types
and then not Is_Tag_To_CW_Conversion (Obj_Id)
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
-- Do not consider containers in the context of iterator loops. Such
-- transient objects must exist for as long as the loop is around,
@ -4851,11 +4937,13 @@ package body Exp_Util is
end if;
end Is_Renamed_Object;
-----------------------------
-- Is_Tag_To_CW_Conversion --
-----------------------------
-------------------------------------
-- Is_Tag_To_Class_Wide_Conversion --
-------------------------------------
function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is
function Is_Tag_To_Class_Wide_Conversion
(Obj_Id : Entity_Id) return Boolean
is
Expr : constant Node_Id := Expression (Parent (Obj_Id));
begin
@ -4864,7 +4952,7 @@ package body Exp_Util is
and then Present (Expr)
and then Nkind (Expr) = N_Unchecked_Type_Conversion
and then Etype (Expression (Expr)) = RTE (RE_Tag);
end Is_Tag_To_CW_Conversion;
end Is_Tag_To_Class_Wide_Conversion;
----------------------------
-- Is_Untagged_Derivation --
@ -7015,7 +7103,7 @@ package body Exp_Util is
and then Needs_Finalization (Obj_Typ)
and then not (Ekind (Obj_Id) = E_Constant
and then not Has_Completion (Obj_Id))
and then not Is_Tag_To_CW_Conversion (Obj_Id)
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
then
return True;
@ -7064,10 +7152,7 @@ package body Exp_Util is
-- Specific cases of object renamings
elsif Nkind (Decl) = N_Object_Renaming_Declaration
and then Nkind (Name (Decl)) = N_Explicit_Dereference
and then Nkind (Prefix (Name (Decl))) = N_Identifier
then
elsif Nkind (Decl) = N_Object_Renaming_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
@ -7089,6 +7174,19 @@ package body Exp_Util is
and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
then
return True;
-- Detect a case where a source object has been initialized by a
-- controlled function call which was later rewritten as a class-
-- wide conversion of Ada.Tags.Displace.
-- Obj : Class_Wide_Type := Function_Call (...);
-- Temp : ... := Function_Call (...)'reference;
-- Obj : Class_Wide_Type renames
-- (... Ada.Tags.Displace (Temp));
elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
return True;
end if;
-- Inspect the freeze node of an access-to-controlled type and look

11
gcc/ada/exp_util.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -521,6 +521,12 @@ package Exp_Util is
-- False otherwise. True for an empty list. It is an error to call this
-- routine with No_List as the argument.
function Is_Displacement_Of_Ctrl_Function_Result
(Obj_Id : Entity_Id) return Boolean;
-- Determine whether Obj_Id is a source object that has been initialized by
-- a controlled function call later rewritten as a class-wide conversion of
-- Ada.Tags.Displace.
function Is_Finalizable_Transient
(Decl : Node_Id;
Rel_Node : Node_Id) return Boolean;
@ -587,7 +593,8 @@ package Exp_Util is
-- We consider that a (1 .. 2) is a renamed object since it is the prefix
-- of the name in the renaming declaration.
function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean;
function Is_Tag_To_Class_Wide_Conversion
(Obj_Id : Entity_Id) return Boolean;
-- Determine whether object Obj_Id is the result of a tag-to-class-wide
-- type conversion.

20
gcc/ada/lib-load.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -406,9 +406,25 @@ package body Lib.Load is
New_Child
(Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump)))));
-- If the load is for a with_clause, for visibility purposes both
-- the renamed entity and renaming one must be available in the
-- current unit: the renamed one in order to retrieve the child
-- unit, and the original one because it may be used as a prefix
-- in the body of the current unit. We add an explicit with_clause
-- for the original parent so that the renaming declaration is
-- properly loaded and analyzed.
if Present (With_Node) then
Insert_After (With_Node,
Make_With_Clause (Sloc (With_Node),
Name => Copy_Separate_Tree (Prefix (Name (With_Node)))));
end if;
-- Save the renaming entity, to establish its visibility when
-- installing the context. The implicit with is on this entity,
-- not on the package it renames.
-- not on the package it renames. This is somewhat redundant given
-- the with_clause just created, but it simplifies subsequent
-- expansion of the current with_clause. Optimizable ???
if Nkind (Error_Node) = N_With_Clause
and then Nkind (Name (Error_Node)) = N_Selected_Component

23
gcc/ada/sem_ch10.adb
View File

@ -2936,32 +2936,11 @@ package body Sem_Ch10 is
function Build_Unit_Name (Nam : Node_Id) return Node_Id is
Ent : Entity_Id;
Renaming : Entity_Id;
Result : Node_Id;
begin
if Nkind (Nam) = N_Identifier then
-- If the parent unit P in the name of the with_clause for P.Q is
-- a renaming of package R, then the entity of the parent is set
-- to R, but the identifier retains Chars (P) to be consistent
-- with the source (see details in lib-load). However the implicit
-- with_clause for the parent must make the entity for P visible,
-- because P.Q may be used as a prefix within the current unit.
-- The entity for P is the current_entity with that name, because
-- the package renaming declaration for it has just been analyzed.
-- Note that this case can only happen if P.Q has already appeared
-- in a previous with_clause in a related unit, such as the
-- library body of the current unit.
if Chars (Nam) /= Chars (Entity (Nam)) then
Renaming := Current_Entity (Nam);
pragma Assert (Renamed_Entity (Renaming) = Entity (Nam));
return New_Occurrence_Of (Renaming, Loc);
else
return New_Occurrence_Of (Entity (Nam), Loc);
end if;
return New_Occurrence_Of (Entity (Nam), Loc);
else
Ent := Entity (Nam);