Skip to content

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

[multiple changes] 

2012-10-04  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Set_CPP_Constructors_Old): Removed.
	(Set_CPP_Constructors): Code cleanup.

2012-10-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb (Is_Ancestor_Unit): Make global, for use elsewhere.
	(Install_Private_with_Clauses): if clause is private and limited,
	do not install the limited view if the library unit is an ancestor
	of the unit being compiled.  This unusual configuration occurs
	when compiling a unit DDP, when an ancestor P of DDP has a
	private limited with clause on a descendant of P that is itself
	an ancestor of DDP.

From-SVN: r192069
parent 4bb43ffb
Showing with 139 additions and 220 deletions
gcc/ada/ChangeLog
2012-10-04 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Set_CPP_Constructors_Old): Removed.
(Set_CPP_Constructors): Code cleanup.
2012-10-04 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb (Is_Ancestor_Unit): Make global, for use elsewhere.
(Install_Private_with_Clauses): if clause is private and limited,
do not install the limited view if the library unit is an ancestor
of the unit being compiled. This unusual configuration occurs
when compiling a unit DDP, when an ancestor P of DDP has a
private limited with clause on a descendant of P that is itself
an ancestor of DDP.
2012-10-04 Vincent Celier <celier@adacore.com> 2012-10-04 Vincent Celier <celier@adacore.com>
* prj-proc.adb (Process_Package_Declaration): Use project * prj-proc.adb (Process_Package_Declaration): Use project
......
gcc/ada/exp_disp.adb
...@@ -8447,41 +8447,22 @@ package body Exp_Disp is ...@@ -8447,41 +8447,22 @@ package body Exp_Disp is
procedure Set_CPP_Constructors (Typ : Entity_Id) is procedure Set_CPP_Constructors (Typ : Entity_Id) is
procedure Set_CPP_Constructors_Old (Typ : Entity_Id); function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
-- For backward compatibility this routine handles CPP constructors -- Duplicate the parameters profile of the imported C++ constructor
-- of non-tagged types. -- adding an access to the object as an additional parameter.
procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
Loc : Source_Ptr; Loc : constant Source_Ptr := Sloc (E);
Init : Entity_Id;
E : Entity_Id;
Found : Boolean := False;
P : Node_Id;
Parms : List_Id; Parms : List_Id;
P : Node_Id;
Covers_Default_Constructor : Entity_Id := Empty;
begin begin
-- Look for the constructor entities
E := Next_Entity (Typ);
while Present (E) loop
if Ekind (E) = E_Function
and then Is_Constructor (E)
then
-- Create the init procedure
Found := True;
Loc := Sloc (E);
Init := Make_Defining_Identifier (Loc,
Make_Init_Proc_Name (Typ));
Parms := Parms :=
New_List ( New_List (
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_X), Make_Defining_Identifier (Loc, Name_uInit),
Parameter_Type => Parameter_Type => New_Reference_To (Typ, Loc)));
New_Reference_To (Typ, Loc)));
if Present (Parameter_Specifications (Parent (E))) then if Present (Parameter_Specifications (Parent (E))) then
P := First (Parameter_Specifications (Parent (E))); P := First (Parameter_Specifications (Parent (E)));
...@@ -8490,110 +8471,26 @@ package body Exp_Disp is ...@@ -8490,110 +8471,26 @@ package body Exp_Disp is
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars (Defining_Identifier (P))), Chars => Chars (Defining_Identifier (P))),
Parameter_Type => Parameter_Type => New_Copy_Tree (Parameter_Type (P)),
New_Copy_Tree (Parameter_Type (P)),
Expression => New_Copy_Tree (Expression (P)))); Expression => New_Copy_Tree (Expression (P))));
Next (P); Next (P);
end loop; end loop;
end if; end if;
Discard_Node ( return Parms;
Make_Subprogram_Declaration (Loc, end Gen_Parameters_Profile;
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Init,
Parameter_Specifications => Parms)));
Set_Init_Proc (Typ, Init);
Set_Is_Imported (Init);
Set_Is_Constructor (Init);
Set_Interface_Name (Init, Interface_Name (E));
Set_Convention (Init, Convention_CPP);
Set_Is_Public (Init);
Set_Has_Completion (Init);
-- If this constructor has parameters and all its parameters
-- have defaults then it covers the default constructor. The
-- semantic analyzer ensures that only one constructor with
-- defaults covers the default constructor.
if Present (Parameter_Specifications (Parent (E)))
and then Needs_No_Actuals (E)
then
Covers_Default_Constructor := Init;
end if;
end if;
Next_Entity (E);
end loop;
-- If there are no constructors, mark the type as abstract since we
-- won't be able to declare objects of that type.
if not Found then
Set_Is_Abstract_Type (Typ);
end if;
-- Handle constructor that has all its parameters with defaults and
-- hence it covers the default constructor. We generate a wrapper IP
-- which calls the covering constructor.
if Present (Covers_Default_Constructor) then
declare
Body_Stmts : List_Id;
Wrapper_Id : Entity_Id;
Wrapper_Body_Node : Node_Id;
begin
Loc := Sloc (Covers_Default_Constructor);
Body_Stmts := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Covers_Default_Constructor, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_uInit))));
Wrapper_Id := Make_Defining_Identifier (Loc,
Make_Init_Proc_Name (Typ));
Wrapper_Body_Node :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Wrapper_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uInit),
Parameter_Type =>
New_Reference_To (Typ, Loc)))),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts,
Exception_Handlers => No_List));
Discard_Node (Wrapper_Body_Node);
Set_Init_Proc (Typ, Wrapper_Id);
end;
end if;
end Set_CPP_Constructors_Old;
-- Local variables -- Local variables
Loc : Source_Ptr; Loc : Source_Ptr;
E : Entity_Id; E : Entity_Id;
Found : Boolean := False; Found : Boolean := False;
IP : Entity_Id;
IP_Body : Node_Id;
P : Node_Id; P : Node_Id;
Parms : List_Id; Parms : List_Id;
Constructor_Decl_Node : Node_Id;
Constructor_Id : Entity_Id;
Wrapper_Id : Entity_Id;
Wrapper_Body_Node : Node_Id;
Actuals : List_Id;
Body_Stmts : List_Id;
Init_Tags_List : List_Id;
Covers_Default_Constructor : Entity_Id := Empty; Covers_Default_Constructor : Entity_Id := Empty;
-- Start of processing for Set_CPP_Constructor -- Start of processing for Set_CPP_Constructor
...@@ -8601,22 +8498,6 @@ package body Exp_Disp is ...@@ -8601,22 +8498,6 @@ package body Exp_Disp is
begin begin
pragma Assert (Is_CPP_Class (Typ)); pragma Assert (Is_CPP_Class (Typ));
-- For backward compatibility the compiler accepts C++ classes
-- imported through non-tagged record types. In such case the
-- wrapper of the C++ constructor is useless because the _tag
-- component is not available.
-- Example:
-- type Root is limited record ...
-- pragma Import (CPP, Root);
-- function New_Root return Root;
-- pragma CPP_Constructor (New_Root, ... );
if not Is_Tagged_Type (Typ) then
Set_CPP_Constructors_Old (Typ);
return;
end if;
-- Look for the constructor entities -- Look for the constructor entities
E := Next_Entity (Typ); E := Next_Entity (Typ);
...@@ -8626,30 +8507,60 @@ package body Exp_Disp is ...@@ -8626,30 +8507,60 @@ package body Exp_Disp is
then then
Found := True; Found := True;
Loc := Sloc (E); Loc := Sloc (E);
Parms := Gen_Parameters_Profile (E);
IP :=
Make_Defining_Identifier (Loc,
Chars => Make_Init_Proc_Name (Typ));
-- Generate the declaration of the imported C++ constructor -- Case 1: Constructor of non-tagged type
Parms := -- If the C++ class has no virtual methods then the matching Ada
New_List ( -- type is a non-tagged record type. In such case there is no need
Make_Parameter_Specification (Loc, -- to generate a wrapper of the C++ constructor because the _tag
Defining_Identifier => -- component is not available.
Make_Defining_Identifier (Loc, Name_uInit),
Parameter_Type =>
New_Reference_To (Typ, Loc)));
if Present (Parameter_Specifications (Parent (E))) then if not Is_Tagged_Type (Typ) then
P := First (Parameter_Specifications (Parent (E))); Discard_Node
while Present (P) loop (Make_Subprogram_Declaration (Loc,
Append_To (Parms, Specification =>
Make_Parameter_Specification (Loc, Make_Procedure_Specification (Loc,
Defining_Identifier => Defining_Unit_Name => IP,
Make_Defining_Identifier (Loc, Parameter_Specifications => Parms)));
Chars (Defining_Identifier (P))),
Parameter_Type => New_Copy_Tree (Parameter_Type (P)))); Set_Init_Proc (Typ, IP);
Next (P); Set_Is_Imported (IP);
end loop; Set_Is_Constructor (IP);
end if; Set_Interface_Name (IP, Interface_Name (E));
Set_Convention (IP, Convention_CPP);
Set_Is_Public (IP);
Set_Has_Completion (IP);
-- Case 2: Constructor of a tagged type
-- In this case we generate the IP as a wrapper of the the
-- C++ constructor because IP must also save copy of the _tag
-- generated in the C++ side. The copy of the _tag is used by
-- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
-- Generate:
-- procedure IP (_init : Typ; ...) is
-- procedure ConstructorP (_init : Typ; ...);
-- pragma Import (ConstructorP);
-- begin
-- ConstructorP (_init, ...);
-- if Typ._tag = null then
-- Typ._tag := _init._tag;
-- end if;
-- end IP;
else
declare
Body_Stmts : constant List_Id := New_List;
Constructor_Id : Entity_Id;
Constructor_Decl_Node : Node_Id;
Init_Tags_List : List_Id;
begin
Constructor_Id := Make_Temporary (Loc, 'P'); Constructor_Id := Make_Temporary (Loc, 'P');
Constructor_Decl_Node := Constructor_Decl_Node :=
...@@ -8665,37 +8576,16 @@ package body Exp_Disp is ...@@ -8665,37 +8576,16 @@ package body Exp_Disp is
Set_Is_Public (Constructor_Id); Set_Is_Public (Constructor_Id);
Set_Has_Completion (Constructor_Id); Set_Has_Completion (Constructor_Id);
-- Build the wrapper of this constructor -- Build the init procedure as a wrapper of this constructor
Parms :=
New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uInit),
Parameter_Type =>
New_Reference_To (Typ, Loc)));
if Present (Parameter_Specifications (Parent (E))) then
P := First (Parameter_Specifications (Parent (E)));
while Present (P) loop
Append_To (Parms,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars (Defining_Identifier (P))),
Parameter_Type =>
New_Copy_Tree (Parameter_Type (P)),
Expression => New_Copy_Tree (Expression (P))));
Next (P);
end loop;
end if;
Body_Stmts := New_List; Parms := Gen_Parameters_Profile (E);
-- Invoke the C++ constructor -- Invoke the C++ constructor
Actuals := New_List; declare
Actuals : constant List_Id := New_List;
begin
P := First (Parms); P := First (Parms);
while Present (P) loop while Present (P) loop
Append_To (Actuals, Append_To (Actuals,
...@@ -8707,6 +8597,7 @@ package body Exp_Disp is ...@@ -8707,6 +8597,7 @@ package body Exp_Disp is
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Constructor_Id, Loc), Name => New_Reference_To (Constructor_Id, Loc),
Parameter_Associations => Actuals)); Parameter_Associations => Actuals));
end;
-- Initialize copies of C++ primary and secondary tags -- Initialize copies of C++ primary and secondary tags
...@@ -8723,10 +8614,12 @@ package body Exp_Disp is ...@@ -8723,10 +8614,12 @@ package body Exp_Disp is
while Present (Tag_Elmt) while Present (Tag_Elmt)
and then Is_Tag (Node (Tag_Elmt)) and then Is_Tag (Node (Tag_Elmt))
loop loop
-- Skip the following assertion with primary tags because -- Skip the following assertion with primary tags
-- Related_Type is not set on primary tag components -- because Related_Type is not set on primary tag
-- components
pragma Assert (Tag_Comp = First_Tag_Component (Typ) pragma Assert
(Tag_Comp = First_Tag_Component (Typ)
or else Related_Type (Node (Tag_Elmt)) or else Related_Type (Node (Tag_Elmt))
= Related_Type (Tag_Comp)); = Related_Type (Tag_Comp));
...@@ -8759,14 +8652,11 @@ package body Exp_Disp is ...@@ -8759,14 +8652,11 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Null_Address), Loc))), New_Reference_To (RTE (RE_Null_Address), Loc))),
Then_Statements => Init_Tags_List)); Then_Statements => Init_Tags_List));
Wrapper_Id := Make_Defining_Identifier (Loc, IP_Body :=
Make_Init_Proc_Name (Typ));
Wrapper_Body_Node :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
Make_Procedure_Specification (Loc, Make_Procedure_Specification (Loc,
Defining_Unit_Name => Wrapper_Id, Defining_Unit_Name => IP,
Parameter_Specifications => Parms), Parameter_Specifications => Parms),
Declarations => New_List (Constructor_Decl_Node), Declarations => New_List (Constructor_Decl_Node),
Handled_Statement_Sequence => Handled_Statement_Sequence =>
...@@ -8774,8 +8664,10 @@ package body Exp_Disp is ...@@ -8774,8 +8664,10 @@ package body Exp_Disp is
Statements => Body_Stmts, Statements => Body_Stmts,
Exception_Handlers => No_List)); Exception_Handlers => No_List));
Discard_Node (Wrapper_Body_Node); Discard_Node (IP_Body);
Set_Init_Proc (Typ, Wrapper_Id); Set_Init_Proc (Typ, IP);
end;
end if;
-- If this constructor has parameters and all its parameters -- If this constructor has parameters and all its parameters
-- have defaults then it covers the default constructor. The -- have defaults then it covers the default constructor. The
...@@ -8785,7 +8677,7 @@ package body Exp_Disp is ...@@ -8785,7 +8677,7 @@ package body Exp_Disp is
if Present (Parameter_Specifications (Parent (E))) if Present (Parameter_Specifications (Parent (E)))
and then Needs_No_Actuals (E) and then Needs_No_Actuals (E)
then then
Covers_Default_Constructor := Wrapper_Id; Covers_Default_Constructor := IP;
end if; end if;
end if; end if;
...@@ -8804,6 +8696,10 @@ package body Exp_Disp is ...@@ -8804,6 +8696,10 @@ package body Exp_Disp is
-- which calls the covering constructor. -- which calls the covering constructor.
if Present (Covers_Default_Constructor) then if Present (Covers_Default_Constructor) then
declare
Body_Stmts : List_Id;
begin
Loc := Sloc (Covers_Default_Constructor); Loc := Sloc (Covers_Default_Constructor);
Body_Stmts := New_List ( Body_Stmts := New_List (
...@@ -8813,20 +8709,18 @@ package body Exp_Disp is ...@@ -8813,20 +8709,18 @@ package body Exp_Disp is
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Identifier (Loc, Name_uInit)))); Make_Identifier (Loc, Name_uInit))));
Wrapper_Id := IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
Wrapper_Body_Node := IP_Body :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
Make_Procedure_Specification (Loc, Make_Procedure_Specification (Loc,
Defining_Unit_Name => Wrapper_Id, Defining_Unit_Name => IP,
Parameter_Specifications => New_List ( Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uInit), Make_Defining_Identifier (Loc, Name_uInit),
Parameter_Type => Parameter_Type => New_Reference_To (Typ, Loc)))),
New_Reference_To (Typ, Loc)))),
Declarations => No_List, Declarations => No_List,
...@@ -8835,8 +8729,9 @@ package body Exp_Disp is ...@@ -8835,8 +8729,9 @@ package body Exp_Disp is
Statements => Body_Stmts, Statements => Body_Stmts,
Exception_Handlers => No_List)); Exception_Handlers => No_List));
Discard_Node (Wrapper_Body_Node); Discard_Node (IP_Body);
Set_Init_Proc (Typ, Wrapper_Id); Set_Init_Proc (Typ, IP);
end;
end if; end if;
-- If the CPP type has constructors then it must import also the default -- If the CPP type has constructors then it must import also the default
......
gcc/ada/sem_ch10.adb
...@@ -164,6 +164,11 @@ package body Sem_Ch10 is ...@@ -164,6 +164,11 @@ package body Sem_Ch10 is
-- an enclosing scope. Iterate over context to find child units of U_Name -- an enclosing scope. Iterate over context to find child units of U_Name
-- or of some ancestor of it. -- or of some ancestor of it.
function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
-- When compiling a unit Q descended from some parent unit P, a limited
-- with_clause in the context of P that names some other ancestor of Q
-- must not be installed because the ancestor is immediately visible.
function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean; function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
-- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
-- returns True if Lib_Unit is a library spec which is a child spec, i.e. -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
...@@ -3521,11 +3526,6 @@ package body Sem_Ch10 is ...@@ -3521,11 +3526,6 @@ package body Sem_Ch10 is
-- units. The shadow entities are created when the inserted clause is -- units. The shadow entities are created when the inserted clause is
-- analyzed. Implements Ada 2005 (AI-50217). -- analyzed. Implements Ada 2005 (AI-50217).
function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
-- When compiling a unit Q descended from some parent unit P, a limited
-- with_clause in the context of P that names some other ancestor of Q
-- must not be installed because the ancestor is immediately visible.
--------------------- ---------------------
-- Check_Renamings -- -- Check_Renamings --
--------------------- ---------------------
...@@ -3794,22 +3794,6 @@ package body Sem_Ch10 is ...@@ -3794,22 +3794,6 @@ package body Sem_Ch10 is
end if; end if;
end Expand_Limited_With_Clause; end Expand_Limited_With_Clause;
----------------------
-- Is_Ancestor_Unit --
----------------------
function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
E1 : constant Entity_Id := Defining_Entity (Unit (U1));
E2 : Entity_Id;
begin
if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
E2 := Defining_Entity (Unit (Library_Unit (U2)));
return Is_Ancestor_Package (E1, E2);
else
return False;
end if;
end Is_Ancestor_Unit;
-- Start of processing for Install_Limited_Context_Clauses -- Start of processing for Install_Limited_Context_Clauses
begin begin
...@@ -4061,8 +4045,17 @@ package body Sem_Ch10 is ...@@ -4061,8 +4045,17 @@ package body Sem_Ch10 is
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
and then Private_Present (Item) and then Private_Present (Item)
then then
-- If the unit is an ancestor of the current one, it is the
-- case of a private limited with clause on a child unit, and
-- the compilation of one of its descendants, In that case the
-- limited view is errelevant.
if Limited_Present (Item) then if Limited_Present (Item) then
if not Limited_View_Installed (Item) then if not Limited_View_Installed (Item)
and then
not Is_Ancestor_Unit (Library_Unit (Item),
Cunit (Current_Sem_Unit))
then
Install_Limited_Withed_Unit (Item); Install_Limited_Withed_Unit (Item);
end if; end if;
else else
...@@ -5269,6 +5262,22 @@ package body Sem_Ch10 is ...@@ -5269,6 +5262,22 @@ package body Sem_Ch10 is
(C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T)))); (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
end Is_Legal_Shadow_Entity_In_Body; end Is_Legal_Shadow_Entity_In_Body;
----------------------
-- Is_Ancestor_Unit --
----------------------
function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
E1 : constant Entity_Id := Defining_Entity (Unit (U1));
E2 : Entity_Id;
begin
if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
E2 := Defining_Entity (Unit (Library_Unit (U2)));
return Is_Ancestor_Package (E1, E2);
else
return False;
end if;
end Is_Ancestor_Unit;
----------------------- -----------------------
-- Load_Needed_Body -- -- Load_Needed_Body --
----------------------- -----------------------
......
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