From 294b942d56cb4d7f0f03ccf70294e48b90710e31 Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 29 Apr 2009 13:29:08 +0000 Subject: [PATCH] 2009-04-29 Javier Miranda * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@146966 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 48 +++++++++++++++++++++++ gcc/ada/exp_aggr.adb | 23 +++++++---- gcc/ada/exp_ch3.adb | 73 +++++++++++++++++++++++++++++------ gcc/ada/exp_ch3.ads | 8 +++- gcc/ada/exp_disp.adb | 91 ++++++++++++++++++++++++++------------------ gcc/ada/exp_disp.ads | 13 ++++--- gcc/ada/exp_tss.adb | 73 +++++++++++++++++++++++++++++++---- gcc/ada/exp_tss.ads | 22 +++++++---- gcc/ada/gnat_rm.texi | 29 +++++++++----- gcc/ada/sem_ch3.adb | 8 ++-- gcc/ada/sem_ch5.adb | 15 ++++++-- gcc/ada/sem_prag.adb | 9 +---- gcc/ada/sem_util.adb | 13 +++++++ gcc/ada/sem_util.ads | 5 ++- 14 files changed, 330 insertions(+), 100 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3c14d9e7ba09..7b3f1fbb6789 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2009-04-29 Javier Miranda + + * 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. + 2009-04-29 Vincent Celier * prj-part.adb (Parse_Single_Project): Do not attempt to find a diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7c38cba86243..516905f88732 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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); end loop; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d05cdbba9e8d..5ba57dea1343 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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 diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index d51724af3cd3..6738ae958f9a 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -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 diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 7df455015361..23dc728f9888 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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 + 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 := + 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; + Next_Entity (E); end loop; - -- Create the init procedure - - 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); - -- 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 -- diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index ed8666952466..c91798f24509 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -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; diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index b350644c24e7..c7e03660d948 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -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 - return Node (Elmt); + 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 + 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); diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index e72e38cc2c0d..b81199ccf292 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -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); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 81b6a1140bc4..509717f681d8 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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) at the implementation 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 aggregate indicates the explicit 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. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 114e217986f7..9bd9a0012605 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; ------------------------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 5cf092c9917f..37975bc73a7b 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -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); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index daa607bb6efc..926f750405d1 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e76e9d2c987a..d7e85261dfe4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- ---------------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 4046b785892e..9e2d3ffcf1e7 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 -- 2.47.2