sem_aggr.adb (Resolve_Extension_Aggregate): Warn on the use of C++ constructors…

sem_aggr.adb (Resolve_Extension_Aggregate): Warn on the use of C++ constructors that leave the object partially initialized.

2010-08-10  Javier Miranda  <miranda@adacore.com>

	* sem_aggr.adb (Resolve_Extension_Aggregate): Warn on the use of C++
	constructors that leave the object partially initialized.
	* exp_atag.ads, exp_atags.adb (Build_Inherit_CPP_Prims): New subprogram
	that copies from parent of Typ the dispatch table slots of inherited
	C++ primitives. It handles primary and secondary dispatch tables.
	* einfo.adb (Related_Type): Moved from Node26 to Node27. Required to
	use this attribute with E_Variable entities.
	(Set_Is_Tag): Relax assertion to allow its use with variables that
	store tags.
	(Set_Related_Type): Relax assertion to allow its use with variables
	that store the tag of a C++ class.
	(Write_26_Field_Name): Remove Related_Type.
	(Write_27_Field_Name): Add Related_Type.
	* einfo.ads (Related_Type): Moved from Node26 to Node27. Available also
	with E_Variable entities.
	* sem_prag.adb (CPP_Constructor): Warn on duplicated occurrence of this
	pragma.
	* sem_util.adb (Search_Tag): Add missing support for CPP types.
	(Enclosing_CPP_Parent): New subprogram.
	(Has_Suffix): New subprogram.
	* sem_util.ads (Enclosing_CPP_Parent): New subprogram that returns the
	closest ancestor of a type that is a C++ type.
	(Has_Suffix): New subprogram. Used in assertions to check the suffix of
	internal entities.
	* sem_attr.adb (Analyze_Access_Attribute): Check wrong use of current
	instance in derivations of C++ types.
	* exp_tss.adb (CPP_Init_Proc): New subprogram.
	(Is_CPP_Init_Proc): New subprogram.
	(Set_TSS): Handle new C++ init routines.
	* exp_tss.ads (TSS_CPP_Init): New TSS name. For initialization of C++
	dispatch tables.
	(CPP_Init_Proc): New subprogram.
	(Is_CPP_Init_Proc): New subprogram.
	* exp_disp.adb (CPP_Num_Prims): New subprogram.
	(Has_CPP_Constructors): New subprogram.
	(Make_Secondary_DT, Make_DT): For derivations of CPP types, do not
	initialize slots located in the C++ part of the dispatch table.
	(Make_Tags): For CPP types declare variables used by the IP routine to
	store the C++ tag values after the first invocation of the C++
	constructor.
	(Build_CPP_Init_DT): New subprogram.
	(Set_CPP_Constructors): New implementation that builds an IP for each
	CPP constructor. These IP are wrappers of the C++ constructors that,
	after the first invocation of the constructor, read the C++ tags from
	the object and save them locally. These copies of the C++ tags are used
	by the IC routines to initialize tables of Ada derivations of CPP types.
	(Write_DT): Indicate what primitives are imported from C++
	* exp_disp.ads (CPP_Num_Prims): New subprogram.
	(Has_CPP_Constructors): New subprogram.
	* exp_aggr.adb (Build_Record_Aggr_Code): For derivations of C++ types
	invoke the IC routine to inherit the slots of the parents.
	* sem_ch13.adb (Analyze_Freeze_Entity): Add new warnings on CPP types.
	* exp_ch3.adb (Is_Variable_Size_Array): New subprogram.
	(Is_Variable_Size_Record): Factorize code calling
	Is_Variable_Size_Array.
	(Build_CPP_Init_Procedure): New subprogram that builds the tree
	corresponding to the procedure that initializes the C++ part of the
	dispatch table of an Ada tagged type that is a derivation of a CPP type.
	(Build_Init_Procedure): Adding documentation plus code reorganization to
	leave more clear the construction of the IP with C++ types.
	(Expand_Freeze_Record_Type): Delay call to Set_CPP_Constructors because
	it cannot be called after Make_Tags has been invoked.
	(Inherit_CPP_Tag): Removed.
	(Init_Secondary_Tags): For derivations of CPP types, warn on tags
	located at variable offset.
	* freeze.ads: Minor reformating.
	* sem_ch8.adb (Write_Scopes): Add pragma export. Required to have it
	available in gdb.
	* gcc-interface/Make-lang.in: Update dependencies.

From-SVN: r163065

gcc/ada/ChangeLog

+2010-08-10  Javier Miranda  <miranda@adacore.com>
+
+	* sem_aggr.adb (Resolve_Extension_Aggregate): Warn on the use of C++
+	constructors that leave the object partially initialized.
+	* exp_atag.ads, exp_atags.adb (Build_Inherit_CPP_Prims): New subprogram
+	that copies from parent of Typ the dispatch table slots of inherited
+	C++ primitives. It handles primary and secondary dispatch tables.
+	* einfo.adb (Related_Type): Moved from Node26 to Node27. Required to
+	use this attribute with E_Variable entities.
+	(Set_Is_Tag): Relax assertion to allow its use with variables that
+	store tags.
+	(Set_Related_Type): Relax assertion to allow its use with variables
+	that store the tag of a C++ class.
+	(Write_26_Field_Name): Remove Related_Type.
+	(Write_27_Field_Name): Add Related_Type.
+	* einfo.ads (Related_Type): Moved from Node26 to Node27. Available also
+	with E_Variable entities.
+	* sem_prag.adb (CPP_Constructor): Warn on duplicated occurrence of this
+	pragma.
+	* sem_util.adb (Search_Tag): Add missing support for CPP types.
+	(Enclosing_CPP_Parent): New subprogram.
+	(Has_Suffix): New subprogram.
+	* sem_util.ads (Enclosing_CPP_Parent): New subprogram that returns the
+	closest ancestor of a type that is a C++ type.
+	(Has_Suffix): New subprogram. Used in assertions to check the suffix of
+	internal entities.
+	* sem_attr.adb (Analyze_Access_Attribute): Check wrong use of current
+	instance in derivations of C++ types.
+	* exp_tss.adb (CPP_Init_Proc): New subprogram.
+	(Is_CPP_Init_Proc): New subprogram.
+	(Set_TSS): Handle new C++ init routines.
+	* exp_tss.ads (TSS_CPP_Init): New TSS name. For initialization of C++
+	dispatch tables.
+	(CPP_Init_Proc): New subprogram.
+	(Is_CPP_Init_Proc): New subprogram.
+	* exp_disp.adb (CPP_Num_Prims): New subprogram.
+	(Has_CPP_Constructors): New subprogram.
+	(Make_Secondary_DT, Make_DT): For derivations of CPP types, do not
+	initialize slots located in the C++ part of the dispatch table.
+	(Make_Tags): For CPP types declare variables used by the IP routine to
+	store the C++ tag values after the first invocation of the C++
+	constructor.
+	(Build_CPP_Init_DT): New subprogram.
+	(Set_CPP_Constructors): New implementation that builds an IP for each
+	CPP constructor. These IP are wrappers of the C++ constructors that,
+	after the first invocation of the constructor, read the C++ tags from
+	the object and save them locally. These copies of the C++ tags are used
+	by the IC routines to initialize tables of Ada derivations of CPP types.
+	(Write_DT): Indicate what primitives are imported from C++
+	* exp_disp.ads (CPP_Num_Prims): New subprogram.
+	(Has_CPP_Constructors): New subprogram.
+	* exp_aggr.adb (Build_Record_Aggr_Code): For derivations of C++ types
+	invoke the IC routine to inherit the slots of the parents.
+	* sem_ch13.adb (Analyze_Freeze_Entity): Add new warnings on CPP types.
+	* exp_ch3.adb (Is_Variable_Size_Array): New subprogram.
+	(Is_Variable_Size_Record): Factorize code calling
+	Is_Variable_Size_Array.
+	(Build_CPP_Init_Procedure): New subprogram that builds the tree
+	corresponding to the procedure that initializes the C++ part of the
+	dispatch table of an Ada tagged type that is a derivation of a CPP type.
+	(Build_Init_Procedure): Adding documentation plus code reorganization to
+	leave more clear the construction of the IP with C++ types.
+	(Expand_Freeze_Record_Type): Delay call to Set_CPP_Constructors because
+	it cannot be called after Make_Tags has been invoked.
+	(Inherit_CPP_Tag): Removed.
+	(Init_Secondary_Tags): For derivations of CPP types, warn on tags
+	located at variable offset.
+	* freeze.ads: Minor reformating.
+	* sem_ch8.adb (Write_Scopes): Add pragma export. Required to have it
+	available in gdb.
+	* gcc-interface/Make-lang.in: Update dependencies.
+
 2010-08-10  Robert Dewar  <dewar@adacore.com>
 
 	* a-chahan.ads: Add comments on handling of obsolescent entries.

gcc/ada/einfo.adb

@@ -219,11 +219,11 @@ package body Einfo is
    --    Last_Assignment                 Node26
    --    Overridden_Operation            Node26
    --    Package_Instantiation           Node26
-   --    Related_Type                    Node26
    --    Relative_Deadline_Variable      Node26
    --    Static_Initialization           Node26
 
    --    Current_Use_Clause              Node27
+   --    Related_Type                    Node27
    --    Wrapped_Entity                  Node27
 
    --    Extra_Formals                   Node28
@@ -1481,7 +1481,6 @@ package body Einfo is
 
    function Has_Thunks (Id : E) return B is
    begin
-      pragma Assert (Ekind (Id) = E_Constant);
       return Flag228 (Id);
    end Has_Thunks;
 
@@ -2442,8 +2441,8 @@ package body Einfo is
 
    function Related_Type (Id : E) return E is
    begin
-      pragma Assert (Ekind_In (Id, E_Component, E_Constant));
-      return Node26 (Id);
+      pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+      return Node27 (Id);
    end Related_Type;
 
    function Relative_Deadline_Variable (Id : E) return E is
@@ -3884,8 +3883,7 @@ package body Einfo is
 
    procedure Set_Has_Thunks (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Tag (Id)
-        and then Ekind (Id) = E_Constant);
+      pragma Assert (Is_Tag (Id));
       Set_Flag228 (Id, V);
    end Set_Has_Thunks;
 
@@ -4452,7 +4450,7 @@ package body Einfo is
 
    procedure Set_Is_Tag (Id : E; V : B := True) is
    begin
-      pragma Assert (Ekind_In (Id, E_Component, E_Constant));
+      pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
       Set_Flag78 (Id, V);
    end Set_Is_Tag;
 
@@ -4883,8 +4881,8 @@ package body Einfo is
 
    procedure Set_Related_Type (Id : E; V : E) is
    begin
-      pragma Assert (Ekind_In (Id, E_Component, E_Constant));
-      Set_Node26 (Id, V);
+      pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+      Set_Node27 (Id, V);
    end Set_Related_Type;
 
    procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
@@ -8011,10 +8009,6 @@ package body Einfo is
    procedure Write_Field26_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
-         when E_Component                                  |
-              E_Constant                                   =>
-            Write_Str ("Related_Type");
-
          when E_Generic_Package                            |
               E_Package                                    =>
             Write_Str ("Package_Instantiation");
@@ -8052,6 +8046,11 @@ package body Einfo is
    procedure Write_Field27_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
+         when E_Component                                  |
+              E_Constant                                   |
+              E_Variable                                   =>
+            Write_Str ("Related_Type");
+
          when E_Procedure                                  =>
             Write_Str ("Wrapped_Entity");
 

gcc/ada/einfo.ads

@@ -3306,10 +3306,10 @@ package Einfo is
 --       wrapper package, but for debugging purposes its external symbol
 --       must correspond to the name and scope of the related instance.
 
---    Related_Type (Node26)
---       Present in components and constants associated with dispatch tables.
---       Set to point to the entity of the associated tagged type or interface
---       type.
+--    Related_Type (Node27)
+--       Present in components, constants and variables. Set when there is an
+--       associated dispatch table to point to entities containing primary or
+--       secondary tags. Not set in the _tag component of record types.
 
 --    Relative_Deadline_Variable (Node26) [implementation base type only]
 --       Present in task type entities. This flag is set if a valid and
@@ -4827,7 +4827,7 @@ package Einfo is
    --    Interface_Name                      (Node21)   (JGNAT usage only)
    --    Original_Record_Component           (Node22)
    --    DT_Offset_To_Top_Func               (Node25)
-   --    Related_Type                        (Node26)
+   --    Related_Type                        (Node27)
    --    Has_Biased_Representation           (Flag139)
    --    Has_Per_Object_Constraint           (Flag154)
    --    Is_Atomic                           (Flag85)
@@ -4850,7 +4850,7 @@ package Einfo is
    --    Size_Check_Code                     (Node19)   (constants only)
    --    Prival_Link                         (Node20)   (privals only)
    --    Interface_Name                      (Node21)
-   --    Related_Type                        (Node26)   (constants only)
+   --    Related_Type                        (Node27)   (constants only)
    --    Has_Alignment_Clause                (Flag46)
    --    Has_Atomic_Components               (Flag86)
    --    Has_Biased_Representation           (Flag139)
@@ -5479,6 +5479,7 @@ package Einfo is
    --    Related_Expression                  (Node24)
    --    Debug_Renaming_Link                 (Node25)
    --    Last_Assignment                     (Node26)
+   --    Related_Type                        (Node27)
    --    Has_Alignment_Clause                (Flag46)
    --    Has_Atomic_Components               (Flag86)
    --    Has_Biased_Representation           (Flag139)

gcc/ada/exp_aggr.adb

@@ -34,6 +34,7 @@ with Exp_Util; use Exp_Util;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Ch9;  use Exp_Ch9;
+with Exp_Disp; use Exp_Disp;
 with Exp_Tss;  use Exp_Tss;
 with Fname;    use Fname;
 with Freeze;   use Freeze;
@@ -2840,12 +2841,61 @@ package body Exp_Aggr is
       --  constructor to ensure the proper initialization of the _Tag
       --  component.
 
-      if Is_CPP_Class (Typ) then
-         pragma Assert (Present (Base_Init_Proc (Typ)));
-         Append_List_To (L,
-           Build_Initialization_Call (Loc,
-             Id_Ref => Lhs,
-             Typ    => Typ));
+      if Is_CPP_Class (Root_Type (Typ))
+        and then CPP_Num_Prims (Typ) > 0
+      then
+         Invoke_Constructor : declare
+            CPP_Parent : constant Entity_Id :=
+                           Enclosing_CPP_Parent (Typ);
+
+            procedure Invoke_IC_Proc (T : Entity_Id);
+            --  Recursive routine used to climb to parents. Required because
+            --  parents must be initialized before descendants to ensure
+            --  propagation of inherited C++ slots.
+
+            --------------------
+            -- Invoke_IC_Proc --
+            --------------------
+
+            procedure Invoke_IC_Proc (T : Entity_Id) is
+            begin
+               --  Avoid generating extra calls. Initialization required
+               --  only for types defined from the level of derivation of
+               --  type of the constructor and the type of the aggregate.
+
+               if T = CPP_Parent then
+                  return;
+               end if;
+
+               Invoke_IC_Proc (Etype (T));
+
+               --  Generate call to the IC routine
+
+               if Present (CPP_Init_Proc (T)) then
+                  Append_To (L,
+                    Make_Procedure_Call_Statement (Loc,
+                      New_Reference_To (CPP_Init_Proc (T), Loc)));
+               end if;
+            end Invoke_IC_Proc;
+
+         --  Start of processing for Invoke_Constructor
+
+         begin
+            --  Implicit invocation of the C++ constructor
+
+            if Nkind (N) = N_Aggregate then
+               Append_To (L,
+                 Make_Procedure_Call_Statement (Loc,
+                   Name =>
+                     New_Reference_To
+                       (Base_Init_Proc (CPP_Parent), Loc),
+                   Parameter_Associations => New_List (
+                     Unchecked_Convert_To (CPP_Parent,
+                       New_Copy_Tree (Lhs)))));
+            end if;
+
+            Invoke_IC_Proc (Typ);
+         end Invoke_Constructor;
       end if;
 
       --  Generate the assignments, component by component

gcc/ada/exp_atag.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2010, 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- --
@@ -97,6 +97,11 @@ package Exp_Atag is
    --
    --  Generates: TSD (Tag).Transportable;
 
+   function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id;
+   --  Build code that copies from Typ's parent the dispatch table slots of
+   --  inherited primitives and updates slots of overridden primitives. The
+   --  generated code handles primary and secondary dispatch tables of Typ.
+
    function Build_Inherit_Predefined_Prims
      (Loc          : Source_Ptr;
       Old_Tag_Node : Node_Id;

gcc/ada/exp_disp.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -186,6 +186,10 @@ package Exp_Disp is
    --  bodies they are added to the end of the list of declarations of the
    --  package body.
 
+   function CPP_Num_Prims (Typ : Entity_Id) return Nat;
+   --  Return the number of primitives of the C++ part of the dispatch table.
+   --  For types that are not derivations of CPP types return 0.
+
    procedure Expand_Dispatching_Call (Call_Node : Node_Id);
    --  Expand the call to the operation through the dispatch table and perform
    --  the required tag checks when appropriate. For CPP types tag checks are
@@ -215,6 +219,9 @@ package Exp_Disp is
    --  Otherwise they are set to the defining identifier and the subprogram
    --  body of the generated thunk.
 
+   function Has_CPP_Constructors (Typ : Entity_Id) return Boolean;
+   --  Returns true if the type has CPP constructors
+
    function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
    --  Ada 2005 (AI-251): Determines if E is a predefined primitive operation
 

gcc/ada/exp_tss.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -109,6 +109,35 @@ package body Exp_Tss is
       Prepend_Elmt (TSS, TSS_Elist (FN));
    end Copy_TSS;
 
+   -------------------
+   -- CPP_Init_Proc --
+   -------------------
+
+   function CPP_Init_Proc (Typ  : Entity_Id) return Entity_Id is
+      FN   : constant Node_Id := Freeze_Node (Typ);
+      Elmt : Elmt_Id;
+
+   begin
+      if not Is_CPP_Class (Root_Type (Typ))
+        or else No (FN)
+        or else No (TSS_Elist (FN))
+      then
+         return Empty;
+
+      else
+         Elmt := First_Elmt (TSS_Elist (FN));
+         while Present (Elmt) loop
+            if Is_CPP_Init_Proc (Node (Elmt)) then
+               return Node (Elmt);
+            end if;
+
+            Next_Elmt (Elmt);
+         end loop;
+      end if;
+
+      return Empty;
+   end CPP_Init_Proc;
+
    ------------------------
    -- Find_Inherited_TSS --
    ------------------------
@@ -276,6 +305,18 @@ package body Exp_Tss is
       return Empty;
    end Init_Proc;
 
+   ----------------------
+   -- Is_CPP_Init_Proc --
+   ----------------------
+
+   function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is
+      C1 : Character;
+      C2 : Character;
+   begin
+      Get_Last_Two_Chars (Chars (E), C1, C2);
+      return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2);
+   end Is_CPP_Init_Proc;
+
    ------------------
    -- Is_Init_Proc --
    ------------------
@@ -393,7 +434,7 @@ package body Exp_Tss is
       --  Skip this for Init_Proc with No_Default_Initialization, since the
       --  Init proc is a dummy void entity in this case to be ignored.
 
-      if Is_Init_Proc (TSS)
+      if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS))
         and then Restriction_Active (No_Default_Initialization)
       then
          null;

gcc/ada/exp_tss.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -84,6 +84,7 @@ package Exp_Tss is
    TSS_Composite_Equality : constant TNT := "EQ";  -- Composite Equality
    TSS_From_Any           : constant TNT := "FA";  -- PolyORB/DSA From_Any
    TSS_Init_Proc          : constant TNT := "IP";  -- Initialization Procedure
+   TSS_CPP_Init_Proc      : constant TNT := "IC";  -- Init C++ dispatch tables
    TSS_RAS_Access         : constant TNT := "RA";  -- RAS type access
    TSS_RAS_Dereference    : constant TNT := "RD";  -- RAS type dereference
    TSS_Rep_To_Pos         : constant TNT := "RP";  -- Rep to Pos conversion
@@ -104,6 +105,7 @@ package Exp_Tss is
       TSS_Composite_Equality,
       TSS_From_Any,
       TSS_Init_Proc,
+      TSS_CPP_Init_Proc,
       TSS_RAS_Access,
       TSS_RAS_Dereference,
       TSS_Rep_To_Pos,
@@ -140,15 +142,18 @@ package Exp_Tss is
    function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id;
    --  Version for init procs, same as Make_TSS_Name (Typ, TSS_Init_Proc)
 
+   function Is_CPP_Init_Proc (E : Entity_Id) return Boolean;
+   --  Version for CPP init procs, same as Is_TSS (E, TSS_CPP_Init_Proc);
+
+   function Is_Init_Proc (E : Entity_Id) return Boolean;
+   --  Version for init procs, same as Is_TSS (E, TSS_Init_Proc);
+
    function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean;
    --  Determines if given entity (E) is the name of a TSS identified by Nam
 
    function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean;
    --  Same test applied directly to a Name_Id value
 
-   function Is_Init_Proc (E : Entity_Id) return Boolean;
-   --  Version for init procs, same as Is_TSS (E, TSS_Init_Proc);
-
    -----------------------------------------
    -- TSS Data structures and Subprograms --
    -----------------------------------------
@@ -188,6 +193,11 @@ 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 CPP_Init_Proc (Typ : Entity_Id) return Entity_Id;
+   --  Obtains the CPP_Init TSS entity the given type. The CPP_Init TSS is a
+   --  procedure used to initialize the C++ part of the primary and secondary
+   --  dispatch tables of a tagged type derived from CPP types.
+
    function Init_Proc
      (Typ : Entity_Id;
       Ref : Entity_Id := Empty) return Entity_Id;

gcc/ada/freeze.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --

gcc/ada/sem_aggr.adb

@@ -2417,6 +2417,36 @@ package body Sem_Aggr is
                Error_Msg_N
                  ("type of limited ancestor part must be constrained", A);
 
+            --  Reject the use of CPP constructors that leave objects partially
+            --  initialized. For example:
+
+            --    type CPP_Root is tagged limited record ...
+            --    pragma Import (CPP, CPP_Root);
+
+            --    type CPP_DT is new CPP_Root and Iface ...
+            --    pragma Import (CPP, CPP_DT);
+
+            --    type Ada_DT is new CPP_DT with ...
+
+            --    Obj : Ada_DT := Ada_DT'(New_CPP_Root with others => <>);
+
+            --  Using the constructor of CPP_Root the slots of the dispatch
+            --  table of CPP_DT cannot be set, and the secondary tag of
+            --  CPP_DT is unknown.
+
+            elsif Nkind (A) = N_Function_Call
+              and then Is_CPP_Constructor_Call (A)
+              and then Enclosing_CPP_Parent (Typ) /= A_Type
+            then
+               Error_Msg_NE
+                 ("?must use 'C'P'P constructor for type &", A,
+                  Enclosing_CPP_Parent (Typ));
+
+               --  The following call is not needed if the previous warning
+               --  is promoted to an error.
+
+               Resolve_Record_Aggregate (N, Typ);
+
             elsif Is_Class_Wide_Type (Etype (A))
               and then Nkind (Original_Node (A)) = N_Function_Call
             then

gcc/ada/sem_attr.adb

@@ -697,6 +697,12 @@ package body Sem_Attr is
                        ("current instance attribute must appear alone", N);
                   end if;
 
+                  if Is_CPP_Class (Root_Type (Typ)) then
+                     Error_Msg_N
+                       ("?current instance unsupported for derivations of "
+                        & "'C'P'P types", N);
+                  end if;
+
                --  OK if we are in initialization procedure for the type
                --  in question, in which case the reference to the type
                --  is rewritten as a reference to the current object.

gcc/ada/sem_ch13.adb

@@ -26,7 +26,9 @@
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
+with Elists;   use Elists;
 with Errout;   use Errout;
+with Exp_Disp; use Exp_Disp;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Lib;      use Lib;
@@ -2385,6 +2387,70 @@ package body Sem_Ch13 is
 
          Add_Internal_Interface_Entities (E);
       end if;
+
+      --  Check CPP types
+
+      if Ekind (E) = E_Record_Type
+        and then Is_CPP_Class (E)
+        and then Is_Tagged_Type (E)
+        and then Tagged_Type_Expansion
+        and then Expander_Active
+      then
+         if CPP_Num_Prims (E) = 0 then
+
+            --  If the CPP type has user defined components then it must import
+            --  primitives from C++. This is required because if the C++ class
+            --  has no primitives then the C++ compiler does not added the _tag
+            --  component to the type.
+
+            pragma Assert (Chars (First_Entity (E)) = Name_uTag);
+
+            if First_Entity (E) /= Last_Entity (E) then
+               Error_Msg_N
+                 ("?'C'P'P type must import at least one primitive from C++",
+                  E);
+            end if;
+         end if;
+
+         --  Check that all its primitives are abstract or imported from C++.
+         --  Check also availability of the C++ constructor.
+
+         declare
+            Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
+            Elmt             : Elmt_Id;
+            Error_Reported   : Boolean := False;
+            Prim             : Node_Id;
+
+         begin
+            Elmt := First_Elmt (Primitive_Operations (E));
+            while Present (Elmt) loop
+               Prim := Node (Elmt);
+
+               if Comes_From_Source (Prim) then
+                  if Is_Abstract_Subprogram (Prim) then
+                     null;
+
+                  elsif not Is_Imported (Prim)
+                    or else Convention (Prim) /= Convention_CPP
+                  then
+                     Error_Msg_N
+                       ("?primitives of 'C'P'P types must be imported from C++"
+                        & " or abstract", Prim);
+
+                  elsif not Has_Constructors
+                     and then not Error_Reported
+                  then
+                     Error_Msg_Name_1 := Chars (E);
+                     Error_Msg_N
+                       ("?'C'P'P constructor required for type %", Prim);
+                     Error_Reported := True;
+                  end if;
+               end if;
+
+               Next_Elmt (Elmt);
+            end loop;
+         end;
+      end if;
    end Analyze_Freeze_Entity;
 
    ------------------------------------------

gcc/ada/sem_ch8.adb

@@ -513,6 +513,7 @@ package body Sem_Ch8 is
 
    procedure Write_Scopes;
    pragma Warnings (Off, Write_Scopes);
+   pragma Export (Ada, Write_Scopes);
    --  Debugging information: dump all entities on scope stack
 
    --------------------------------

gcc/ada/sem_prag.adb

@@ -6554,6 +6554,14 @@ package body Sem_Prag is
 
             Def_Id := Entity (Id);
 
+            --  Check if already defined as constructor
+
+            if Is_Constructor (Def_Id) then
+               Error_Msg_N
+                 ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
+               return;
+            end if;
+
             if Ekind (Def_Id) = E_Function
               and then (Is_CPP_Class (Etype (Def_Id))
                          or else (Is_Class_Wide_Type (Etype (Def_Id))

gcc/ada/sem_util.adb

@@ -1564,22 +1564,48 @@ package body Sem_Util is
 
       function Search_Tag (Iface : Entity_Id) return Entity_Id is
          ADT : Elmt_Id;
-
       begin
+         if not Is_CPP_Class (T) then
             ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+         else
+            ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
+         end if;
+
          while Present (ADT)
-            and then Ekind (Node (ADT)) = E_Constant
+            and then Is_Tag (Node (ADT))
             and then Related_Type (Node (ADT)) /= Iface
          loop
-            --  Skip the secondary dispatch tables of Iface
+            --  Skip secondary dispatch table referencing thunks to user
+            --  defined primitives covered by this interface.
 
+            pragma Assert (Has_Suffix (Node (ADT), 'P'));
             Next_Elmt (ADT);
+
+            --  Skip secondary dispatch tables of Ada types
+
+            if not Is_CPP_Class (T) then
+
+               --  Skip secondary dispatch table referencing thunks to
+               --  predefined primitives.
+
+               pragma Assert (Has_Suffix (Node (ADT), 'Y'));
                Next_Elmt (ADT);
+
+               --  Skip secondary dispatch table referencing user-defined
+               --  primitives covered by this interface.
+
+               pragma Assert (Has_Suffix (Node (ADT), 'D'));
                Next_Elmt (ADT);
+
+               --  Skip secondary dispatch table referencing predefined
+               --  primitives
+
+               pragma Assert (Has_Suffix (Node (ADT), 'Z'));
                Next_Elmt (ADT);
+            end if;
          end loop;
 
-         pragma Assert (Ekind (Node (ADT)) = E_Constant);
+         pragma Assert (Is_Tag (Node (ADT)));
          return Node (ADT);
       end Search_Tag;
 
@@ -2499,6 +2525,28 @@ package body Sem_Util is
       end if;
    end Designate_Same_Unit;
 
+   --------------------------
+   -- Enclosing_CPP_Parent --
+   --------------------------
+
+   function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
+      Parent_Typ : Entity_Id := Typ;
+
+   begin
+      while not Is_CPP_Class (Parent_Typ)
+         and then Etype (Parent_Typ) /= Parent_Typ
+      loop
+         Parent_Typ := Etype (Parent_Typ);
+
+         if Is_Private_Type (Parent_Typ) then
+            Parent_Typ := Full_View (Base_Type (Parent_Typ));
+         end if;
+      end loop;
+
+      pragma Assert (Is_CPP_Class (Parent_Typ));
+      return Parent_Typ;
+   end Enclosing_CPP_Parent;
+
    ----------------------------
    -- Enclosing_Generic_Body --
    ----------------------------
@@ -5208,6 +5256,16 @@ package body Sem_Util is
       end if;
    end Has_Stream;
 
+   ----------------
+   -- Has_Suffix --
+   ----------------
+
+   function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
+   begin
+      Get_Name_String (Chars (E));
+      return Name_Buffer (Name_Len) = Suffix;
+   end Has_Suffix;
+
    --------------------------
    -- Has_Tagged_Component --
    --------------------------

gcc/ada/sem_util.ads

@@ -279,6 +279,9 @@ package Sem_Util is
    --  these names is supposed to be a selected component name, an expanded
    --  name, a defining program unit name or an identifier.
 
+   function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
+   --  Returns the closest ancestor of Typ that is a CPP type.
+
    function Enclosing_Generic_Body
      (N : Node_Id) return Node_Id;
    --  Returns the Node_Id associated with the innermost enclosing generic
@@ -578,6 +581,9 @@ package Sem_Util is
    --  applied to the underlying type (or returns False if there is no
    --  underlying type).
 
+   function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean;
+   --  Returns true if the last character of E is Suffix. Used in Assertions.
+
    function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
    --  Returns True if Typ is a composite type (array or record) which is
    --  either itself a tagged type, or has a component (recursively) which is