From 2f82b41a94d8ff46b3a9ef7fc11e6f49bd890dae Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 10 Jul 2009 09:30:44 +0000 Subject: [PATCH] 2009-07-10 Javier Miranda * exp_ch3.adb (Expand_Freeze_Record_Type): Handle constructors of non-tagged record types. * sem_prag.adb (Process_Import_Or_Interface): Allow the use of "pragma Import (CPP,..)" with non-tagged types. Required to import C++ classes that have no virtual primitives. (Analyze_Pragma): For pragma CPP_Constructor. Allow the use of functions returning non-tagged types. For backward compatibility, if the constructor returns a class wide type we internally change the returned type to the corresponding non class-wide type. * sem_aggr.adb (Valid_Ancestor_Type): CPP_Constructors code cleanup. (Resolve_Extension_Aggregate): CPP_Constructors code cleanup. (Resolve_Aggr_Expr): CPP_Constructors code cleanup. (Resolve_Record_Aggregate): CPP_Constructors code cleanup. * sem_ch3.adb (Analyze_Object_Declaration): CPP_Constructors code cleanup. * sem_ch5.adb (Analyze_Assignment): CPP_Constructors code cleanup. * sem_util.adb (Is_CPP_Constructor_Call): Code cleanup. * sem_res.adb (Resolve_Allocator): CPP_Constructors code cleanup. * exp_ch4.adb (Expand_Allocator_Expression): CPP_Constructors code cleanup. * exp_aggr.adb (Build_Record_Aggr_Code): CPP_Constructors code clean up. * gnat_rm.texi (pragma CPP_Class): Document that it can be used now with non-tagged record types. (pragma CPP_Constructor): Document that it can be used now with functions returning specific types. For backward compatibility we also support functions returning class-wide types. * gnat_ugn.texi (Interfacing with C++ constructors): Update the examples to incorporate the new syntax in which the functions used to import C++ constructors return specific types. (Interfacing with C++ at the Class Level): Update the examples to incorporate the new syntax in which the functions used to import C++ constructors return specific types. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149466 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 49 ++++++++++++++++ gcc/ada/exp_aggr.adb | 11 ++-- gcc/ada/exp_ch3.adb | 8 +++ gcc/ada/exp_ch4.adb | 5 +- gcc/ada/gnat_rm.texi | 31 +++++++--- gcc/ada/gnat_ugn.texi | 10 ++-- gcc/ada/sem_aggr.adb | 26 +-------- gcc/ada/sem_ch3.adb | 1 - gcc/ada/sem_ch5.adb | 1 - gcc/ada/sem_prag.adb | 153 ++++++++++++++++++++++++++++++-------------------- gcc/ada/sem_res.adb | 12 +--- gcc/ada/sem_util.adb | 1 - 12 files changed, 188 insertions(+), 120 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 39c8080..bdcea23 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,52 @@ +2009-07-10 Javier Miranda + + * exp_ch3.adb (Expand_Freeze_Record_Type): Handle constructors of + non-tagged record types. + + * sem_prag.adb + (Process_Import_Or_Interface): Allow the use of "pragma Import (CPP,..)" + with non-tagged types. Required to import C++ classes that have no + virtual primitives. + (Analyze_Pragma): For pragma CPP_Constructor. Allow the use of functions + returning non-tagged types. For backward compatibility, if the + constructor returns a class wide type we internally change the + returned type to the corresponding non class-wide type. + + * sem_aggr.adb + (Valid_Ancestor_Type): CPP_Constructors code cleanup. + (Resolve_Extension_Aggregate): CPP_Constructors code cleanup. + (Resolve_Aggr_Expr): CPP_Constructors code cleanup. + (Resolve_Record_Aggregate): CPP_Constructors code cleanup. + + * sem_ch3.adb + (Analyze_Object_Declaration): CPP_Constructors code cleanup. + + * sem_ch5.adb (Analyze_Assignment): CPP_Constructors code cleanup. + + * sem_util.adb (Is_CPP_Constructor_Call): Code cleanup. + + * sem_res.adb (Resolve_Allocator): CPP_Constructors code cleanup. + + * exp_ch4.adb (Expand_Allocator_Expression): CPP_Constructors code + cleanup. + + * exp_aggr.adb (Build_Record_Aggr_Code): CPP_Constructors code clean up. + + * gnat_rm.texi + (pragma CPP_Class): Document that it can be used now with non-tagged + record types. + (pragma CPP_Constructor): Document that it can be used now with + functions returning specific types. For backward compatibility + we also support functions returning class-wide types. + + * gnat_ugn.texi + (Interfacing with C++ constructors): Update the examples to incorporate + the new syntax in which the functions used to import C++ constructors + return specific types. + (Interfacing with C++ at the Class Level): Update the examples to + incorporate the new syntax in which the functions used to import + C++ constructors return specific types. + 2009-07-10 Thomas Quinot * exp_disp.adb (Make_Disp_Asynchronous_Select_Body, diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3d0c2d1..a65a713 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2380,9 +2380,8 @@ package body Exp_Aggr is end Gen_Ctrl_Actions_For_Aggr; function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result; - -- If the default expression of a component mentions a discriminant of - -- the type, it has to be rewritten as the discriminant of the target - -- object. + -- If default expression of a component mentions a discriminant of the + -- type, it must be rewritten as the discriminant of the target object. function Replace_Type (Expr : Node_Id) return Traverse_Result; -- If the aggregate contains a self-reference, traverse each expression @@ -2402,7 +2401,7 @@ package body Exp_Aggr is then Rewrite (Expr, Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj, Loc), + Prefix => New_Occurrence_Of (Obj, Loc), Selector_Name => Make_Identifier (Loc, Chars (Expr)))); end if; return OK; @@ -2565,7 +2564,7 @@ package body Exp_Aggr is -- Handle calls to C++ constructors elsif Is_CPP_Constructor_Call (A) then - Init_Typ := Etype (Etype (A)); + Init_Typ := Etype (A); Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); Set_Assignment_OK (Ref); @@ -3053,7 +3052,7 @@ package body Exp_Aggr is Instr := Make_OK_Assignment_Statement (Loc, Name => Comp_Expr, - Expression => Expr_Q); + Expression => Expr_Q); Set_No_Ctrl_Actions (Instr); Append_To (L, Instr); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8cacbeb..cb8e41e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5702,6 +5702,14 @@ package body Exp_Ch3 is Next_Component (Comp); end loop; + -- Handle constructors of non-tagged CPP_Class types + + if not Is_Tagged_Type (Def_Id) + and then Is_CPP_Class (Def_Id) + then + Set_CPP_Constructors (Def_Id); + end if; + -- Creation of the Dispatch Table. Note that a Dispatch Table is built -- for regular tagged types as well as for Ada types deriving from a C++ -- Class, but not for tagged types directly corresponding to C++ classes diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 880d4a0..7cfcaee 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -580,8 +580,7 @@ package body Exp_Ch4 is -- Allocate the object with no expression Node := Relocate_Node (N); - Set_Expression (Node, - New_Reference_To (Root_Type (Etype (Exp)), Loc)); + Set_Expression (Node, New_Reference_To (Etype (Exp), Loc)); -- Avoid its expansion to avoid generating a call to the default -- C++ constructor @@ -615,7 +614,7 @@ package body Exp_Ch4 is Id_Ref => Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Temp, Loc)), - Typ => Root_Type (Etype (Exp)), + Typ => Etype (Exp), Constructor_Ref => Exp)); end; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index ad63bac..3e85ef7 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -1494,9 +1494,10 @@ pragma CPP_Class ([Entity =>] LOCAL_NAME); @noindent The argument denotes an entity in the current declarative region that is -declared as a tagged record type. It indicates that the type corresponds -to an externally declared C++ class type, and is to be laid out the same -way that C++ would lay out the type. +declared as a record type. It indicates that the type corresponds to an +externally declared C++ class type, and is to be laid out the same way +that C++ would lay out the type. If the C++ class has virtual primitives +then the record must be declared as a tagged record type. Types for which @code{CPP_Class} is specified do not have assignment or equality operators defined (such operations can be imported or declared @@ -1536,20 +1537,28 @@ must be of one of the following forms: @itemize @bullet @item +@code{function @var{Fname} return @var{T}} + +@itemize @bullet +@item @code{function @var{Fname} return @var{T}'Class} @item +@code{function @var{Fname} (@dots{}) return @var{T}} +@end itemize + +@item @code{function @var{Fname} (@dots{}) return @var{T}'Class} @end itemize @noindent -where @var{T} is a tagged limited type imported from C++ with pragma +where @var{T} is a limited record 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. The -second form covers all the non-default constructors of the type. See -the GNAT users guide for details. +The first two forms import the default constructor, used when an object +of type @var{T} is created on the Ada side with no explicit constructor. +The latter two forms cover all the non-default constructors of the type. +See the GNAT users guide for details. If no constructors are imported, it is impossible to create any objects on the Ada side and the type is implicitly declared abstract. @@ -1558,6 +1567,12 @@ Pragma @code{CPP_Constructor} is intended primarily for automatic generation using an automatic binding generator tool. See @ref{Interfacing to C++} for more related information. +Note: The use of functions returning class-wide types for constructors is +currently obsolete. They are supported for backward compatibility. The +use of functions returning the type T leave the Ada sources more clear +because the imported C++ constructors always return an object of type T; +that is, they never return an object whose type is a descendant of type T. + @node Pragma CPP_Virtual @unnumberedsec Pragma CPP_Virtual @cindex Interfacing to C++ diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 9f6178d..4242ef0 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3278,13 +3278,13 @@ package Pkg_Root is function Get_Value (Obj : Root) return int; pragma Import (CPP, Get_Value); - function Constructor return Root'Class; + function Constructor return Root; pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ev"); - function Constructor (v : Integer) return Root'Class; + function Constructor (v : Integer) return Root; pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ei"); - function Constructor (v, w : Integer) return Root'Class; + function Constructor (v, w : Integer) return Root; pragma Cpp_Constructor (Constructor, "_ZN4RootC1Eii"); end Pkg_Root; @end smallexample @@ -3527,7 +3527,7 @@ package Animals is procedure Set_Owner (A : in out Dog; Name : Chars_Ptr); pragma Import (C_Plus_Plus, Set_Owner); - function New_Dog return Dog'Class; + function New_Dog return Dog; pragma CPP_Constructor (New_Dog); pragma Import (CPP, New_Dog, "_ZN3DogC2Ev"); end Animals; @@ -22833,7 +22833,7 @@ The corresponding Ada code is generated: (this : access Dog; Name : Interfaces.C.Strings.chars_ptr); pragma Import (CPP, Set_Owner, "_ZN3Dog9Set_OwnerEPc"); - function New_Dog return Dog'Class; + function New_Dog return Dog; pragma CPP_Constructor (New_Dog); pragma Import (CPP, New_Dog, "_ZN3DogC1Ev"); end; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 2c40c92..b160b92 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2183,11 +2183,6 @@ package body Sem_Aggr is if Etype (Imm_Type) = Base_Type (A_Type) then return True; - elsif Is_CPP_Constructor_Call (A) - and then Etype (Imm_Type) = Base_Type (Etype (A_Type)) - then - return True; - -- The base type of the parent type may appear as a private -- extension if it is declared as such in a parent unit of -- the current one. For consistency of the subsequent analysis @@ -2303,7 +2298,6 @@ package body Sem_Aggr is if Is_Class_Wide_Type (Etype (A)) and then Nkind (Original_Node (A)) = N_Function_Call - and then not Is_CPP_Constructor_Call (Original_Node (A)) then -- If the ancestor part is a dispatching call, it appears -- statically to be a legal ancestor, but it yields any @@ -2795,9 +2789,7 @@ package body Sem_Aggr is -- Check wrong use of class-wide types - if Is_Class_Wide_Type (Etype (Expr)) - and then not Is_CPP_Constructor_Call (Expr) - then + if Is_Class_Wide_Type (Etype (Expr)) then Error_Msg_N ("dynamically tagged expression not allowed", Expr); end if; @@ -3100,21 +3092,7 @@ package body Sem_Aggr is -- ancestors, starting with the root. if Nkind (N) = N_Extension_Aggregate then - - -- Handle case where ancestor part is a C++ constructor. In - -- this case it must be a function returning a class-wide type. - -- If the ancestor part is a C++ constructor, then it must be a - -- function returning a class-wide type, so handle that here. - - if Is_CPP_Constructor_Call (Ancestor_Part (N)) then - pragma Assert - (Is_Class_Wide_Type (Etype (Ancestor_Part (N)))); - Root_Typ := Root_Type (Etype (Ancestor_Part (N))); - - -- Normal case, not a C++ constructor - else - Root_Typ := Base_Type (Etype (Ancestor_Part (N))); - end if; + Root_Typ := Base_Type (Etype (Ancestor_Part (N))); else Root_Typ := Root_Type (Typ); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a5d6f97..c6a10e0 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2631,7 +2631,6 @@ 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; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 4c047b4..8402e33 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -549,7 +549,6 @@ 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 a9ef7d1..90de628 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -35,6 +35,7 @@ with Checks; use Checks; with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Exp_Dist; use Exp_Dist; with Lib; use Lib; @@ -3553,73 +3554,67 @@ package body Sem_Prag is elsif Is_Record_Type (Def_Id) and then C = Convention_CPP then - if not Is_Tagged_Type (Def_Id) then - Error_Msg_Sloc := Sloc (Def_Id); - Error_Pragma_Arg ("imported 'C'P'P type must be tagged", Arg2); - - else - -- Types treated as CPP classes are treated as limited, but we - -- don't require them to be declared this way. A warning is - -- issued to encourage the user to declare them as limited. - -- This is not an error, for compatibility reasons, because - -- these types have been supported this way for some time. + -- Types treated as CPP classes are treated as limited, but we + -- don't require them to be declared this way. A warning is + -- issued to encourage the user to declare them as limited. + -- This is not an error, for compatibility reasons, because + -- these types have been supported this way for some time. - if not Is_Limited_Type (Def_Id) then - Error_Msg_N - ("imported 'C'P'P type should be " & - "explicitly declared limited?", - Get_Pragma_Arg (Arg2)); - Error_Msg_N - ("\type will be considered limited", - Get_Pragma_Arg (Arg2)); - end if; + if not Is_Limited_Type (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type should be " & + "explicitly declared limited?", + Get_Pragma_Arg (Arg2)); + Error_Msg_N + ("\type will be considered limited", + Get_Pragma_Arg (Arg2)); + end if; - Set_Is_CPP_Class (Def_Id); - Set_Is_Limited_Record (Def_Id); + Set_Is_CPP_Class (Def_Id); + Set_Is_Limited_Record (Def_Id); - -- Imported CPP types must not have discriminants (because C++ - -- classes do not have discriminants). + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). - if Has_Discriminants (Def_Id) then - Error_Msg_N - ("imported 'C'P'P type cannot have discriminants", - First (Discriminant_Specifications - (Declaration_Node (Def_Id)))); - end if; + if Has_Discriminants (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Def_Id)))); + end if; - -- Components of imported CPP types must not have default - -- expressions because the constructor (if any) is in the - -- C++ side. + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is in the + -- C++ side. - declare - Tdef : constant Node_Id := - Type_Definition (Declaration_Node (Def_Id)); - Clist : Node_Id; - Comp : Node_Id; + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Def_Id)); + Clist : Node_Id; + Comp : Node_Id; - begin - if Nkind (Tdef) = N_Record_Definition then - Clist := Component_List (Tdef); + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); - else - pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); - Clist := Component_List (Record_Extension_Part (Tdef)); - end if; + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; - if Present (Clist) then - Comp := First (Component_Items (Clist)); - while Present (Comp) loop - if Present (Expression (Comp)) then - Error_Msg_N - ("component of imported 'C'P'P type cannot have" & - " default expression", Expression (Comp)); - end if; + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; - Next (Comp); - end loop; - end if; - end; - end if; + Next (Comp); + end loop; + end if; + end; else Error_Pragma_Arg @@ -6272,8 +6267,10 @@ package body Sem_Prag is -- [, [Link_Name =>] static_string_EXPRESSION ]); when Pragma_CPP_Constructor => CPP_Constructor : declare - Id : Entity_Id; - Def_Id : Entity_Id; + Elmt : Elmt_Id; + Id : Entity_Id; + Def_Id : Entity_Id; + Tag_Typ : Entity_Id; begin GNAT_Pragma; @@ -6294,8 +6291,10 @@ package body Sem_Prag is Def_Id := Entity (Id); if Ekind (Def_Id) = E_Function - and then Is_Class_Wide_Type (Etype (Def_Id)) - and then Is_CPP_Class (Etype (Etype (Def_Id))) + and then (Is_CPP_Class (Etype (Def_Id)) + or else (Is_Class_Wide_Type (Etype (Def_Id)) + and then + Is_CPP_Class (Root_Type (Etype (Def_Id))))) then if Arg_Count >= 2 then Set_Imported (Def_Id); @@ -6306,6 +6305,38 @@ package body Sem_Prag is Set_Has_Completion (Def_Id); Set_Is_Constructor (Def_Id); + -- Imported C++ constructors are not dispatching primitives + -- because in C++ they don't have a dispatch table slot. + -- However, in Ada the constructor has the profile of a + -- function that returns a tagged type and therefore it has + -- been considered by the Semantic analyzer a dispatching + -- primitive operation. We extract it now from the list of + -- primitive operations of the type. + + if Is_Tagged_Type (Etype (Def_Id)) + and then not Is_Class_Wide_Type (Etype (Def_Id)) + then + pragma Assert (Is_Dispatching_Operation (Def_Id)); + Tag_Typ := Etype (Def_Id); + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) + and then Node (Elmt) /= Def_Id + loop + Next_Elmt (Elmt); + end loop; + + Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); + Set_Is_Dispatching_Operation (Def_Id, False); + end if; + + -- For backward compatibility, if the constructor returns a + -- class wide type we internally change the returned type to + -- the corresponding non class-wide type. + + if Is_Class_Wide_Type (Etype (Def_Id)) then + Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); + end if; else Error_Pragma_Arg ("pragma% requires function returning a 'C'P'P_Class type", diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3af4785..14ec28d 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3982,17 +3982,9 @@ package body Sem_Res is Check_Unset_Reference (Expression (E)); -- A qualified expression requires an exact match of the type, - -- class-wide matching is not allowed. We skip this test in a call - -- to a CPP constructor because in such case, although the function - -- profile indicates that it returns a class-wide type, the object - -- returned by the C++ constructor has a concrete type. + -- class-wide matching is not allowed. - if Is_Class_Wide_Type (Etype (Expression (E))) - and then Is_CPP_Constructor_Call (Expression (E)) - then - null; - - elsif (Is_Class_Wide_Type (Etype (Expression (E))) + if (Is_Class_Wide_Type (Etype (Expression (E))) or else Is_Class_Wide_Type (Etype (E))) and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c270600..7e9fea5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5530,7 +5530,6 @@ package body Sem_Util is 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))); -- 2.7.4