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

1 files changed, 43 insertions, 2 deletions

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index f3b9ee2..28f6d6e 100644
--- 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);