]> git.ipfire.org Git - thirdparty/gcc.git/commitdiff
2009-04-29 Javier Miranda <miranda@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 29 Apr 2009 13:29:08 +0000 (13:29 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 29 Apr 2009 13:29:08 +0000 (13:29 +0000)
* 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

14 files changed:
gcc/ada/ChangeLog
gcc/ada/exp_aggr.adb
gcc/ada/exp_ch3.adb
gcc/ada/exp_ch3.ads
gcc/ada/exp_disp.adb
gcc/ada/exp_disp.ads
gcc/ada/exp_tss.adb
gcc/ada/exp_tss.ads
gcc/ada/gnat_rm.texi
gcc/ada/sem_ch3.adb
gcc/ada/sem_ch5.adb
gcc/ada/sem_prag.adb
gcc/ada/sem_util.adb
gcc/ada/sem_util.ads

index 3c14d9e7ba092a08e0762366ca9ccb64974dd13f..7b3f1fbb6789be4a52eeae3e45caa5fa8f768670 100644 (file)
@@ -1,3 +1,51 @@
+2009-04-29  Javier Miranda  <miranda@adacore.com>
+
+       * sem_ch3.adb (Analyze_Object_Declaration): Disable error message
+       associated with dyamically tagged expressions if the expression
+       initializing a tagged type corresponds with a non default CPP
+       constructor.
+       (OK_For_Limited_Init): CPP constructor calls are OK for initialization
+       of limited type objects.
+
+       * sem_ch5.adb (Analyze_Assignment): Improve the error message reported
+       when a CPP constructor is called in an assignment. Disable also the
+       error message associated with dyamically tagged expressions if the
+       exporession initializing a tagged type corresponds with a non default
+       CPP constructor.
+
+       * sem_prag.adb (Analyze_Pragma): Remove code disabling the use of
+       non-default C++ constructors.
+
+       * sem_util.ads, sem_util.adb (Is_CPP_Constructor_Call): New subprogram.
+
+       * exp_tss.ads, exp_tss.adb (Base_Init_Proc): Add support for
+       non-default constructors.
+       (Init_Proc): Add support for non-default constructors.
+
+       * exp_disp.adb (Set_Default_Constructor): Removed.
+       (Set_CPP_Constructors): Code based in removed Set_Default_Constructor
+       but extending its functionality to handle non-default constructors.
+
+       * exp_aggr.adb (Build_Record_Aggr_Code): Add support for non-default
+       constructors. Minor code cleanup removing unrequired label and goto
+       statement.
+
+       * exp_ch3.adb (Build_Initialization_Call): Add support for non-default
+       constructors.
+       (Build_Init_Statements): Add support for non-default constructors.
+       (Expand_N_Object_Declaration): Add support for non-default constructors.
+       (Freeze_Record_Type): Replace call to Set_Default_Constructor by call
+       to Set_CPP_Constructors.
+
+       * exp_ch5.adb (Expand_N_Assignment_Statement): Add support for
+       non-default constructors.
+       Required to handle its use in build-in-place statements.
+
+       * gnat_rm.texi (CPP_Constructor): Document new extended use of this
+       pragma for non-default C++ constructors and the new compiler support
+       that allows the use of these constructors in record components, limited
+       aggregates, and extended return statements.
+
 2009-04-29  Vincent Celier  <celier@adacore.com>
 
        * prj-part.adb (Parse_Single_Project): Do not attempt to find a
index 7c38cba86243c5b3c2d5a76d4205898b1848daa8..516905f88732298ce52945b946493da9791e48be 100644 (file)
@@ -2775,10 +2775,24 @@ package body Exp_Aggr is
       while Present (Comp) loop
          Selector := Entity (First (Choices (Comp)));
 
+         --  C++ constructors
+
+         if Is_CPP_Constructor_Call (Expression (Comp)) then
+            Append_List_To (L,
+              Build_Initialization_Call (Loc,
+                Id_Ref => Make_Selected_Component (Loc,
+                            Prefix => New_Copy_Tree (Target),
+                            Selector_Name => New_Occurrence_Of (Selector,
+                                                                   Loc)),
+                Typ    => Etype (Selector),
+                Enclos_Type => Typ,
+                With_Default_Init => True,
+                Constructor_Ref => Expression (Comp)));
+
          --  Ada 2005 (AI-287): For each default-initialized component generate
          --  a call to the corresponding IP subprogram if available.
 
-         if Box_Present (Comp)
+         elsif Box_Present (Comp)
            and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
          then
             if Ekind (Selector) /= E_Discriminant then
@@ -2822,12 +2836,9 @@ package body Exp_Aggr is
                 Enclos_Type => Typ,
                 With_Default_Init => True));
 
-            goto Next_Comp;
-         end if;
-
          --  Prepare for component assignment
 
-         if Ekind (Selector) /= E_Discriminant
+         elsif Ekind (Selector) /= E_Discriminant
            or else Nkind (N) = N_Extension_Aggregate
          then
             --  All the discriminants have now been assigned
@@ -3107,8 +3118,6 @@ package body Exp_Aggr is
             end;
          end if;
 
-         <<Next_Comp>>
-
          Next (Comp);
       end loop;
 
index d05cdbba9e8df308a094b6c063d224c5e9e6e503..5ba57dea13439c43512af2230a61fcfe253edc2d 100644 (file)
@@ -1368,22 +1368,35 @@ package body Exp_Ch3 is
       In_Init_Proc      : Boolean := False;
       Enclos_Type       : Entity_Id := Empty;
       Discr_Map         : Elist_Id := New_Elmt_List;
-      With_Default_Init : Boolean := False) return List_Id
+      With_Default_Init : Boolean := False;
+      Constructor_Ref   : Node_Id := Empty) return List_Id
    is
-      First_Arg      : Node_Id;
+      Res            : constant List_Id := New_List;
+      Arg            : Node_Id;
       Args           : List_Id;
-      Decls          : List_Id;
+      Controller_Typ : Entity_Id;
       Decl           : Node_Id;
+      Decls          : List_Id;
       Discr          : Entity_Id;
-      Arg            : Node_Id;
-      Proc           : constant Entity_Id := Base_Init_Proc (Typ);
-      Init_Type      : constant Entity_Id := Etype (First_Formal (Proc));
-      Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type);
-      Res            : constant List_Id   := New_List;
+      First_Arg      : Node_Id;
+      Full_Init_Type : Entity_Id;
       Full_Type      : Entity_Id := Typ;
-      Controller_Typ : Entity_Id;
+      Init_Type      : Entity_Id;
+      Proc           : Entity_Id;
 
    begin
+      pragma Assert (Constructor_Ref = Empty
+        or else Is_CPP_Constructor_Call (Constructor_Ref));
+
+      if No (Constructor_Ref) then
+         Proc := Base_Init_Proc (Typ);
+      else
+         Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
+      end if;
+
+      Init_Type      := Etype (First_Formal (Proc));
+      Full_Init_Type := Underlying_Type (Init_Type);
+
       --  Nothing to do if the Init_Proc is null, unless Initialize_Scalars
       --  is active (in which case we make the call anyway, since in the
       --  actual compiled client it may be non null).
@@ -1579,6 +1592,10 @@ package body Exp_Ch3 is
         and then Chars (Selector_Name (Id_Ref)) = Name_uParent
       then
          Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
+
+      elsif Present (Constructor_Ref) then
+         Append_List_To (Args,
+           New_Copy_List (Parameter_Associations (Constructor_Ref)));
       end if;
 
       Append_To (Res,
@@ -2589,7 +2606,21 @@ package body Exp_Ch3 is
                --  Case of explicit initialization
 
                if Present (Expression (Decl)) then
-                  Stmts := Build_Assignment (Id, Expression (Decl));
+                  if Is_CPP_Constructor_Call (Expression (Decl)) then
+                     Stmts :=
+                       Build_Initialization_Call
+                         (Loc,
+                          Make_Selected_Component (Loc,
+                            Prefix => Make_Identifier (Loc, Name_uInit),
+                            Selector_Name => New_Occurrence_Of (Id, Loc)),
+                          Typ,
+                          In_Init_Proc => True,
+                          Enclos_Type => Rec_Type,
+                          Discr_Map => Discr_Map,
+                          Constructor_Ref => Expression (Decl));
+                  else
+                     Stmts := Build_Assignment (Id, Expression (Decl));
+                  end if;
 
                --  Case of composite component with its own Init_Proc
 
@@ -4622,6 +4653,26 @@ package body Exp_Ch3 is
                              (Access_Disp_Table (Base_Type (Typ)))),
                           Loc))));
 
+            elsif Is_Tagged_Type (Typ)
+              and then Is_CPP_Constructor_Call (Expr)
+            then
+               --  The call to the initialization procedure does NOT freeze the
+               --  object being initialized.
+
+               Id_Ref := New_Reference_To (Def_Id, Loc);
+               Set_Must_Not_Freeze (Id_Ref);
+               Set_Assignment_OK (Id_Ref);
+
+               Insert_Actions_After (Init_After,
+                 Build_Initialization_Call (Loc, Id_Ref, Typ,
+                   Constructor_Ref => Expr));
+
+               --  We remove here the original call to the constructor
+               --  to avoid its management in the backend
+
+               Set_Expression (N, Empty);
+               return;
+
             --  For discrete types, set the Is_Known_Valid flag if the
             --  initializing value is known to be valid.
 
@@ -5629,7 +5680,7 @@ package body Exp_Ch3 is
 
          if Is_CPP_Class (Def_Id) then
             Set_All_DT_Position (Def_Id);
-            Set_Default_Constructor (Def_Id);
+            Set_CPP_Constructors (Def_Id);
 
             --  Create the tag entities with a minimum decoration
 
index d51724af3cd3e16b084dc0948dfbe84eb77895e4..6738ae958f9a0951c630735ee923a5de0e9650d1 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -67,7 +67,8 @@ package Exp_Ch3 is
       In_Init_Proc      : Boolean := False;
       Enclos_Type       : Entity_Id := Empty;
       Discr_Map         : Elist_Id := New_Elmt_List;
-      With_Default_Init : Boolean := False) return List_Id;
+      With_Default_Init : Boolean := False;
+      Constructor_Ref   : Node_Id := Empty) return List_Id;
    --  Builds a call to the initialization procedure for the base type of Typ,
    --  passing it the object denoted by Id_Ref, plus additional parameters as
    --  appropriate for the type (the _Master, for task types, for example).
@@ -88,6 +89,9 @@ package Exp_Ch3 is
    --  Ada 2005 (AI-287): With_Default_Init is used to indicate that the
    --  initialization call corresponds to a default initialized component
    --  of an aggregate.
+   --
+   --  Constructor_Ref is a call to a constructor subprogram. It is currently
+   --  used only to support C++ constructors.
 
    procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id);
    --  If the designated type of an access type is a task type or contains
index 7df45501536120095f9ba4a5cf0830fea85328c3..23dc728f98887e67548475feeb232a129210cd34 100644 (file)
@@ -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 --
index ed8666952466f42e9bdba1a453f84a1cb44831a1..c91798f24509fc3be2c888779b87bb424170a534 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -328,10 +328,13 @@ package Exp_Disp is
    --  Class case check that no pragma CPP_Virtual is missing and that the
    --  DT_Position are coherent
 
-   procedure Set_Default_Constructor (Typ : Entity_Id);
-   --  Typ is a CPP_Class type. Create the Init procedure of that type to
-   --  be the default constructor (i.e. the function returning this type,
-   --  having a pragma CPP_Constructor and no parameter)
+   procedure Set_CPP_Constructors (Typ : Entity_Id);
+   --  Typ is a CPP_Class type. Create the Init procedures of that type
+   --  required to handle its default and non-default constructors. The
+   --  functions to which pragma CPP_Constructor is applied in the sources
+   --  are functions returning this type, and having an implicit access to the
+   --  target object in its first argument; such implicit argument is explicit
+   --  in the IP procedures built here.
 
    procedure Set_DTC_Entity_Value
      (Tagged_Type : Entity_Id;
index b350644c24e74e59788def3ea6648208d189681a..c7e03660d9487062da52d543b3aef36da4ad3f8e 100644 (file)
@@ -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);
index e72e38cc2c0d569525bc65653f3aea1218db3352..b81199ccf292f102b1502a21c06e26952dd08c1f 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -187,8 +187,9 @@ package Exp_Tss is
    --  used to initially install a TSS in the case where the subprogram for the
    --  TSS has already been created and its declaration processed.
 
-   function Init_Proc (Typ : Entity_Id) return Entity_Id;
-   pragma Inline (Init_Proc);
+   function Init_Proc
+     (Typ : Entity_Id;
+      Ref : Entity_Id := Empty) return Entity_Id;
    --  Obtains the _init TSS entry for the given type. This function call is
    --  equivalent to TSS (Typ, Name_uInit). The _init TSS is the procedure
    --  used to initialize otherwise uninitialized instances of a type. If
@@ -198,14 +199,21 @@ package Exp_Tss is
    --  the corresponding base type (see Base_Init_Proc function). A special
    --  case arises for concurrent types. Such types do not themselves have an
    --  init proc TSS, but initialization is required. The init proc used is
-   --  the one for the corresponding record type (see Base_Init_Proc).
+   --  the one for the corresponding record type (see Base_Init_Proc). If
+   --  Ref is present it is call to a subprogram whose profile matches the
+   --  profile of the required constructor (this argument is used to handle
+   --  non-default CPP constructors).
 
-   function Base_Init_Proc (Typ : Entity_Id) return Entity_Id;
+   function Base_Init_Proc
+     (Typ : Entity_Id;
+      Ref : Entity_Id := Empty) return Entity_Id;
    --  Obtains the _Init TSS entry from the base type of the entity, and also
    --  deals with going indirect through the Corresponding_Record_Type field
    --  for concurrent objects (which are initialized with the initialization
-   --  routine for the corresponding record type). Returns Empty if there is
-   --  no _Init TSS entry for the base type.
+   --  routine for the corresponding record type). Returns Empty if there is no
+   --  _Init TSS entry for the base type. If Ref is present it is a call to a
+   --  subprogram whose profile matches the profile of the required constructor
+   --  (this argument is used to handle non-default CPP constructors).
 
    procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id);
    pragma Inline (Set_Init_Proc);
index 81b6a1140bc4b92bb098faa6b48faa6bd2af8fd8..509717f681d8a3efb2c513cc81d1c7322fbf04d1 100644 (file)
@@ -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.
index 114e217986f7c57db1635c6c67cdc2af6dbda08b..9bd9a00126052f831982aba484828d13cb826ba4 100644 (file)
@@ -2656,6 +2656,7 @@ package body Sem_Ch3 is
          if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
            and then Is_Tagged_Type (T)
            and then not Is_Class_Wide_Type (T)
+           and then not Is_CPP_Constructor_Call (E)
          then
             Error_Msg_N ("dynamically tagged expression not allowed!", E);
          end if;
@@ -15311,9 +15312,10 @@ package body Sem_Ch3 is
 
    function OK_For_Limited_Init (Exp : Node_Id) return Boolean is
    begin
-      return Ada_Version >= Ada_05
-        and then not Debug_Flag_Dot_L
-        and then OK_For_Limited_Init_In_05 (Exp);
+      return Is_CPP_Constructor_Call (Exp)
+        or else (Ada_Version >= Ada_05
+                  and then not Debug_Flag_Dot_L
+                  and then OK_For_Limited_Init_In_05 (Exp));
    end OK_For_Limited_Init;
 
    -------------------------------
index 5cf092c9917fcdd160fe2c443ae1227333211a6a..37975bc73a7b62313e522faa9b5e198b2dc75f0a 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -436,9 +436,15 @@ package body Sem_Ch5 is
         and then not Assignment_OK (Original_Node (Lhs))
         and then not Is_Value_Type (T1)
       then
-         Error_Msg_N
-           ("left hand of assignment must not be limited type", Lhs);
-         Explain_Limited_Type (T1, Lhs);
+         --  CPP constructors can only be called in declarations
+
+         if Is_CPP_Constructor_Call (Rhs) then
+            Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs);
+         else
+            Error_Msg_N
+              ("left hand of assignment must not be limited type", Lhs);
+            Explain_Limited_Type (T1, Lhs);
+         end if;
          return;
 
       --  Enforce RM 3.9.3 (8): left-hand side cannot be abstract
@@ -543,6 +549,7 @@ package body Sem_Ch5 is
            or else (Is_Dynamically_Tagged (Rhs)
                      and then not Is_Access_Type (T1)))
         and then not Is_Class_Wide_Type (T1)
+        and then not Is_CPP_Constructor_Call (Rhs)
       then
          Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
 
index daa607bb6efce3cceee8d2b63a8f60ba87b78c3f..926f750405d1987a420c703f2376991706e8d42f 100644 (file)
@@ -6201,13 +6201,8 @@ package body Sem_Prag is
                   Process_Interface_Name (Def_Id, Arg2, Arg3);
                end if;
 
-               if No (Parameter_Specifications (Parent (Def_Id))) then
-                  Set_Has_Completion (Def_Id);
-                  Set_Is_Constructor (Def_Id);
-               else
-                  Error_Pragma_Arg
-                    ("non-default constructors not implemented", Arg1);
-               end if;
+               Set_Has_Completion (Def_Id);
+               Set_Is_Constructor (Def_Id);
 
             else
                Error_Pragma_Arg
index e76e9d2c987aa7bb4da6c0f79ee6b16a521e1880..d7e85261dfe4062cb31f53b056a5e9349f7d1919 100644 (file)
@@ -5518,6 +5518,19 @@ package body Sem_Util is
       return False;
    end Is_Controlling_Limited_Procedure;
 
+   -----------------------------
+   -- Is_CPP_Constructor_Call --
+   -----------------------------
+
+   function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
+   begin
+      return Nkind (N) = N_Function_Call
+        and then Is_Class_Wide_Type (Etype (N))
+        and then Is_CPP_Class (Etype (Etype (N)))
+        and then Is_Constructor (Entity (Name (N)))
+        and then Is_Imported (Entity (Name (N)));
+   end Is_CPP_Constructor_Call;
+
    ----------------------------------------------
    -- Is_Dependent_Component_Of_Mutable_Object --
    ----------------------------------------------
index 4046b785892ef446fdd8dd87e1f4d1a9d4229c0c..9e2d3ffcf1e7c7e326f973786c63b724ef085459 100644 (file)
@@ -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