exp_ch3.adb (Expand_Freeze_Record_Type): Handle constructors of non-tagged record types.

2009-07-10  Javier Miranda  <miranda@adacore.com>

	* 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.

From-SVN: r149466

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  <miranda@adacore.com>
+
+	* 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  <quinot@adacore.com>
 
 	* 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)));