exp_disp.adb (Make_DT, [...]): Set attribute Is_Static_Dispatch_Table

2008-03-26  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Make_DT, Make_Secondary_DT): Set attribute
	Is_Static_Dispatch_Table
	(Build_Dispatch_Tables): Replace calls to Exchange_Entities() by calls
	to Exchange_Declarations to exchange the private and full-view. Bug
	found working in this issue.
	(Expand_Dispatching_Call): Propagate the convention of the subprogram
	to the subprogram pointer type.
	(Make_Secondary_DT): Replace generation of Prim'Address by
	Address (Prim'Unrestricted_Access)
	(Make_DT): Replace generation of Prim'Address by
	Address (Prim'Unrestricted_Access)
	(Make_Disp_*_Bodies): When compiling for a restricted profile, use
	simple call form for single entry.
	(Make_DT): Handle new contents of Access_Disp_Table (access to dispatch
	tables of predefined primitives).
	(Make_Secondary_DT): Add support to handle access to dispatch tables of
	predefined primitives.
	(Make_Tags): Add entities to Access_Dispatch_Table associated with
	access to dispatch tables containing predefined primitives.

	* exp_ch6.adb (N_Pragma): Chars field removed, use Chars
	(Pragma_Identifier (..  instead, adjustments throughout to accomodate
	this change.
	(Register_Predefined_DT_Entry): Updated to handle the new contents
	of attribute Access_Disp_Table (pointers to dispatch tables containing
	predefined primitives).

	* exp_util.ads, exp_util.adb (Corresponding_Runtime_Package): New
	subprogram.
	(Find_Interface_ADT): Updated to skip the new contents of attribute
	Access_Dispatch_Table (pointers to dispatch tables containing predefined
	primitives).

	* sem_util.adb (Has_Abstract_Interfaces): Add missing support for
	concurrent types.
	(Set_Convention): Use new function Is_Access_Subprogram_Type
	(Collect_Interfaces_Info): Updated to skip the new contents of attribute
	Access_Dispatch_Table (pointers to dispatch tables containing predefined
	primitives).

	* exp_atag.ads, exp_atag.adb (Build_Inherit_Predefined_Prims): Improve
	expanded code avoiding calls to Build_Predef_Prims.
	(Build_Set_Predefined_Prim_Op_Address): Improve expanded code avoiding
	call to Build_Get_Predefined_Prim_Op_Address.

From-SVN: r133564

diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb
index 670ddf8b868fc93adc91abd4dedec4b4fb66bbdc..c2c37a7eb30a0aa1534c111f80854f7c271e6faa 100644 (file)
--- a/gcc/ada/exp_atag.adb
+++ b/gcc/ada/exp_atag.adb
@@ -369,64 +369,32 @@ package body Exp_Atag is
       New_Tag_Node : Node_Id) return Node_Id
    is
    begin
-      if RTE_Available (RE_DT) then
-         return
-           Make_Assignment_Statement (Loc,
-             Name =>
-               Make_Slice (Loc,
-                 Prefix =>
-                   Make_Explicit_Dereference (Loc,
-                     Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
-                       Make_Selected_Component (Loc,
-                         Prefix =>
-                           Build_DT (Loc, New_Tag_Node),
-                         Selector_Name =>
-                           New_Reference_To
-                             (RTE_Record_Component (RE_Predef_Prims), Loc)))),
-                 Discrete_Range => Make_Range (Loc,
-                   Make_Integer_Literal (Loc, Uint_1),
-                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
-
-             Expression =>
-               Make_Slice (Loc,
-                 Prefix =>
-                   Make_Explicit_Dereference (Loc,
-                     Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
-                       Make_Selected_Component (Loc,
-                         Prefix =>
-                           Build_DT (Loc, Old_Tag_Node),
-                         Selector_Name =>
-                           New_Reference_To
-                             (RTE_Record_Component (RE_Predef_Prims), Loc)))),
-
-                 Discrete_Range =>
-                   Make_Range (Loc,
-                     Low_Bound  => Make_Integer_Literal (Loc, 1),
-                     High_Bound =>
-                       New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
-      else
-         return
-           Make_Assignment_Statement (Loc,
-             Name =>
-               Make_Slice (Loc,
-                 Prefix =>
-                   Make_Explicit_Dereference (Loc,
-                     Build_Predef_Prims (Loc, New_Tag_Node)),
-                 Discrete_Range => Make_Range (Loc,
-                   Make_Integer_Literal (Loc, Uint_1),
-                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
+      return
+        Make_Assignment_Statement (Loc,
+          Name =>
+            Make_Slice (Loc,
+              Prefix =>
+                Make_Explicit_Dereference (Loc,
+                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+                    Make_Explicit_Dereference (Loc,
+                      Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+                        New_Tag_Node)))),
+              Discrete_Range => Make_Range (Loc,
+                Make_Integer_Literal (Loc, Uint_1),
+                New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
 
-             Expression =>
-               Make_Slice (Loc,
-                 Prefix =>
-                   Make_Explicit_Dereference (Loc,
-                     Build_Predef_Prims (Loc, Old_Tag_Node)),
-                 Discrete_Range =>
-                   Make_Range (Loc,
-                     Low_Bound  => Make_Integer_Literal (Loc, 1),
-                     High_Bound =>
-                       New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
-      end if;
+          Expression =>
+            Make_Slice (Loc,
+              Prefix =>
+                Make_Explicit_Dereference (Loc,
+                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+                    Make_Explicit_Dereference (Loc,
+                      Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+                        Old_Tag_Node)))),
+              Discrete_Range =>
+                Make_Range (Loc,
+                  Make_Integer_Literal (Loc, 1),
+                  New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
    end Build_Inherit_Predefined_Prims;
 
    ------------------------
@@ -472,8 +440,15 @@ package body Exp_Atag is
    begin
       return
          Make_Assignment_Statement (Loc,
-           Name       => Build_Get_Predefined_Prim_Op_Address (Loc,
-                           Tag_Node, Position),
+           Name =>
+             Make_Indexed_Component (Loc,
+               Prefix =>
+                 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+                   Make_Explicit_Dereference (Loc,
+                     Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
+               Expressions =>
+                 New_List (Make_Integer_Literal (Loc, Position))),
+
            Expression => Address_Node);
    end Build_Set_Predefined_Prim_Op_Address;
 

diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads
index 5f22431062b8dbfc926e1c3440dc918e22d6d233..9d724f291407e9687c8e00b7655dd8df18ce8a0b 100644 (file)
--- a/gcc/ada/exp_atag.ads
+++ b/gcc/ada/exp_atag.ads
@@ -90,15 +90,16 @@ package Exp_Atag is
    --  Generates: TSD (Tag).Transportable;
 
    function Build_Inherit_Predefined_Prims
-     (Loc              : Source_Ptr;
-      Old_Tag_Node     : Node_Id;
-      New_Tag_Node     : Node_Id) return Node_Id;
+     (Loc          : Source_Ptr;
+      Old_Tag_Node : Node_Id;
+      New_Tag_Node : Node_Id) return Node_Id;
    --  Build code that inherits the predefined primitives of the parent.
    --
    --  Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
    --               Predefined_DT (Old_T).D (All_Predefined_Prims);
    --
-   --  Required to build the dispatch tables with the 3.4 backend.
+   --  Required to build non-library level dispatch tables. Also required
+   --  when compiling without static dispatch tables support.
 
    function Build_Inherit_Prims
      (Loc          : Source_Ptr;

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 8d75049fbc7986198d1bd8f891f6c37f3996456f..c5f88c7a8987e0733b29084cf8382c923ae575c6 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3388,7 +3388,7 @@ package body Exp_Ch6 is
          --  not be posting warnings on the inlined body so it is unneeded.
 
          elsif Nkind (N) = N_Pragma
-           and then Chars (N) = Name_Unreferenced
+           and then Pragma_Name (N) = Name_Unreferenced
          then
             Rewrite (N, Make_Null_Statement (Sloc (N)));
             return OK;
@@ -4756,14 +4756,14 @@ package body Exp_Ch6 is
             return;
          end if;
 
-         --  Skip the first access-to-dispatch-table pointer since it leads
-         --  to the primary dispatch table. We are only concerned with the
-         --  secondary dispatch table pointers. Note that the access-to-
-         --  dispatch-table pointer corresponds to the first implemented
-         --  interface retrieved below.
+         --  Skip the first two access-to-dispatch-table pointers since they
+         --  leads to the primary dispatch table (predefined DT and user
+         --  defined DT). We are only concerned with the secondary dispatch
+         --  table pointers. Note that the access-to- dispatch-table pointer
+         --  corresponds to the first implemented interface retrieved below.
 
          Iface_DT_Ptr :=
-           Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)));
+           Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
 
          while Present (Iface_DT_Ptr)
             and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
@@ -4776,23 +4776,41 @@ package body Exp_Ch6 is
                  Thunk_Code,
 
                  Build_Set_Predefined_Prim_Op_Address (Loc,
-                   Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc),
+                   Tag_Node =>
+                     New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
                    Position => DT_Position (Prim),
                    Address_Node =>
-                     Make_Attribute_Reference (Loc,
-                       Prefix         => New_Reference_To (Thunk_Id, Loc),
-                       Attribute_Name => Name_Address)),
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (Thunk_Id, Loc),
+                         Attribute_Name => Name_Unrestricted_Access))),
 
                  Build_Set_Predefined_Prim_Op_Address (Loc,
-                   Tag_Node => New_Reference_To
-                                 (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
+                   Tag_Node =>
+                     New_Reference_To
+                      (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
+                       Loc),
                    Position => DT_Position (Prim),
                    Address_Node =>
-                     Make_Attribute_Reference (Loc,
-                       Prefix         => New_Reference_To (Prim, Loc),
-                       Attribute_Name => Name_Address))));
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (Prim, Loc),
+                         Attribute_Name => Name_Unrestricted_Access)))));
             end if;
 
+            --  Skip the tag of the predefined primitives dispatch table
+
+            Next_Elmt (Iface_DT_Ptr);
+            pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
+
+            --  Skip the tag of the no-thunks dispatch table
+
+            Next_Elmt (Iface_DT_Ptr);
+            pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
+
+            --  Skip the tag of the predefined primitives no-thunks dispatch
+            --  table
+
             Next_Elmt (Iface_DT_Ptr);
             pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
 

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index de26ec249faead61a73971575c1be4ef9f8006e0..c14c7348dea2ed1180f7f28c758c18222782a081 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -46,6 +46,7 @@ with Rident;   use Rident;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch7;  use Sem_Ch7;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
@@ -175,14 +176,14 @@ package body Exp_Disp is
                           /= E_Record_Subtype
             then
                declare
-                  E1, E2 : Entity_Id;
+                  E1 : constant Entity_Id := Defining_Entity (D);
+                  E2 : constant Entity_Id := Full_View (Defining_Entity (D));
+
                begin
-                  E1 := Defining_Entity (D);
-                  E2 := Full_View (Defining_Entity (D));
-                  Exchange_Entities (E1, E2);
+                  Exchange_Declarations (E1);
                   Insert_List_After_And_Analyze (Last (Target_List),
                     Make_DT (E1));
-                  Exchange_Entities (E1, E2);
+                  Exchange_Declarations (E2);
                end;
             end if;
 
@@ -612,6 +613,7 @@ package body Exp_Disp is
 
       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
+      Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
 
       --  If the controlling argument is a value of type Ada.Tag or an abstract
       --  interface class-wide type then use it directly. Otherwise, the tag
@@ -1531,6 +1533,7 @@ package body Exp_Disp is
       Decls     : constant List_Id    := New_List;
       DT_Ptr    : Entity_Id;
       Loc       : constant Source_Ptr := Sloc (Typ);
+      Obj_Ref   : Node_Id;
       Stmts     : constant List_Id    := New_List;
 
    begin
@@ -1593,46 +1596,78 @@ package body Exp_Disp is
                 Object_Definition =>
                   New_Reference_To (RTE (RE_Communication_Block), Loc)));
 
-            --  Generate:
-            --    Protected_Entry_Call
-            --      (T._object'Access,            --  Object
-            --       Protected_Entry_Index! (I),  --  E
-            --       P,                           --  Uninterpreted_Data
-            --       Asynchronous_Call,           --  Mode
-            --       Bnn);                        --  Communication_Block
+            --  Build T._object'Access for calls below
 
-            --  where T is the protected object, I is the entry index, P are
-            --  the wrapped parameters and B is the name of the communication
-            --  block.
+            Obj_Ref :=
+               Make_Attribute_Reference (Loc,
+                 Attribute_Name => Name_Unchecked_Access,
+                 Prefix         =>
+                   Make_Selected_Component (Loc,
+                     Prefix        => Make_Identifier (Loc, Name_uT),
+                     Selector_Name => Make_Identifier (Loc, Name_uObject)));
 
-            Append_To (Stmts,
-              Make_Procedure_Call_Statement (Loc,
-                Name =>
-                  New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
-                Parameter_Associations =>
-                  New_List (
+            case Corresponding_Runtime_Package (Conc_Typ) is
+               when System_Tasking_Protected_Objects_Entries =>
 
-                    Make_Attribute_Reference (Loc,        -- T._object'Access
-                      Attribute_Name =>
-                        Name_Unchecked_Access,
-                      Prefix =>
-                        Make_Selected_Component (Loc,
-                          Prefix =>
-                            Make_Identifier (Loc, Name_uT),
-                          Selector_Name =>
-                            Make_Identifier (Loc, Name_uObject))),
+                  --  Generate:
+                  --    Protected_Entry_Call
+                  --      (T._object'Access,            --  Object
+                  --       Protected_Entry_Index! (I),  --  E
+                  --       P,                           --  Uninterpreted_Data
+                  --       Asynchronous_Call,           --  Mode
+                  --       Bnn);                        --  Communication_Block
+
+                  --  where T is the protected object, I is the entry index, P
+                  --  is the wrapped parameters and B is the name of the
+                  --  communication block.
+
+                  Append_To (Stmts,
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+                      Parameter_Associations =>
+                        New_List (
+                          Obj_Ref,
 
-                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
-                      Subtype_Mark =>
-                        New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
-                      Expression =>
-                        Make_Identifier (Loc, Name_uI)),
+                          Make_Unchecked_Type_Conversion (Loc,  --  entry index
+                            Subtype_Mark =>
+                              New_Reference_To
+                                 (RTE (RE_Protected_Entry_Index), Loc),
+                            Expression => Make_Identifier (Loc, Name_uI)),
 
-                    Make_Identifier (Loc, Name_uP),       --  parameter block
-                    New_Reference_To (                    --  Asynchronous_Call
-                      RTE (RE_Asynchronous_Call), Loc),
+                          Make_Identifier (Loc, Name_uP), --  parameter block
+                          New_Reference_To (              --  Asynchronous_Call
+                            RTE (RE_Asynchronous_Call), Loc),
+
+                          New_Reference_To (Com_Block, Loc)))); -- comm block
+
+               when System_Tasking_Protected_Objects_Single_Entry =>
+
+                  --  Generate:
+                  --    procedure Protected_Single_Entry_Call
+                  --      (Object              : Protection_Entry_Access;
+                  --       Uninterpreted_Data  : System.Address;
+                  --       Mode                : Call_Modes);
 
-                    New_Reference_To (Com_Block, Loc)))); -- comm block
+                  Append_To (Stmts,
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To
+                          (RTE (RE_Protected_Single_Entry_Call), Loc),
+                      Parameter_Associations =>
+                        New_List (
+                          Obj_Ref,
+
+                          Make_Attribute_Reference (Loc,
+                            Prefix => Make_Identifier (Loc, Name_uP),
+                            Attribute_Name => Name_Address),
+
+                            New_Reference_To
+                             (RTE (RE_Asynchronous_Call), Loc))));
+
+               when others =>
+                  raise Program_Error;
+            end case;
 
             --  Generate:
             --    B := Dummy_Communication_Block (Bnn);
@@ -1660,7 +1695,7 @@ package body Exp_Disp is
             --       Asynchronous_Call,      --  Mode
             --       F);                     --  Rendezvous_Successful
 
-            --  where T is the task object, I is the entry index, P are the
+            --  where T is the task object, I is the entry index, P is the
             --  wrapped parameters and F is the status flag.
 
             Append_To (Stmts,
@@ -1669,7 +1704,6 @@ package body Exp_Disp is
                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
                 Parameter_Associations =>
                   New_List (
-
                     Make_Selected_Component (Loc,         -- T._task_id
                       Prefix =>
                         Make_Identifier (Loc, Name_uT),
@@ -1843,6 +1877,7 @@ package body Exp_Disp is
       Conc_Typ : Entity_Id           := Empty;
       Decls    : constant List_Id    := New_List;
       DT_Ptr   : Entity_Id;
+      Obj_Ref  : Node_Id;
       Stmts    : constant List_Id    := New_List;
 
    begin
@@ -1929,46 +1964,73 @@ package body Exp_Disp is
 
          if Ekind (Conc_Typ) = E_Protected_Type then
 
-            --  Generate:
-            --    Protected_Entry_Call
-            --      (T._object'Access,            --  Object
-            --       Protected_Entry_Index! (I),  --  E
-            --       P,                           --  Uninterpreted_Data
-            --       Conditional_Call,            --  Mode
-            --       Bnn);                        --  Block
+            Obj_Ref :=                                  -- T._object'Access
+               Make_Attribute_Reference (Loc,
+                 Attribute_Name => Name_Unchecked_Access,
+                 Prefix         =>
+                   Make_Selected_Component (Loc,
+                     Prefix        => Make_Identifier (Loc, Name_uT),
+                     Selector_Name => Make_Identifier (Loc, Name_uObject)));
 
-            --  where T is the protected object, I is the entry index, P are
-            --  the wrapped parameters and Bnn is the name of the communication
-            --  block.
+            case Corresponding_Runtime_Package (Conc_Typ) is
+               when System_Tasking_Protected_Objects_Entries =>
+                  --  Generate:
 
-            Append_To (Stmts,
-              Make_Procedure_Call_Statement (Loc,
-                Name =>
-                  New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
-                Parameter_Associations =>
-                  New_List (
+                  --    Protected_Entry_Call
+                  --      (T._object'Access,            --  Object
+                  --       Protected_Entry_Index! (I),  --  E
+                  --       P,                           --  Uninterpreted_Data
+                  --       Conditional_Call,            --  Mode
+                  --       Bnn);                        --  Block
 
-                    Make_Attribute_Reference (Loc,        -- T._object'Access
-                      Attribute_Name =>
-                        Name_Unchecked_Access,
-                      Prefix =>
-                        Make_Selected_Component (Loc,
-                          Prefix =>
-                            Make_Identifier (Loc, Name_uT),
-                          Selector_Name =>
-                            Make_Identifier (Loc, Name_uObject))),
+                  --  where T is the protected object, I is the entry index, P
+                  --  are the wrapped parameters and Bnn is the name of the
+                  --  communication block.
 
-                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
-                      Subtype_Mark =>
-                        New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
-                      Expression =>
-                        Make_Identifier (Loc, Name_uI)),
+                  Append_To (Stmts,
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+                      Parameter_Associations =>
+                        New_List (
+                          Obj_Ref,
 
-                    Make_Identifier (Loc, Name_uP),       --  parameter block
-                    New_Reference_To (                    --  Conditional_Call
-                      RTE (RE_Conditional_Call), Loc),
-                    New_Reference_To (                    --  Bnn
-                      Blk_Nam, Loc))));
+                          Make_Unchecked_Type_Conversion (Loc,  --  entry index
+                            Subtype_Mark =>
+                              New_Reference_To
+                                 (RTE (RE_Protected_Entry_Index), Loc),
+                            Expression => Make_Identifier (Loc, Name_uI)),
+
+                          Make_Identifier (Loc, Name_uP),  --  parameter block
+
+                          New_Reference_To (               --  Conditional_Call
+                            RTE (RE_Conditional_Call), Loc),
+                          New_Reference_To (               --  Bnn
+                            Blk_Nam, Loc))));
+
+               when System_Tasking_Protected_Objects_Single_Entry =>
+
+                  --    If we are compiling for a restricted run-time, the call
+                  --    uses the simpler form.
+
+                  Append_To (Stmts,
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To
+                          (RTE (RE_Protected_Single_Entry_Call), Loc),
+                      Parameter_Associations =>
+                        New_List (
+                          Obj_Ref,
+
+                          Make_Attribute_Reference (Loc,
+                            Prefix => Make_Identifier (Loc, Name_uP),
+                            Attribute_Name => Name_Address),
+
+                            New_Reference_To
+                             (RTE (RE_Conditional_Call), Loc))));
+               when others =>
+                  raise Program_Error;
+            end case;
 
             --  Generate:
             --    F := not Cancelled (Bnn);
@@ -2339,79 +2401,83 @@ package body Exp_Disp is
          --            A);
          --    end if;
 
-         Append_To (Stmts,
-           Make_If_Statement (Loc,
-             Condition =>
-               Make_Identifier (Loc, Name_uF),
-
-             Then_Statements =>
-               New_List (
-
-                  --  Call to Requeue_Protected_Entry
-
-                 Make_Procedure_Call_Statement (Loc,
-                   Name =>
-                     New_Reference_To (
-                       RTE (RE_Requeue_Protected_Entry), Loc),
-                   Parameter_Associations =>
-                     New_List (
-
-                       Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
-                         Subtype_Mark =>
-                           New_Reference_To (
-                             RTE (RE_Protection_Entries_Access), Loc),
-                         Expression =>
-                           Make_Identifier (Loc, Name_uP)),
-
-                       Make_Attribute_Reference (Loc,        -- O._object'Acc
-                         Attribute_Name =>
-                           Name_Unchecked_Access,
-                         Prefix =>
-                           Make_Selected_Component (Loc,
-                             Prefix =>
-                               Make_Identifier (Loc, Name_uO),
-                             Selector_Name =>
-                               Make_Identifier (Loc, Name_uObject))),
+         if Restriction_Active (No_Entry_Queue) then
+            Append_To (Stmts, Make_Null_Statement (Loc));
+         else
+            Append_To (Stmts,
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Identifier (Loc, Name_uF),
 
-                       Make_Unchecked_Type_Conversion (Loc,  -- entry index
-                         Subtype_Mark =>
-                           New_Reference_To (
-                             RTE (RE_Protected_Entry_Index), Loc),
-                         Expression =>
-                           Make_Identifier (Loc, Name_uI)),
+                Then_Statements =>
+                  New_List (
 
-                       Make_Identifier (Loc, Name_uA)))),    -- abort status
+                     --  Call to Requeue_Protected_Entry
 
-             Else_Statements =>
-               New_List (
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To (
+                          RTE (RE_Requeue_Protected_Entry), Loc),
+                      Parameter_Associations =>
+                        New_List (
+
+                          Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
+                            Subtype_Mark =>
+                              New_Reference_To (
+                                RTE (RE_Protection_Entries_Access), Loc),
+                            Expression =>
+                              Make_Identifier (Loc, Name_uP)),
+
+                          Make_Attribute_Reference (Loc,      -- O._object'Acc
+                            Attribute_Name =>
+                              Name_Unchecked_Access,
+                            Prefix =>
+                              Make_Selected_Component (Loc,
+                                Prefix =>
+                                  Make_Identifier (Loc, Name_uO),
+                                Selector_Name =>
+                                  Make_Identifier (Loc, Name_uObject))),
+
+                          Make_Unchecked_Type_Conversion (Loc,  -- entry index
+                            Subtype_Mark =>
+                              New_Reference_To (
+                                RTE (RE_Protected_Entry_Index), Loc),
+                            Expression =>
+                              Make_Identifier (Loc, Name_uI)),
 
-                  --  Call to Requeue_Task_To_Protected_Entry
+                          Make_Identifier (Loc, Name_uA)))),   -- abort status
 
-                 Make_Procedure_Call_Statement (Loc,
-                   Name =>
-                     New_Reference_To (
-                       RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
-                   Parameter_Associations =>
-                     New_List (
+                Else_Statements =>
+                  New_List (
 
-                       Make_Attribute_Reference (Loc,        -- O._object'Acc
-                         Attribute_Name =>
-                           Name_Unchecked_Access,
-                         Prefix =>
-                           Make_Selected_Component (Loc,
-                             Prefix =>
-                               Make_Identifier (Loc, Name_uO),
-                             Selector_Name =>
-                               Make_Identifier (Loc, Name_uObject))),
+                     --  Call to Requeue_Task_To_Protected_Entry
 
-                       Make_Unchecked_Type_Conversion (Loc,  -- entry index
-                         Subtype_Mark =>
-                           New_Reference_To (
-                             RTE (RE_Protected_Entry_Index), Loc),
-                         Expression =>
-                           Make_Identifier (Loc, Name_uI)),
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To (
+                          RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
+                      Parameter_Associations =>
+                        New_List (
+
+                          Make_Attribute_Reference (Loc,     -- O._object'Acc
+                            Attribute_Name =>
+                              Name_Unchecked_Access,
+                            Prefix =>
+                              Make_Selected_Component (Loc,
+                                Prefix =>
+                                  Make_Identifier (Loc, Name_uO),
+                                Selector_Name =>
+                                  Make_Identifier (Loc, Name_uObject))),
+
+                          Make_Unchecked_Type_Conversion (Loc, -- entry index
+                            Subtype_Mark =>
+                              New_Reference_To (
+                                RTE (RE_Protected_Entry_Index), Loc),
+                            Expression =>
+                              Make_Identifier (Loc, Name_uI)),
 
-                       Make_Identifier (Loc, Name_uA))))));  -- abort status
+                          Make_Identifier (Loc, Name_uA)))))); -- abort status
+         end if;
       else
          pragma Assert (Is_Task_Type (Conc_Typ));
 
@@ -2658,6 +2724,7 @@ package body Exp_Disp is
       Conc_Typ : Entity_Id           := Empty;
       Decls    : constant List_Id    := New_List;
       DT_Ptr   : Entity_Id;
+      Obj_Ref  : Node_Id;
       Stmts    : constant List_Id    := New_List;
 
    begin
@@ -2727,48 +2794,83 @@ package body Exp_Disp is
                        New_Reference_To (DT_Ptr, Loc)),
                      Make_Identifier (Loc, Name_uS)))));
 
+         --  Protected case
+
          if Ekind (Conc_Typ) = E_Protected_Type then
 
-            --  Generate:
-            --    Timed_Protected_Entry_Call (
-            --      T._object'access,
+            --  Build T._object'Access
+
+            Obj_Ref :=
+               Make_Attribute_Reference (Loc,
+                  Attribute_Name => Name_Unchecked_Access,
+                  Prefix         =>
+                    Make_Selected_Component (Loc,
+                      Prefix        => Make_Identifier (Loc, Name_uT),
+                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
+
+            --  Normal case, No_Entry_Queue restriction not active. In this
+            --  case we generate:
+
+            --   Timed_Protected_Entry_Call
+            --     (T._object'access,
             --      Protected_Entry_Index! (I),
-            --      P,
-            --      D,
-            --      M,
-            --      F);
+            --      P, D, M, F);
 
             --  where T is the protected object, I is the entry index, P are
             --  the wrapped parameters, D is the delay amount, M is the delay
             --  mode and F is the status flag.
 
-            Append_To (Stmts,
-              Make_Procedure_Call_Statement (Loc,
-                Name =>
-                  New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
-                Parameter_Associations =>
-                  New_List (
+            case Corresponding_Runtime_Package (Conc_Typ) is
+               when System_Tasking_Protected_Objects_Entries =>
+                  Append_To (Stmts,
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To
+                          (RTE (RE_Timed_Protected_Entry_Call), Loc),
+                      Parameter_Associations =>
+                        New_List (
+                          Obj_Ref,
+
+                          Make_Unchecked_Type_Conversion (Loc,  --  entry index
+                            Subtype_Mark =>
+                              New_Reference_To
+                                (RTE (RE_Protected_Entry_Index), Loc),
+                            Expression =>
+                              Make_Identifier (Loc, Name_uI)),
 
-                    Make_Attribute_Reference (Loc,        -- T._object'access
-                      Attribute_Name =>
-                        Name_Unchecked_Access,
-                      Prefix =>
-                        Make_Selected_Component (Loc,
-                          Prefix =>
-                            Make_Identifier (Loc, Name_uT),
-                          Selector_Name =>
-                            Make_Identifier (Loc, Name_uObject))),
+                          Make_Identifier (Loc, Name_uP),   --  parameter block
+                          Make_Identifier (Loc, Name_uD),   --  delay
+                          Make_Identifier (Loc, Name_uM),   --  delay mode
+                          Make_Identifier (Loc, Name_uF)))); --  status flag
 
-                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
-                      Subtype_Mark =>
-                        New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
-                      Expression =>
-                        Make_Identifier (Loc, Name_uI)),
+               when System_Tasking_Protected_Objects_Single_Entry =>
+                  --  Generate:
 
-                    Make_Identifier (Loc, Name_uP),       --  parameter block
-                    Make_Identifier (Loc, Name_uD),       --  delay
-                    Make_Identifier (Loc, Name_uM),       --  delay mode
-                    Make_Identifier (Loc, Name_uF))));    --  status flag
+                  --   Timed_Protected_Single_Entry_Call
+                  --     (T._object'access, P, D, M, F);
+
+                  --  where T is the protected object, P is the wrapped
+                  --  parameters, D is the delay amount, M is the delay mode, F
+                  --  is the status flag.
+
+                  Append_To (Stmts,
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To
+                          (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
+                      Parameter_Associations =>
+                        New_List (
+                          Obj_Ref,
+                          Make_Identifier (Loc, Name_uP),   --  parameter block
+                          Make_Identifier (Loc, Name_uD),   --  delay
+                          Make_Identifier (Loc, Name_uM),   --  delay mode
+                          Make_Identifier (Loc, Name_uF)))); --  status flag
+
+               when others =>
+                  raise Program_Error;
+            end case;
+
+         --  Task case
 
          else
             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
@@ -2957,12 +3059,13 @@ package body Exp_Disp is
       --  generate forward references and statically allocate the table.
 
       procedure Make_Secondary_DT
-        (Typ             : Entity_Id;
-         Iface           : Entity_Id;
-         Num_Iface_Prims : Nat;
-         Iface_DT_Ptr    : Entity_Id;
-         Build_Thunks    : Boolean;
-         Result          : List_Id);
+        (Typ              : Entity_Id;
+         Iface            : Entity_Id;
+         Num_Iface_Prims  : Nat;
+         Iface_DT_Ptr     : Entity_Id;
+         Predef_Prims_Ptr : Entity_Id;
+         Build_Thunks     : Boolean;
+         Result           : List_Id);
       --  Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
       --  Table of Typ associated with Iface. Each abstract interface of Typ
       --  has two secondary dispatch tables: one containing pointers to thunks
@@ -3024,12 +3127,13 @@ package body Exp_Disp is
       -----------------------
 
       procedure Make_Secondary_DT
-        (Typ             : Entity_Id;
-         Iface           : Entity_Id;
-         Num_Iface_Prims : Nat;
-         Iface_DT_Ptr    : Entity_Id;
-         Build_Thunks    : Boolean;
-         Result          : List_Id)
+        (Typ              : Entity_Id;
+         Iface            : Entity_Id;
+         Num_Iface_Prims  : Nat;
+         Iface_DT_Ptr     : Entity_Id;
+         Predef_Prims_Ptr : Entity_Id;
+         Build_Thunks     : Boolean;
+         Result           : List_Id)
       is
          Loc                : constant Source_Ptr := Sloc (Typ);
          Name_DT            : constant Name_Id := New_Internal_Name ('T');
@@ -3168,9 +3272,10 @@ package body Exp_Disp is
             for J in Prim_Table'Range loop
                if Present (Prim_Table (J)) then
                   New_Node :=
-                    Make_Attribute_Reference (Loc,
-                      Prefix => New_Reference_To (Prim_Table (J), Loc),
-                      Attribute_Name => Name_Address);
+                    Unchecked_Convert_To (RTE (RE_Address),
+                      Make_Attribute_Reference (Loc,
+                        Prefix => New_Reference_To (Prim_Table (J), Loc),
+                        Attribute_Name => Name_Unrestricted_Access));
                else
                   New_Node :=
                     New_Reference_To (RTE (RE_Null_Address), Loc);
@@ -3451,9 +3556,10 @@ package body Exp_Disp is
                for J in Prim_Table'Range loop
                   if Present (Prim_Table (J)) then
                      New_Node :=
-                       Make_Attribute_Reference (Loc,
-                         Prefix => New_Reference_To (Prim_Table (J), Loc),
-                         Attribute_Name => Name_Address);
+                       Unchecked_Convert_To (RTE (RE_Address),
+                         Make_Attribute_Reference (Loc,
+                           Prefix => New_Reference_To (Prim_Table (J), Loc),
+                           Attribute_Name => Name_Unrestricted_Access));
                   else
                      New_Node :=
                        New_Reference_To (RTE (RE_Null_Address), Loc);
@@ -3513,6 +3619,30 @@ package body Exp_Disp is
                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
                    Attribute_Name => Name_Address))));
 
+         Append_To (Result,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Predef_Prims_Ptr,
+             Constant_Present    => True,
+             Object_Definition =>
+               New_Reference_To (RTE (RE_Address), Loc),
+             Expression =>
+               Make_Attribute_Reference (Loc,
+                 Prefix =>
+                   Make_Selected_Component (Loc,
+                     Prefix => New_Reference_To (Iface_DT, Loc),
+                   Selector_Name =>
+                     New_Occurrence_Of
+                       (RTE_Record_Component (RE_Predef_Prims), Loc)),
+                 Attribute_Name => Name_Address)));
+
+         --  Mark entities containing library level static dispatch tables.
+         --  This attribute is later propagated to all the access-to-subprogram
+         --  itypes generated to fill the dispatch table slots (see exp_attr).
+
+         if Building_Static_DT (Typ) then
+            Set_Is_Static_Dispatch_Table_Entity (Predef_Prims);
+            Set_Is_Static_Dispatch_Table_Entity (Iface_DT);
+         end if;
       end Make_Secondary_DT;
 
       --  Local variables
@@ -3535,10 +3665,7 @@ package body Exp_Disp is
       Nb_Prim            : Nat := 0;
       New_Node           : Node_Id;
       No_Reg             : Node_Id;
-      Null_Parent_Tag    : Boolean := False;
       Num_Ifaces         : Nat := 0;
-      Old_Tag1           : Node_Id;
-      Old_Tag2           : Node_Id;
       Prim               : Entity_Id;
       Prim_Elmt          : Elmt_Id;
       Prim_Ops_Aggr_List : List_Id;
@@ -3686,7 +3813,8 @@ package body Exp_Disp is
          Collect_Interface_Components (Typ, Typ_Comps);
 
          Suffix_Index := 0;
-         AI_Tag_Elmt  := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+         AI_Tag_Elmt  :=
+           Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
 
          AI_Tag_Comp := First_Elmt (Typ_Comps);
          while Present (AI_Tag_Comp) loop
@@ -3699,10 +3827,15 @@ package body Exp_Disp is
               Num_Iface_Prims => UI_To_Int
                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
+              Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
               Build_Thunks    => True,
               Result          => Result);
             Next_Elmt (AI_Tag_Elmt);
 
+            --  Skip the secondary dispatch table of predefined primitives
+
+            Next_Elmt (AI_Tag_Elmt);
+
             --  Build the secondary table containing pointers to primitives
             --  (used to give support to Generic Dispatching Constructors).
 
@@ -3712,10 +3845,15 @@ package body Exp_Disp is
               Num_Iface_Prims =>  UI_To_Int
                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
+              Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
               Build_Thunks    => False,
               Result          => Result);
             Next_Elmt (AI_Tag_Elmt);
 
+            --  Skip the secondary dispatch table of predefined primitives
+
+            Next_Elmt (AI_Tag_Elmt);
+
             Suffix_Index := Suffix_Index + 1;
             Next_Elmt (AI_Tag_Comp);
          end loop;
@@ -3850,6 +3988,23 @@ package body Exp_Disp is
                           New_Occurrence_Of
                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
                       Attribute_Name => Name_Address))));
+
+            Append_To (Result,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier =>
+                  Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
+                Constant_Present    => True,
+                Object_Definition   => New_Reference_To
+                                            (RTE (RE_Address), Loc),
+                Expression =>
+                  Make_Attribute_Reference (Loc,
+                    Prefix =>
+                      Make_Selected_Component (Loc,
+                        Prefix => New_Reference_To (DT, Loc),
+                      Selector_Name =>
+                        New_Occurrence_Of
+                          (RTE_Record_Component (RE_Predef_Prims), Loc)),
+                    Attribute_Name => Name_Address)));
          end if;
       end if;
 
@@ -4245,7 +4400,9 @@ package body Exp_Disp is
                      Sec_DT_Tag :=
                        New_Reference_To (DT_Ptr, Loc);
                   else
-                     Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+                     Elmt :=
+                       Next_Elmt
+                        (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
                      pragma Assert (Has_Thunks (Node (Elmt)));
 
                      while Ekind (Node (Elmt)) = E_Constant
@@ -4254,14 +4411,20 @@ package body Exp_Disp is
                      loop
                         pragma Assert (Has_Thunks (Node (Elmt)));
                         Next_Elmt (Elmt);
+                        pragma Assert (Has_Thunks (Node (Elmt)));
+                        Next_Elmt (Elmt);
+                        pragma Assert (not Has_Thunks (Node (Elmt)));
+                        Next_Elmt (Elmt);
                         pragma Assert (not Has_Thunks (Node (Elmt)));
                         Next_Elmt (Elmt);
                      end loop;
 
                      pragma Assert (Ekind (Node (Elmt)) = E_Constant
-                       and then not Has_Thunks (Node (Next_Elmt (Elmt))));
+                       and then not
+                         Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
                      Sec_DT_Tag :=
-                       New_Reference_To (Node (Next_Elmt (Elmt)), Loc);
+                       New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
+                                         Loc);
                   end if;
 
                   Append_To (TSD_Ifaces_List,
@@ -4645,9 +4808,10 @@ package body Exp_Disp is
                for J in Prim_Table'Range loop
                   if Present (Prim_Table (J)) then
                      New_Node :=
-                       Make_Attribute_Reference (Loc,
-                         Prefix => New_Reference_To (Prim_Table (J), Loc),
-                         Attribute_Name => Name_Address);
+                       Unchecked_Convert_To (RTE (RE_Address),
+                         Make_Attribute_Reference (Loc,
+                           Prefix => New_Reference_To (Prim_Table (J), Loc),
+                           Attribute_Name => Name_Unrestricted_Access));
                   else
                      New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
                   end if;
@@ -4787,9 +4951,10 @@ package body Exp_Disp is
                for J in Prim_Table'Range loop
                   if Present (Prim_Table (J)) then
                      New_Node :=
-                       Make_Attribute_Reference (Loc,
-                         Prefix => New_Reference_To (Prim_Table (J), Loc),
-                         Attribute_Name => Name_Address);
+                       Unchecked_Convert_To (RTE (RE_Address),
+                         Make_Attribute_Reference (Loc,
+                           Prefix => New_Reference_To (Prim_Table (J), Loc),
+                           Attribute_Name => Name_Unrestricted_Access));
                   else
                      New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
                   end if;
@@ -4871,6 +5036,12 @@ package body Exp_Disp is
                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
       end if;
 
+      --  Inherit the dispatch tables of the parent
+
+      --  There is no need to inherit anything from the parent when building
+      --  static dispatch tables because the whole dispatch table (including
+      --  inherited primitives) has been already built.
+
       if Building_Static_DT (Typ) then
          null;
 
@@ -4880,60 +5051,52 @@ package body Exp_Disp is
       elsif Is_CPP_Class (Etype (Typ)) then
          null;
 
-         --  Otherwise we fill in the dispatch tables here
+      --  Otherwise we fill in the dispatch tables here
 
       else
-         if Typ = Etype (Typ)
-           or else Is_CPP_Class (Etype (Typ))
-           or else Is_Interface (Typ)
-         then
-            Null_Parent_Tag := True;
-
-            Old_Tag1 :=
-              Unchecked_Convert_To (RTE (RE_Tag),
-                Make_Integer_Literal (Loc, 0));
-            Old_Tag2 :=
-              Unchecked_Convert_To (RTE (RE_Tag),
-                Make_Integer_Literal (Loc, 0));
-
-         else
-            Old_Tag1 :=
-              New_Reference_To
-                (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
-            Old_Tag2 :=
-              New_Reference_To
-                (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
-         end if;
-
          if Typ /= Etype (Typ)
            and then not Is_Interface (Typ)
            and then not Restriction_Active (No_Dispatching_Calls)
          then
             --  Inherit the dispatch table
 
-            if not Is_Interface (Etype (Typ)) then
-               if not Null_Parent_Tag then
-                  declare
-                     Nb_Prims : constant Int :=
-                                  UI_To_Int (DT_Entry_Count
-                                    (First_Tag_Component (Etype (Typ))));
-                  begin
+            if not Is_Interface (Typ)
+              and then not Is_Interface (Etype (Typ))
+              and then not Is_CPP_Class (Etype (Typ))
+            then
+               declare
+                  Nb_Prims : constant Int :=
+                               UI_To_Int (DT_Entry_Count
+                                 (First_Tag_Component (Etype (Typ))));
+               begin
+                  Append_To (Elab_Code,
+                    Build_Inherit_Predefined_Prims (Loc,
+                      Old_Tag_Node =>
+                        New_Reference_To
+                          (Node
+                           (Next_Elmt
+                            (First_Elmt
+                             (Access_Disp_Table (Etype (Typ))))), Loc),
+                      New_Tag_Node =>
+                        New_Reference_To
+                          (Node
+                           (Next_Elmt
+                            (First_Elmt
+                             (Access_Disp_Table (Typ)))), Loc)));
+
+                  if Nb_Prims /= 0 then
                      Append_To (Elab_Code,
-                       Build_Inherit_Predefined_Prims (Loc,
-                         Old_Tag_Node => Old_Tag1,
-                         New_Tag_Node =>
-                           New_Reference_To (DT_Ptr, Loc)));
-
-                     if Nb_Prims /= 0 then
-                        Append_To (Elab_Code,
-                          Build_Inherit_Prims (Loc,
-                            Typ          => Typ,
-                            Old_Tag_Node => Old_Tag2,
-                            New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
-                            Num_Prims    => Nb_Prims));
-                     end if;
-                  end;
-               end if;
+                       Build_Inherit_Prims (Loc,
+                         Typ          => Typ,
+                         Old_Tag_Node =>
+                           New_Reference_To
+                             (Node
+                              (First_Elmt
+                               (Access_Disp_Table (Etype (Typ)))), Loc),
+                         New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
+                         Num_Prims    => Nb_Prims));
+                  end if;
+               end;
             end if;
 
             --  Inherit the secondary dispatch tables of the ancestor
@@ -4942,12 +5105,14 @@ package body Exp_Disp is
                declare
                   Sec_DT_Ancestor : Elmt_Id :=
                                       Next_Elmt
+                                       (Next_Elmt
                                         (First_Elmt
-                                           (Access_Disp_Table (Etype (Typ))));
+                                          (Access_Disp_Table (Etype (Typ)))));
                   Sec_DT_Typ      : Elmt_Id :=
                                       Next_Elmt
-                                        (First_Elmt
-                                           (Access_Disp_Table (Typ)));
+                                       (Next_Elmt
+                                         (First_Elmt
+                                           (Access_Disp_Table (Typ))));
 
                   procedure Copy_Secondary_DTs (Typ : Entity_Id);
                   --  Local procedure required to climb through the ancestors
@@ -4998,12 +5163,15 @@ package body Exp_Disp is
                                       Build_Inherit_Predefined_Prims (Loc,
                                         Old_Tag_Node =>
                                           Unchecked_Convert_To (RTE (RE_Tag),
-                                             New_Reference_To
-                                               (Node (Sec_DT_Ancestor), Loc)),
+                                            New_Reference_To
+                                              (Node
+                                                (Next_Elmt (Sec_DT_Ancestor)),
+                                               Loc)),
                                         New_Tag_Node =>
                                           Unchecked_Convert_To (RTE (RE_Tag),
                                             New_Reference_To
-                                              (Node (Sec_DT_Typ), Loc))));
+                                              (Node (Next_Elmt (Sec_DT_Typ)),
+                                               Loc))));
 
                                     if Num_Prims /= 0 then
                                        Append_To (Elab_Code,
@@ -5027,6 +5195,12 @@ package body Exp_Disp is
                                  Next_Elmt (Sec_DT_Ancestor);
                                  Next_Elmt (Sec_DT_Typ);
 
+                                 --  Skip the secondary dispatch table of
+                                 --  predefined primitives
+
+                                 Next_Elmt (Sec_DT_Ancestor);
+                                 Next_Elmt (Sec_DT_Typ);
+
                                  if not Is_Interface (Etype (Typ)) then
 
                                     --  Inherit second secondary dispatch table
@@ -5036,11 +5210,14 @@ package body Exp_Disp is
                                         Old_Tag_Node =>
                                           Unchecked_Convert_To (RTE (RE_Tag),
                                              New_Reference_To
-                                               (Node (Sec_DT_Ancestor), Loc)),
+                                               (Node
+                                                 (Next_Elmt (Sec_DT_Ancestor)),
+                                                Loc)),
                                         New_Tag_Node =>
                                           Unchecked_Convert_To (RTE (RE_Tag),
                                             New_Reference_To
-                                              (Node (Sec_DT_Typ), Loc))));
+                                              (Node (Next_Elmt (Sec_DT_Typ)),
+                                               Loc))));
 
                                     if Num_Prims /= 0 then
                                        Append_To (Elab_Code,
@@ -5064,6 +5241,13 @@ package body Exp_Disp is
 
                               Next_Elmt (Sec_DT_Ancestor);
                               Next_Elmt (Sec_DT_Typ);
+
+                              --  Skip the secondary dispatch table of
+                              --  predefined primitives
+
+                              Next_Elmt (Sec_DT_Ancestor);
+                              Next_Elmt (Sec_DT_Typ);
+
                               Next_Elmt (Iface);
                            end if;
 
@@ -5143,6 +5327,15 @@ package body Exp_Disp is
            Make_Select_Specific_Data_Table (Typ));
       end if;
 
+      --  Mark entities containing library level static dispatch tables. This
+      --  attribute is later propagated to all the access-to-subprogram itypes
+      --  generated to fill the dispatch table slots (see exp_attr).
+
+      if Building_Static_DT (Typ) then
+         Set_Is_Static_Dispatch_Table_Entity (Predef_Prims);
+         Set_Is_Static_Dispatch_Table_Entity (DT);
+      end if;
+
       Analyze_List (Result, Suppress => All_Checks);
       Set_Has_Dispatch_Table (Typ);
 
@@ -5312,18 +5505,19 @@ package body Exp_Disp is
    ---------------
 
    function Make_Tags (Typ : Entity_Id) return List_Id is
-      Loc             : constant Source_Ptr := Sloc (Typ);
-      Tname           : constant Name_Id := Chars (Typ);
-      Result          : constant List_Id := New_List;
-      AI_Tag_Comp     : Elmt_Id;
-      DT              : Node_Id;
-      DT_Constr_List  : List_Id;
-      DT_Ptr          : Node_Id;
-      Iface_DT_Ptr    : Node_Id;
-      Nb_Prim         : Nat;
-      Suffix_Index    : Int;
-      Typ_Name        : Name_Id;
-      Typ_Comps       : Elist_Id;
+      Loc              : constant Source_Ptr := Sloc (Typ);
+      Tname            : constant Name_Id := Chars (Typ);
+      Result           : constant List_Id := New_List;
+      AI_Tag_Comp      : Elmt_Id;
+      DT               : Node_Id;
+      DT_Constr_List   : List_Id;
+      DT_Ptr           : Node_Id;
+      Predef_Prims_Ptr : Node_Id;
+      Iface_DT_Ptr     : Node_Id;
+      Nb_Prim          : Nat;
+      Suffix_Index     : Int;
+      Typ_Name         : Name_Id;
+      Typ_Comps        : Elist_Id;
 
    begin
       --  1) Generate the primary and secondary tag entities
@@ -5334,18 +5528,28 @@ package body Exp_Disp is
          Collect_Interface_Components (Typ, Typ_Comps);
       end if;
 
-      --  1) Generate the primary tag entity
+      --  1) Generate the primary tag entities
+
+      --  Primary dispatch table containing user-defined primitives
 
       DT_Ptr := Make_Defining_Identifier (Loc,
                   New_External_Name (Tname, 'P'));
       Set_Etype (DT_Ptr, RTE (RE_Tag));
 
+      --  Primary dispatch table containing predefined primitives
+
+      Predef_Prims_Ptr :=
+        Make_Defining_Identifier (Loc,
+          Chars => New_External_Name (Tname, 'Y'));
+      Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
+
       --  Import the forward declaration of the Dispatch Table wrapper record
       --  (Make_DT will take care of its exportation)
 
       if Building_Static_DT (Typ) then
-         DT := Make_Defining_Identifier (Loc,
-                 New_External_Name (Tname, 'T'));
+         DT :=
+           Make_Defining_Identifier (Loc,
+             Chars => New_External_Name (Tname, 'T'));
 
          --  Generate:
          --    DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
@@ -5371,6 +5575,7 @@ package body Exp_Disp is
          Set_Dispatch_Table_Wrapper (Typ, DT);
 
          if Has_DT (Typ) then
+
             --  Calculate the number of primitives of the dispatch table and
             --  the size of the Type_Specific_Data record.
 
@@ -5415,6 +5620,22 @@ package body Exp_Disp is
                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
                       Attribute_Name => Name_Address))));
 
+            Append_To (Result,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => Predef_Prims_Ptr,
+                Constant_Present    => True,
+                Object_Definition   => New_Reference_To
+                                            (RTE (RE_Address), Loc),
+                Expression =>
+                  Make_Attribute_Reference (Loc,
+                    Prefix =>
+                      Make_Selected_Component (Loc,
+                        Prefix => New_Reference_To (DT, Loc),
+                      Selector_Name =>
+                        New_Occurrence_Of
+                          (RTE_Record_Component (RE_Predef_Prims), Loc)),
+                    Attribute_Name => Name_Address)));
+
          --  No dispatch table required
 
          else
@@ -5450,6 +5671,7 @@ package body Exp_Disp is
       pragma Assert (No (Access_Disp_Table (Typ)));
       Set_Access_Disp_Table (Typ, New_Elmt_List);
       Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
+      Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
 
       --  2) Generate the secondary tag entities
 
@@ -5471,6 +5693,9 @@ package body Exp_Disp is
 
             Typ_Name := Name_Find;
 
+            --  Secondary dispatch table referencing thunks to user-defined
+            --  primitives covered by this interface.
+
             Iface_DT_Ptr :=
               Make_Defining_Identifier (Loc,
                 Chars => New_External_Name (Typ_Name, 'P'));
@@ -5484,6 +5709,25 @@ package body Exp_Disp is
               (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
             Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
 
+            --  Secondary dispatch table referencing thunks to predefined
+            --  primitives.
+
+            Iface_DT_Ptr :=
+              Make_Defining_Identifier (Loc,
+                Chars => New_External_Name (Typ_Name, 'Y'));
+            Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+            Set_Ekind (Iface_DT_Ptr, E_Constant);
+            Set_Is_Tag (Iface_DT_Ptr);
+            Set_Has_Thunks (Iface_DT_Ptr);
+            Set_Is_Statically_Allocated (Iface_DT_Ptr);
+            Set_Is_True_Constant (Iface_DT_Ptr);
+            Set_Related_Type
+              (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+            Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+            --  Secondary dispatch table referencing user-defined primitives
+            --  covered by this interface.
+
             Iface_DT_Ptr :=
               Make_Defining_Identifier (Loc,
                 Chars => New_External_Name (Typ_Name, 'D'));
@@ -5496,6 +5740,20 @@ package body Exp_Disp is
               (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
             Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
 
+            --  Secondary dispatch table referencing predefined primitives
+
+            Iface_DT_Ptr :=
+              Make_Defining_Identifier (Loc,
+                Chars => New_External_Name (Typ_Name, 'Z'));
+            Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+            Set_Ekind (Iface_DT_Ptr, E_Constant);
+            Set_Is_Tag (Iface_DT_Ptr);
+            Set_Is_Statically_Allocated (Iface_DT_Ptr);
+            Set_Is_True_Constant (Iface_DT_Ptr);
+            Set_Related_Type
+              (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+            Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
             Next_Elmt (AI_Tag_Comp);
          end loop;
       end if;
@@ -5703,33 +5961,38 @@ package body Exp_Disp is
       end if;
 
       if not Present (Abstract_Interface_Alias (Prim)) then
-         Typ          := Scope (DTC_Entity (Prim));
-         DT_Ptr       := Node (First_Elmt (Access_Disp_Table (Typ)));
-         Pos          := DT_Position (Prim);
-         Tag          := First_Tag_Component (Typ);
+         Typ := Scope (DTC_Entity (Prim));
+         Pos := DT_Position (Prim);
+         Tag := First_Tag_Component (Typ);
 
          if Is_Predefined_Dispatching_Operation (Prim)
            or else Is_Predefined_Dispatching_Alias (Prim)
          then
+            DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
             Insert_After (Ins_Nod,
               Build_Set_Predefined_Prim_Op_Address (Loc,
                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
                 Position     => Pos,
-                Address_Node => Make_Attribute_Reference (Loc,
-                                   Prefix => New_Reference_To (Prim, Loc),
-                                   Attribute_Name => Name_Address)));
+                Address_Node =>
+                  Unchecked_Convert_To (RTE (RE_Address),
+                    Make_Attribute_Reference (Loc,
+                      Prefix => New_Reference_To (Prim, Loc),
+                      Attribute_Name => Name_Unrestricted_Access))));
 
          else
             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
 
+            DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
             Insert_After (Ins_Nod,
               Build_Set_Prim_Op_Address (Loc,
                 Typ          => Typ,
                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
                 Position     => Pos,
-                Address_Node => Make_Attribute_Reference (Loc,
-                                  Prefix => New_Reference_To (Prim, Loc),
-                                  Attribute_Name => Name_Address)));
+                Address_Node =>
+                  Unchecked_Convert_To (RTE (RE_Address),
+                    Make_Attribute_Reference (Loc,
+                      Prefix => New_Reference_To (Prim, Loc),
+                      Attribute_Name => Name_Unrestricted_Access))));
          end if;
 
       --  Ada 2005 (AI-251): Primitive associated with an interface type
@@ -5763,35 +6026,40 @@ package body Exp_Disp is
             Iface_DT_Ptr  := Node (Iface_DT_Elmt);
             pragma Assert (Has_Thunks (Iface_DT_Ptr));
 
-            Iface_Prim    := Abstract_Interface_Alias (Prim);
-            Pos           := DT_Position (Iface_Prim);
-            Tag           := First_Tag_Component (Iface_Typ);
-            L             := New_List;
+            Iface_Prim := Abstract_Interface_Alias (Prim);
+            Pos        := DT_Position (Iface_Prim);
+            Tag        := First_Tag_Component (Iface_Typ);
+            L          := New_List;
 
             if Is_Predefined_Dispatching_Operation (Prim)
               or else Is_Predefined_Dispatching_Alias (Prim)
             then
                Append_To (L,
                  Build_Set_Predefined_Prim_Op_Address (Loc,
-                   Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
+                   Tag_Node =>
+                     New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
                    Position => Pos,
                    Address_Node =>
-                     Make_Attribute_Reference (Loc,
-                       Prefix          => New_Reference_To (Thunk_Id, Loc),
-                       Attribute_Name  => Name_Address)));
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Make_Attribute_Reference (Loc,
+                         Prefix          => New_Reference_To (Thunk_Id, Loc),
+                         Attribute_Name  => Name_Unrestricted_Access))));
 
+               Next_Elmt (Iface_DT_Elmt);
                Next_Elmt (Iface_DT_Elmt);
                Iface_DT_Ptr := Node (Iface_DT_Elmt);
                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
 
                Append_To (L,
                  Build_Set_Predefined_Prim_Op_Address (Loc,
-                   Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
+                   Tag_Node =>
+                     New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
                    Position => Pos,
                    Address_Node =>
-                     Make_Attribute_Reference (Loc,
-                       Prefix          => New_Reference_To (Alias (Prim), Loc),
-                       Attribute_Name  => Name_Address)));
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Make_Attribute_Reference (Loc,
+                         Prefix => New_Reference_To (Alias (Prim), Loc),
+                         Attribute_Name  => Name_Unrestricted_Access))));
 
                Insert_Actions_After (Ins_Nod, L);
 
@@ -5804,11 +6072,13 @@ package body Exp_Disp is
                    Typ          => Iface_Typ,
                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
                    Position     => Pos,
-                   Address_Node => Make_Attribute_Reference (Loc,
-                                     Prefix =>
-                                       New_Reference_To (Thunk_Id, Loc),
-                                     Attribute_Name => Name_Address)));
+                   Address_Node =>
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Make_Attribute_Reference (Loc,
+                         Prefix => New_Reference_To (Thunk_Id, Loc),
+                         Attribute_Name => Name_Unrestricted_Access))));
 
+               Next_Elmt (Iface_DT_Elmt);
                Next_Elmt (Iface_DT_Elmt);
                Iface_DT_Ptr := Node (Iface_DT_Elmt);
                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
@@ -5818,10 +6088,11 @@ package body Exp_Disp is
                    Typ          => Iface_Typ,
                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
                    Position     => Pos,
-                   Address_Node => Make_Attribute_Reference (Loc,
-                                     Prefix =>
-                                       New_Reference_To (Alias (Prim), Loc),
-                                     Attribute_Name => Name_Address)));
+                   Address_Node =>
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Make_Attribute_Reference (Loc,
+                         Prefix => New_Reference_To (Alias (Prim), Loc),
+                         Attribute_Name => Name_Unrestricted_Access))));
 
                Insert_Actions_After (Ins_Nod, L);
             end if;
@@ -5980,8 +6251,9 @@ package body Exp_Disp is
       end loop;
 
       declare
-         Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
-                        := (others => False);
+         Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
+                        (others => False);
+
          E : Entity_Id;
 
          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
@@ -6231,7 +6503,7 @@ package body Exp_Disp is
          Prim := Node (Prim_Elmt);
 
          --  At this point all the primitives MUST have a position
-         --  in the dispatch table
+         --  in the dispatch table.
 
          if DT_Position (Prim) = No_Uint then
             raise Program_Error;
@@ -6322,8 +6594,7 @@ package body Exp_Disp is
       Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
 
       --  The derived type must have at least as many components as its parent
-      --  (for root types, the Etype points back to itself and the test cannot
-      --   fail)
+      --  (for root types Etype points to itself and the test cannot fail).
 
       if DT_Entry_Count (The_Tag) <
            DT_Entry_Count (First_Tag_Component (Parent_Typ))

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index f3b9ee2f199b30530de17fd69c0d522869f2012b..28f6d6e0d9fcb538f2d759988730c1761e9cb7a4 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
@@ -948,6 +948,43 @@ package body Exp_Util is
       end if;
    end Component_May_Be_Bit_Aligned;
 
+   -----------------------------------
+   -- Corresponding_Runtime_Package --
+   -----------------------------------
+
+   function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
+      Pkg_Id : RTU_Id := RTU_Null;
+
+   begin
+      pragma Assert (Is_Concurrent_Type (Typ));
+
+      if Ekind (Typ) in Protected_Kind then
+         if Has_Entries (Typ)
+           or else Has_Interrupt_Handler (Typ)
+           or else (Has_Attach_Handler (Typ)
+                     and then not Restricted_Profile)
+           or else (Ada_Version >= Ada_05
+                     and then Present (Interface_List (Parent (Typ))))
+         then
+            if Abort_Allowed
+              or else Restriction_Active (No_Entry_Queue) = False
+              or else Number_Entries (Typ) > 1
+              or else (Has_Attach_Handler (Typ)
+                         and then not Restricted_Profile)
+            then
+               Pkg_Id := System_Tasking_Protected_Objects_Entries;
+            else
+               Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
+            end if;
+
+         else
+            Pkg_Id := System_Tasking_Protected_Objects;
+         end if;
+      end if;
+
+      return Pkg_Id;
+   end Corresponding_Runtime_Package;
+
    -------------------------------
    -- Convert_To_Actual_Subtype --
    -------------------------------
@@ -1384,6 +1421,10 @@ package body Exp_Util is
                   return;
                end if;
 
+               --  Document what is going on here, why four Next's???
+
+               Next_Elmt (ADT);
+               Next_Elmt (ADT);
                Next_Elmt (ADT);
                Next_Elmt (ADT);
                Next_Elmt (AI_Elmt);
@@ -1420,7 +1461,7 @@ package body Exp_Util is
         (not Is_Class_Wide_Type (Typ)
           and then Ekind (Typ) /= E_Incomplete_Type);
 
-      ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+      ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
       pragma Assert (Present (Node (ADT)));
       Find_Secondary_Table (Typ);
       pragma Assert (Found);

diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 42c8d2ab8f35683cb23161cdb95b5d136b692965..737b39728ee4992795805739158a8c2b9e55f38f 100644 (file)
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
@@ -212,43 +212,51 @@ package Exp_Util is
    --  function itself must do its own cleanups.
 
    function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean;
-   --  This function is in charge of detecting record components that may cause
-   --  trouble in the back end if an attempt is made to assign the component.
-   --  The back end can handle such assignments with no problem if the
-   --  components involved are small (64-bits or less) records or scalar items
-   --  (including bit-packed arrays represented with modular types) or are both
-   --  aligned on a byte boundary (starting on a byte boundary, and occupying
-   --  an integral number of bytes).
+   --  This function is in charge of detecting record components that may
+   --  cause trouble in the back end if an attempt is made to assign the
+   --  component. The back end can handle such assignments with no problem if
+   --  the components involved are small (64-bits or less) records or scalar
+   --  items (including bit-packed arrays represented with modular types) or
+   --  are both aligned on a byte boundary (starting on a byte boundary, and
+   --  occupying an integral number of bytes).
    --
    --  However, problems arise for records larger than 64 bits, or for arrays
    --  (other than bit-packed arrays represented with a modular type) if the
    --  component starts on a non-byte boundary, or does not occupy an integral
-   --  number of bytes (i.e. there are some bits possibly shared with fields at
-   --  the start or beginning of the component). The back end cannot handle
+   --  number of bytes (i.e. there are some bits possibly shared with fields
+   --  at the start or beginning of the component). The back end cannot handle
    --  loading and storing such components in a single operation.
    --
    --  This function is used to detect the troublesome situation. it is
-   --  conservative in the sense that it produces True unless it knows for sure
-   --  that the component is safe (as outlined in the first paragraph above).
-   --  The code generation for record and array assignment checks for trouble
-   --  using this function, and if so the assignment is generated
+   --  conservative in the sense that it produces True unless it knows for
+   --  sure that the component is safe (as outlined in the first paragraph
+   --  above). The code generation for record and array assignment checks for
+   --  trouble using this function, and if so the assignment is generated
    --  component-wise, which the back end is required to handle correctly.
    --
-   --  Note that in GNAT 3, the back end will reject such components anyway, so
-   --  the hard work in checking for this case is wasted in GNAT 3, but it's
-   --  harmless, so it is easier to do it in all cases, rather than
+   --  Note that in GNAT 3, the back end will reject such components anyway,
+   --  so the hard work in checking for this case is wasted in GNAT 3, but
+   --  it is harmless, so it is easier to do it in all cases, rather than
    --  conditionalize it in GNAT 5 or beyond.
 
    procedure Convert_To_Actual_Subtype (Exp : Node_Id);
-   --  The Etype of an expression is the nominal type of the expression, not
-   --  the actual subtype. Often these are the same, but not always. For
-   --  example, a reference to a formal of unconstrained type has the
+   --  The Etype of an expression is the nominal type of the expression,
+   --  not the actual subtype. Often these are the same, but not always.
+   --  For example, a reference to a formal of unconstrained type has the
    --  unconstrained type as its Etype, but the actual subtype is obtained by
    --  applying the actual bounds. This routine is given an expression, Exp,
-   --  and (if necessary), replaces it using Rewrite, with a conversion to the
-   --  actual subtype, building the actual subtype if necessary. If the
+   --  and (if necessary), replaces it using Rewrite, with a conversion to
+   --  the actual subtype, building the actual subtype if necessary. If the
    --  expression is already of the requested type, then it is unchanged.
 
+   function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id;
+   --  Return the id of the runtime package that will provide support for
+   --  concurrent type Typ. Currently only protected types are supported,
+   --  and the returned value is one of the following:
+   --    System_Tasking_Protected_Objects
+   --    System_Tasking_Protected_Objects_Entries
+   --    System_Tasking_Protected_Objects_Single_Entry
+
    function Current_Sem_Unit_Declarations return List_Id;
    --  Return the a place where it is fine to insert declarations for the
    --  current semantic unit. If the unit is a package body, return the

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 344122a0df040ce210a29ab79be749847ee78b56..c36805838e636e001d9a657826d5d562cc1f7a5e 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
@@ -1386,12 +1386,15 @@ package body Sem_Util is
          ADT : Elmt_Id;
 
       begin
-         ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
+         ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
          while Present (ADT)
             and then Ekind (Node (ADT)) = E_Constant
             and then Related_Type (Node (ADT)) /= Iface
          loop
-            --  Skip the two secondary dispatch tables of Iface
+            --  Skip the secondary dispatch tables of Iface
+
+            Next_Elmt (ADT);
+            Next_Elmt (ADT);
             Next_Elmt (ADT);
             Next_Elmt (ADT);
          end loop;
@@ -3769,6 +3772,15 @@ package body Sem_Util is
       return Entity_Id (Get_Name_Table_Info (Id));
    end Get_Name_Entity_Id;
 
+   -------------------
+   -- Get_Pragma_Id --
+   -------------------
+
+   function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
+   begin
+      return Get_Pragma_Id (Pragma_Name (N));
+   end Get_Pragma_Id;
+
    ---------------------------
    -- Get_Referenced_Object --
    ---------------------------
@@ -3906,31 +3918,42 @@ package body Sem_Util is
    -----------------------------
 
    function Has_Abstract_Interfaces
-     (Tagged_Type   : Entity_Id;
+     (T             : Entity_Id;
       Use_Full_View : Boolean := True) return Boolean
    is
       Typ : Entity_Id;
 
    begin
-      pragma Assert (Is_Record_Type (Tagged_Type)
-         and then Is_Tagged_Type (Tagged_Type));
+      --  Handle concurrent types
 
-      --  Handle concurrent record types
+      if Is_Concurrent_Type (T) then
+         Typ := Corresponding_Record_Type (T);
+      else
+         Typ := T;
+      end if;
 
-      if Is_Concurrent_Record_Type (Tagged_Type)
-        and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type))
+      if not Present (Typ)
+        or else not Is_Tagged_Type (Typ)
       then
-         return True;
+         return False;
       end if;
 
-      Typ := Tagged_Type;
+      pragma Assert (Is_Record_Type (Typ));
 
       --  Handle private types
 
       if Use_Full_View
-        and then Present (Full_View (Tagged_Type))
+        and then Present (Full_View (Typ))
+      then
+         Typ := Full_View (Typ);
+      end if;
+
+      --  Handle concurrent record types
+
+      if Is_Concurrent_Record_Type (Typ)
+        and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
       then
-         Typ := Full_View (Tagged_Type);
+         return True;
       end if;
 
       loop
@@ -3953,7 +3976,7 @@ package body Sem_Util is
             --  Protect the frontend against wrong source with cyclic
             --  derivations
 
-            or else Etype (Typ) = Tagged_Type;
+            or else Etype (Typ) = T;
 
          --  Climb to the ancestor type handling private types
 
@@ -8910,8 +8933,9 @@ package body Sem_Util is
    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
    begin
       Basic_Set_Convention (E, Val);
+
       if Is_Type (E)
-        and then Ekind (Base_Type (E)) in Access_Subprogram_Type_Kind
+        and then Is_Access_Subprogram_Type (Base_Type (E))
         and then Has_Foreign_Convention (E)
       then
          Set_Can_Use_Internal_Rep (E, False);
@@ -8932,6 +8956,93 @@ package body Sem_Util is
       Set_Name_Entity_Id (Chars (E), E);
    end Set_Current_Entity;
 
+   ---------------------------
+   -- Set_Debug_Info_Needed --
+   ---------------------------
+
+   procedure Set_Debug_Info_Needed (T : Entity_Id) is
+
+      procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
+      pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
+      --  Used to set debug info in a related node if not set already
+
+      --------------------------------------
+      -- Set_Debug_Info_Needed_If_Not_Set --
+      --------------------------------------
+
+      procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
+      begin
+         if Present (E)
+           and then not Needs_Debug_Info (E)
+         then
+            Set_Debug_Info_Needed (E);
+         end if;
+      end Set_Debug_Info_Needed_If_Not_Set;
+
+   --  Start of processing for Set_Debug_Info_Needed
+
+   begin
+      --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
+      --  indicates that Debug_Info_Needed is never required for the entity.
+
+      if No (T)
+        or else Debug_Info_Off (T)
+      then
+         return;
+      end if;
+
+      --  Set flag in entity itself. Note that we will go through the following
+      --  circuitry even if the flag is already set on T. That's intentional,
+      --  it makes sure that the flag will be set in subsidiary entities.
+
+      Set_Needs_Debug_Info (T);
+
+      --  Set flag on subsidiary entities if not set already
+
+      if Is_Object (T) then
+         Set_Debug_Info_Needed_If_Not_Set (Etype (T));
+
+      elsif Is_Type (T) then
+         Set_Debug_Info_Needed_If_Not_Set (Etype (T));
+
+         if Is_Record_Type (T) then
+            declare
+               Ent : Entity_Id := First_Entity (T);
+            begin
+               while Present (Ent) loop
+                  Set_Debug_Info_Needed_If_Not_Set (Ent);
+                  Next_Entity (Ent);
+               end loop;
+            end;
+
+         elsif Is_Array_Type (T) then
+            Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
+
+            declare
+               Indx : Node_Id := First_Index (T);
+            begin
+               while Present (Indx) loop
+                  Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
+                  Indx := Next_Index (Indx);
+               end loop;
+            end;
+
+            if Is_Packed (T) then
+               Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
+            end if;
+
+         elsif Is_Access_Type (T) then
+            Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
+
+         elsif Is_Private_Type (T) then
+            Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
+
+         elsif Is_Protected_Type (T) then
+            Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
+         end if;
+      end if;
+   end Set_Debug_Info_Needed;
+
    ---------------------------------
    -- Set_Entity_With_Style_Check --
    ---------------------------------