[Ada] New support for interfacing with C++ non-default constructors
Arnaud Charlet
charlet@adacore.com
Wed Apr 29 13:43:00 GMT 2009
This patch adds new support for interfacing with C++ non-default
constructors. It provides the basic functionality required for
object declaration but also provides support for record components
that are CPP_Class types and are initialized by means of limited
aggregates or through the Ada 2005 extended return statement. The
following test is an example of this new support.
//root.h
class Root {
public:
Root(); // Default constructor
Root(int v); // Non-default constructor
};
//root.cpp
#include "root.h"
#include <iostream>
using namespace std;
Root::Root() {
cout << "C++ default constructor" << endl;
}
Root::Root(int v) {
cout << "C++ non-default constructor.Value=" << v << endl;
}
with Interfaces.C; use Interfaces.C;
package Pkg_CPP_Class is
type Root is tagged limited null record;
pragma Import (CPP, Root);
function Constructor return Root'Class;
pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ev");
function Constructor (v : Integer) return Root'Class;
pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ei");
end;
with Pkg_CPP_Class; use Pkg_CPP_Class;
procedure Test_Obj_Decl is
pragma Warnings (Off);
Obj : Root := Constructor (v => 10);
begin
null;
end;
project Test_Obj_Decl is
for Languages use ("Ada", "C++");
for Main use ("test_obj_decl.adb");
package Naming is
for Specification_Suffix ("c++") use ".h";
for Implementation_Suffix ("c++") use ".cpp";
end Naming;
end Test_Obj_Decl;
Build with e.g. gprbuild -q -Ptest_obj_decl.gpr
Output: C++ non-default constructor. Value=10
Tested on x86_64-pc-linux-gnu, committed on trunk
2009-04-29 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): Disable error message
associated with dyamically tagged expressions if the expression
initializing a tagged type corresponds with a non default CPP
constructor.
(OK_For_Limited_Init): CPP constructor calls are OK for initialization
of limited type objects.
* sem_ch5.adb (Analyze_Assignment): Improve the error message reported
when a CPP constructor is called in an assignment. Disable also the
error message associated with dyamically tagged expressions if the
exporession initializing a tagged type corresponds with a non default
CPP constructor.
* sem_prag.adb (Analyze_Pragma): Remove code disabling the use of
non-default C++ constructors.
* sem_util.ads, sem_util.adb (Is_CPP_Constructor_Call): New subprogram.
* exp_tss.ads, exp_tss.adb (Base_Init_Proc): Add support for
non-default constructors.
(Init_Proc): Add support for non-default constructors.
* exp_disp.adb (Set_Default_Constructor): Removed.
(Set_CPP_Constructors): Code based in removed Set_Default_Constructor
but extending its functionality to handle non-default constructors.
* exp_aggr.adb (Build_Record_Aggr_Code): Add support for non-default
constructors. Minor code cleanup removing unrequired label and goto
statement.
* exp_ch3.adb (Build_Initialization_Call): Add support for non-default
constructors.
(Build_Init_Statements): Add support for non-default constructors.
(Expand_N_Object_Declaration): Add support for non-default constructors.
(Freeze_Record_Type): Replace call to Set_Default_Constructor by call
to Set_CPP_Constructors.
* exp_ch5.adb (Expand_N_Assignment_Statement): Add support for
non-default constructors.
Required to handle its use in build-in-place statements.
* gnat_rm.texi (CPP_Constructor): Document new extended use of this
pragma for non-default C++ constructors and the new compiler support
that allows the use of these constructors in record components, limited
aggregates, and extended return statements.
-------------- next part --------------
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 146944)
+++ exp_aggr.adb (working copy)
@@ -2775,10 +2775,24 @@ package body Exp_Aggr is
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
+ -- C++ constructors
+
+ if Is_CPP_Constructor_Call (Expression (Comp)) then
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Occurrence_Of (Selector,
+ Loc)),
+ Typ => Etype (Selector),
+ Enclos_Type => Typ,
+ With_Default_Init => True,
+ Constructor_Ref => Expression (Comp)));
+
-- Ada 2005 (AI-287): For each default-initialized component generate
-- a call to the corresponding IP subprogram if available.
- if Box_Present (Comp)
+ elsif Box_Present (Comp)
and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
then
if Ekind (Selector) /= E_Discriminant then
@@ -2822,12 +2836,9 @@ package body Exp_Aggr is
Enclos_Type => Typ,
With_Default_Init => True));
- goto Next_Comp;
- end if;
-
-- Prepare for component assignment
- if Ekind (Selector) /= E_Discriminant
+ elsif Ekind (Selector) /= E_Discriminant
or else Nkind (N) = N_Extension_Aggregate
then
-- All the discriminants have now been assigned
@@ -3107,8 +3118,6 @@ package body Exp_Aggr is
end;
end if;
- <<Next_Comp>>
-
Next (Comp);
end loop;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 146949)
+++ exp_ch3.adb (working copy)
@@ -1368,22 +1368,35 @@ package body Exp_Ch3 is
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False) return List_Id
+ With_Default_Init : Boolean := False;
+ Constructor_Ref : Node_Id := Empty) return List_Id
is
- First_Arg : Node_Id;
+ Res : constant List_Id := New_List;
+ Arg : Node_Id;
Args : List_Id;
- Decls : List_Id;
+ Controller_Typ : Entity_Id;
Decl : Node_Id;
+ Decls : List_Id;
Discr : Entity_Id;
- Arg : Node_Id;
- Proc : constant Entity_Id := Base_Init_Proc (Typ);
- Init_Type : constant Entity_Id := Etype (First_Formal (Proc));
- Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type);
- Res : constant List_Id := New_List;
+ First_Arg : Node_Id;
+ Full_Init_Type : Entity_Id;
Full_Type : Entity_Id := Typ;
- Controller_Typ : Entity_Id;
+ Init_Type : Entity_Id;
+ Proc : Entity_Id;
begin
+ pragma Assert (Constructor_Ref = Empty
+ or else Is_CPP_Constructor_Call (Constructor_Ref));
+
+ if No (Constructor_Ref) then
+ Proc := Base_Init_Proc (Typ);
+ else
+ Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
+ end if;
+
+ Init_Type := Etype (First_Formal (Proc));
+ Full_Init_Type := Underlying_Type (Init_Type);
+
-- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
-- is active (in which case we make the call anyway, since in the
-- actual compiled client it may be non null).
@@ -1579,6 +1592,10 @@ package body Exp_Ch3 is
and then Chars (Selector_Name (Id_Ref)) = Name_uParent
then
Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
+
+ elsif Present (Constructor_Ref) then
+ Append_List_To (Args,
+ New_Copy_List (Parameter_Associations (Constructor_Ref)));
end if;
Append_To (Res,
@@ -2589,7 +2606,21 @@ package body Exp_Ch3 is
-- Case of explicit initialization
if Present (Expression (Decl)) then
- Stmts := Build_Assignment (Id, Expression (Decl));
+ if Is_CPP_Constructor_Call (Expression (Decl)) then
+ Stmts :=
+ Build_Initialization_Call
+ (Loc,
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ,
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map,
+ Constructor_Ref => Expression (Decl));
+ else
+ Stmts := Build_Assignment (Id, Expression (Decl));
+ end if;
-- Case of composite component with its own Init_Proc
@@ -4622,6 +4653,26 @@ package body Exp_Ch3 is
(Access_Disp_Table (Base_Type (Typ)))),
Loc))));
+ elsif Is_Tagged_Type (Typ)
+ and then Is_CPP_Constructor_Call (Expr)
+ then
+ -- The call to the initialization procedure does NOT freeze the
+ -- object being initialized.
+
+ Id_Ref := New_Reference_To (Def_Id, Loc);
+ Set_Must_Not_Freeze (Id_Ref);
+ Set_Assignment_OK (Id_Ref);
+
+ Insert_Actions_After (Init_After,
+ Build_Initialization_Call (Loc, Id_Ref, Typ,
+ Constructor_Ref => Expr));
+
+ -- We remove here the original call to the constructor
+ -- to avoid its management in the backend
+
+ Set_Expression (N, Empty);
+ return;
+
-- For discrete types, set the Is_Known_Valid flag if the
-- initializing value is known to be valid.
@@ -5629,7 +5680,7 @@ package body Exp_Ch3 is
if Is_CPP_Class (Def_Id) then
Set_All_DT_Position (Def_Id);
- Set_Default_Constructor (Def_Id);
+ Set_CPP_Constructors (Def_Id);
-- Create the tag entities with a minimum decoration
Index: exp_ch3.ads
===================================================================
--- exp_ch3.ads (revision 146929)
+++ exp_ch3.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
@@ -67,7 +67,8 @@ package Exp_Ch3 is
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False) return List_Id;
+ With_Default_Init : Boolean := False;
+ Constructor_Ref : Node_Id := Empty) return List_Id;
-- Builds a call to the initialization procedure for the base type of Typ,
-- passing it the object denoted by Id_Ref, plus additional parameters as
-- appropriate for the type (the _Master, for task types, for example).
@@ -88,6 +89,9 @@ package Exp_Ch3 is
-- Ada 2005 (AI-287): With_Default_Init is used to indicate that the
-- initialization call corresponds to a default initialized component
-- of an aggregate.
+ --
+ -- Constructor_Ref is a call to a constructor subprogram. It is currently
+ -- used only to support C++ constructors.
procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id);
-- If the designated type of an access type is a task type or contains
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 146929)
+++ exp_disp.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
@@ -6965,57 +6965,76 @@ package body Exp_Disp is
end if;
end Set_All_DT_Position;
- -----------------------------
- -- Set_Default_Constructor --
- -----------------------------
+ --------------------------
+ -- Set_CPP_Constructors --
+ --------------------------
- procedure Set_Default_Constructor (Typ : Entity_Id) is
+ procedure Set_CPP_Constructors (Typ : Entity_Id) is
Loc : Source_Ptr;
Init : Entity_Id;
- Param : Entity_Id;
E : Entity_Id;
+ Found : Boolean := False;
+ P : Node_Id;
+ Parms : List_Id;
begin
- -- Look for the default constructor entity. For now only the
- -- default constructor has the flag Is_Constructor.
+ -- Look for the constructor entities
E := Next_Entity (Typ);
- while Present (E)
- and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
- loop
- Next_Entity (E);
- end loop;
+ while Present (E) loop
+ if Ekind (E) = E_Function
+ and then Is_Constructor (E)
+ then
+ -- Create the init procedure
- -- Create the init procedure
+ Found := True;
+ Loc := Sloc (E);
+ Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
+ Parms :=
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_X),
+ 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))));
+ Next (P);
+ end loop;
+ end if;
+
+ Discard_Node (
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Init,
+ Parameter_Specifications => Parms)));
+
+ Set_Init_Proc (Typ, Init);
+ Set_Is_Imported (Init);
+ Set_Interface_Name (Init, Interface_Name (E));
+ Set_Convention (Init, Convention_C);
+ Set_Is_Public (Init);
+ Set_Has_Completion (Init);
+ end if;
- if Present (E) then
- Loc := Sloc (E);
- Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
- Param := Make_Defining_Identifier (Loc, Name_X);
-
- Discard_Node (
- Make_Subprogram_Declaration (Loc,
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Init,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Param,
- Parameter_Type => New_Reference_To (Typ, Loc))))));
-
- Set_Init_Proc (Typ, Init);
- Set_Is_Imported (Init);
- Set_Interface_Name (Init, Interface_Name (E));
- Set_Convention (Init, Convention_C);
- Set_Is_Public (Init);
- Set_Has_Completion (Init);
+ 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.
- else
+ if not Found then
Set_Is_Abstract_Type (Typ);
end if;
- end Set_Default_Constructor;
+ end Set_CPP_Constructors;
--------------------------
-- Set_DTC_Entity_Value --
Index: exp_disp.ads
===================================================================
--- exp_disp.ads (revision 146929)
+++ exp_disp.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
@@ -328,10 +328,13 @@ package Exp_Disp is
-- Class case check that no pragma CPP_Virtual is missing and that the
-- DT_Position are coherent
- procedure Set_Default_Constructor (Typ : Entity_Id);
- -- Typ is a CPP_Class type. Create the Init procedure of that type to
- -- be the default constructor (i.e. the function returning this type,
- -- having a pragma CPP_Constructor and no parameter)
+ procedure Set_CPP_Constructors (Typ : Entity_Id);
+ -- Typ is a CPP_Class type. Create the Init procedures of that type
+ -- required to handle its default and non-default constructors. The
+ -- functions to which pragma CPP_Constructor is applied in the sources
+ -- are functions returning this type, and having an implicit access to the
+ -- target object in its first argument; such implicit argument is explicit
+ -- in the IP procedures built here.
procedure Set_DTC_Entity_Value
(Tagged_Type : Entity_Id;
Index: exp_tss.adb
===================================================================
--- exp_tss.adb (revision 146929)
+++ exp_tss.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
@@ -27,6 +27,7 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
+with Nlists; use Nlists;
with Lib; use Lib;
with Restrict; use Restrict;
with Rident; use Rident;
@@ -40,7 +41,10 @@ package body Exp_Tss is
-- Base_Init_Proc --
--------------------
- function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
+ function Base_Init_Proc
+ (Typ : Entity_Id;
+ Ref : Entity_Id := Empty) return Entity_Id
+ is
Full_Type : E;
Proc : Entity_Id;
@@ -55,6 +59,7 @@ package body Exp_Tss is
if No (Full_Type) then
return Empty;
+
elsif Is_Concurrent_Type (Full_Type)
and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
then
@@ -63,16 +68,17 @@ package body Exp_Tss is
-- and possibly an itype.
return Init_Proc
- (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))));
+ (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))),
+ Ref);
else
- Proc := Init_Proc (Base_Type (Full_Type));
+ Proc := Init_Proc (Base_Type (Full_Type), Ref);
if No (Proc)
and then Is_Composite_Type (Full_Type)
and then Is_Derived_Type (Full_Type)
then
- return Init_Proc (Root_Type (Full_Type));
+ return Init_Proc (Root_Type (Full_Type), Ref);
else
return Proc;
end if;
@@ -183,9 +189,14 @@ package body Exp_Tss is
-- Init_Proc --
---------------
- function Init_Proc (Typ : Entity_Id) return Entity_Id is
+ function Init_Proc
+ (Typ : Entity_Id;
+ Ref : Entity_Id := Empty) return Entity_Id
+ is
FN : constant Node_Id := Freeze_Node (Typ);
Elmt : Elmt_Id;
+ E1 : Entity_Id;
+ E2 : Entity_Id;
begin
if No (FN) then
@@ -194,11 +205,57 @@ package body Exp_Tss is
elsif No (TSS_Elist (FN)) then
return Empty;
- else
+ elsif No (Ref) then
+ Elmt := First_Elmt (TSS_Elist (FN));
+ while Present (Elmt) loop
+ if Is_Init_Proc (Node (Elmt)) then
+ if not Is_CPP_Class (Typ) then
+ return Node (Elmt);
+
+ -- In case of CPP classes we are searching here for the
+ -- default constructor and hence we must skip non-default
+ -- constructors (if any)
+
+ elsif No (Next
+ (First
+ (Parameter_Specifications (Parent (Node (Elmt))))))
+ then
+ return Node (Elmt);
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Non-default constructors are currently supported only in the
+ -- context of interfacing with C++
+
+ else pragma Assert (Is_CPP_Class (Typ));
+
+ -- Use the referenced function to locate the IP procedure that
+ -- corresponds with the C++ constructor
+
Elmt := First_Elmt (TSS_Elist (FN));
while Present (Elmt) loop
if Is_Init_Proc (Node (Elmt)) then
- return Node (Elmt);
+ E1 := Next_Formal (First_Formal (Node (Elmt)));
+ E2 := First_Formal (Ref);
+
+ while Present (E1) and then Present (E2) loop
+ if Chars (E1) /= Chars (E2)
+ or else Ekind (E1) /= Ekind (E2)
+ or else Etype (E1) /= Etype (E2)
+ then
+ exit;
+ end if;
+
+ E1 := Next_Formal (E1);
+ E2 := Next_Formal (E2);
+ end loop;
+
+ if No (E1) and then No (E2) then
+ return Node (Elmt);
+ end if;
end if;
Next_Elmt (Elmt);
Index: exp_tss.ads
===================================================================
--- exp_tss.ads (revision 146929)
+++ exp_tss.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
@@ -187,8 +187,9 @@ package Exp_Tss is
-- used to initially install a TSS in the case where the subprogram for the
-- TSS has already been created and its declaration processed.
- function Init_Proc (Typ : Entity_Id) return Entity_Id;
- pragma Inline (Init_Proc);
+ function Init_Proc
+ (Typ : Entity_Id;
+ Ref : Entity_Id := Empty) return Entity_Id;
-- Obtains the _init TSS entry for the given type. This function call is
-- equivalent to TSS (Typ, Name_uInit). The _init TSS is the procedure
-- used to initialize otherwise uninitialized instances of a type. If
@@ -198,14 +199,21 @@ package Exp_Tss is
-- the corresponding base type (see Base_Init_Proc function). A special
-- case arises for concurrent types. Such types do not themselves have an
-- init proc TSS, but initialization is required. The init proc used is
- -- the one for the corresponding record type (see Base_Init_Proc).
+ -- the one for the corresponding record type (see Base_Init_Proc). If
+ -- Ref is present it is call to a subprogram whose profile matches the
+ -- profile of the required constructor (this argument is used to handle
+ -- non-default CPP constructors).
- function Base_Init_Proc (Typ : Entity_Id) return Entity_Id;
+ function Base_Init_Proc
+ (Typ : Entity_Id;
+ Ref : Entity_Id := Empty) return Entity_Id;
-- Obtains the _Init TSS entry from the base type of the entity, and also
-- deals with going indirect through the Corresponding_Record_Type field
-- for concurrent objects (which are initialized with the initialization
- -- routine for the corresponding record type). Returns Empty if there is
- -- no _Init TSS entry for the base type.
+ -- routine for the corresponding record type). Returns Empty if there is no
+ -- _Init TSS entry for the base type. If Ref is present it is a call to a
+ -- subprogram whose profile matches the profile of the required constructor
+ -- (this argument is used to handle non-default CPP constructors).
procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id);
pragma Inline (Set_Init_Proc);
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 146929)
+++ gnat_rm.texi (working copy)
@@ -1542,19 +1542,30 @@ must be of one of the following forms:
@end itemize
@noindent
-where @var{T} is a tagged type to which the pragma @code{CPP_Class} applies.
+where @var{T} is a tagged limited type imported from C++ with pragma
+@code{Import} and @code{Convention} = @code{CPP}.
The first form is the default constructor, used when an object of type
-@var{T} is created on the Ada side with no explicit constructor. Other
-constructors (including the copy constructor, which is simply a special
+@var{T} is created on the Ada side with no explicit constructor. The
+second form covers all the non-default constructors of the type.
+Constructors (including the copy constructor, which is simply a special
case of the second form in which the one and only argument is of type
-@var{T}), can only appear in two contexts:
+@var{T}), can only appear in the following contexts:
@itemize @bullet
@item
On the right side of an initialization of an object of type @var{T}.
@item
+On the right side of an initialization of a record component of type @var{T}.
+@item
In an extension aggregate for an object of a type derived from @var{T}.
+@item
+In an Ada 2005 limited aggregate.
+@item
+In an Ada 2005 nested limited aggregate.
+@item
+In an Ada 2005 limited aggregate that initializes an object built in
+place by an extended return statement.
@end itemize
@noindent
@@ -1564,8 +1575,10 @@ argument (the object being initialized)
level. GNAT issues the appropriate call, whatever it is, to get the
object properly initialized.
-In the case of derived objects, you may use one of two possible forms
-for declaring and creating an object:
+In the case of objects of derived types, in addition to the use of Ada
+2005 limited aggregates and extended return statements, you may also
+use one of the following two possible forms for declaring and creating
+an object:
@itemize @bullet
@item @code{New_Object : Derived_T}
@@ -1580,9 +1593,7 @@ constructor is called and the extension
values of the extension fields.
If no constructors are imported, it is impossible to create any objects
-on the Ada side. If no default constructor is imported, only the
-initialization forms using an explicit call to a constructor are
-permitted.
+on the Ada side and the type is implicitly declared abstract.
Pragma @code{CPP_Constructor} is intended primarily for automatic generation
using an automatic binding generator tool.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 146961)
+++ sem_ch3.adb (working copy)
@@ -2656,6 +2656,7 @@ package body Sem_Ch3 is
if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
and then Is_Tagged_Type (T)
and then not Is_Class_Wide_Type (T)
+ and then not Is_CPP_Constructor_Call (E)
then
Error_Msg_N ("dynamically tagged expression not allowed!", E);
end if;
@@ -15311,9 +15312,10 @@ package body Sem_Ch3 is
function OK_For_Limited_Init (Exp : Node_Id) return Boolean is
begin
- return Ada_Version >= Ada_05
- and then not Debug_Flag_Dot_L
- and then OK_For_Limited_Init_In_05 (Exp);
+ return Is_CPP_Constructor_Call (Exp)
+ or else (Ada_Version >= Ada_05
+ and then not Debug_Flag_Dot_L
+ and then OK_For_Limited_Init_In_05 (Exp));
end OK_For_Limited_Init;
-------------------------------
Index: sem_ch5.adb
===================================================================
--- sem_ch5.adb (revision 146929)
+++ sem_ch5.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
@@ -436,9 +436,15 @@ package body Sem_Ch5 is
and then not Assignment_OK (Original_Node (Lhs))
and then not Is_Value_Type (T1)
then
- Error_Msg_N
- ("left hand of assignment must not be limited type", Lhs);
- Explain_Limited_Type (T1, Lhs);
+ -- CPP constructors can only be called in declarations
+
+ if Is_CPP_Constructor_Call (Rhs) then
+ Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs);
+ else
+ Error_Msg_N
+ ("left hand of assignment must not be limited type", Lhs);
+ Explain_Limited_Type (T1, Lhs);
+ end if;
return;
-- Enforce RM 3.9.3 (8): left-hand side cannot be abstract
@@ -543,6 +549,7 @@ package body Sem_Ch5 is
or else (Is_Dynamically_Tagged (Rhs)
and then not Is_Access_Type (T1)))
and then not Is_Class_Wide_Type (T1)
+ and then not Is_CPP_Constructor_Call (Rhs)
then
Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 146929)
+++ sem_prag.adb (working copy)
@@ -6201,13 +6201,8 @@ package body Sem_Prag is
Process_Interface_Name (Def_Id, Arg2, Arg3);
end if;
- if No (Parameter_Specifications (Parent (Def_Id))) then
- Set_Has_Completion (Def_Id);
- Set_Is_Constructor (Def_Id);
- else
- Error_Pragma_Arg
- ("non-default constructors not implemented", Arg1);
- end if;
+ Set_Has_Completion (Def_Id);
+ Set_Is_Constructor (Def_Id);
else
Error_Pragma_Arg
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 146963)
+++ sem_util.adb (working copy)
@@ -5518,6 +5518,19 @@ package body Sem_Util is
return False;
end Is_Controlling_Limited_Procedure;
+ -----------------------------
+ -- Is_CPP_Constructor_Call --
+ -----------------------------
+
+ function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Function_Call
+ and then Is_Class_Wide_Type (Etype (N))
+ and then Is_CPP_Class (Etype (Etype (N)))
+ and then Is_Constructor (Entity (Name (N)))
+ and then Is_Imported (Entity (Name (N)));
+ end Is_CPP_Constructor_Call;
+
----------------------------------------------
-- Is_Dependent_Component_Of_Mutable_Object --
----------------------------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 146929)
+++ sem_util.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
@@ -644,6 +644,9 @@ package Sem_Util is
-- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure
-- of a limited interface with a controlling first parameter.
+ function Is_CPP_Constructor_Call (N : Node_Id) return Boolean;
+ -- Returns True if N is a call to a CPP constructor
+
function Is_Dependent_Component_Of_Mutable_Object
(Object : Node_Id) return Boolean;
-- Returns True if Object is the name of a subcomponent that
More information about the Gcc-patches
mailing list