From 1923d2d6716bf5c1c45dbe285e0774f05611be05 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 26 Mar 2008 08:39:17 +0100 Subject: exp_disp.adb (Make_DT, [...]): Set attribute Is_Static_Dispatch_Table 2008-03-26 Javier Miranda * 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 --- gcc/ada/exp_util.adb | 45 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) (limited to 'gcc/ada/exp_util.adb') 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); -- cgit v1.1