diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/s-finimp.adb')
-rw-r--r-- | gcc-4.2.1/gcc/ada/s-finimp.adb | 606 |
1 files changed, 0 insertions, 606 deletions
diff --git a/gcc-4.2.1/gcc/ada/s-finimp.adb b/gcc-4.2.1/gcc/ada/s-finimp.adb deleted file mode 100644 index 133c47ca2..000000000 --- a/gcc-4.2.1/gcc/ada/s-finimp.adb +++ /dev/null @@ -1,606 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2006, 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Ada.Tags; - -with System.Storage_Elements; -with System.Soft_Links; - -with Unchecked_Conversion; -with System.Restrictions; - -package body System.Finalization_Implementation is - - use Ada.Exceptions; - use System.Finalization_Root; - - package SSL renames System.Soft_Links; - - package SSE renames System.Storage_Elements; - use type SSE.Storage_Offset; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - type RC_Ptr is access all Record_Controller; - - function To_RC_Ptr is - new Unchecked_Conversion (Address, RC_Ptr); - - procedure Raise_Exception_No_Defer - (E : Exception_Id; - Message : String := ""); - pragma Import (Ada, Raise_Exception_No_Defer, - "ada__exceptions__raise_exception_no_defer"); - pragma No_Return (Raise_Exception_No_Defer); - -- Raise an exception without deferring abort. Note that we have to - -- use this rather kludgy Ada Import interface, since this subprogram - -- is not available in the visible spec of Ada.Exceptions. - - procedure Raise_From_Finalize - (L : Finalizable_Ptr; - From_Abort : Boolean; - E_Occ : Exception_Occurrence); - -- Deal with an exception raised during finalization of a list. L is a - -- pointer to the list of element not yet finalized. From_Abort is true - -- if the finalization actions come from an abort rather than a normal - -- exit. E_Occ represents the exception being raised. - - function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset; - pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset"); - - function Parent_Size (Obj : Address; T : Ada.Tags.Tag) - return SSE.Storage_Count; - pragma Import (Ada, Parent_Size, "ada__tags__parent_size"); - - function Get_Deep_Controller (Obj : System.Address) return RC_Ptr; - -- Given the address (obj) of a tagged object, return a - -- pointer to the record controller of this object. - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Record_Controller) is - - First_Comp : Finalizable_Ptr; - My_Offset : constant SSE.Storage_Offset := - Object.My_Address - Object'Address; - - procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr); - -- Subtract the offset to the pointer - - procedure Reverse_Adjust (P : Finalizable_Ptr); - -- Ajust the components in the reverse order in which they are stored - -- on the finalization list. (Adjust and Finalization are not done in - -- the same order) - - ---------------- - -- Ptr_Adjust -- - ---------------- - - procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is - begin - if Ptr /= null then - Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset); - end if; - end Ptr_Adjust; - - -------------------- - -- Reverse_Adjust -- - -------------------- - - procedure Reverse_Adjust (P : Finalizable_Ptr) is - begin - if P /= null then - Ptr_Adjust (P.Next); - Reverse_Adjust (P.Next); - Adjust (P.all); - Object.F := P; -- Successfully adjusted, so place in list. - end if; - end Reverse_Adjust; - - -- Start of processing for Adjust - - begin - -- Adjust the components and their finalization pointers next. We must - -- protect against an exception in some call to Adjust, so we keep - -- pointing to the list of successfully adjusted components, which can - -- be finalized if an exception is raised. - - First_Comp := Object.F; - Object.F := null; -- nothing adjusted yet. - Ptr_Adjust (First_Comp); -- set addresss of first component. - Reverse_Adjust (First_Comp); - - -- Then Adjust the controller itself - - Object.My_Address := Object'Address; - - exception - when others => - -- Finalize those components that were successfully adjusted, and - -- propagate exception. The object itself is not yet attached to - -- global finalization list, so we cannot rely on the outer call to - -- Clean to take care of these components. - - Finalize (Object); - raise; - end Adjust; - - -------------------------- - -- Attach_To_Final_List -- - -------------------------- - - procedure Attach_To_Final_List - (L : in out Finalizable_Ptr; - Obj : in out Finalizable; - Nb_Link : Short_Short_Integer) - is - begin - -- Simple case: attachement to a one way list - - if Nb_Link = 1 then - Obj.Next := L; - L := Obj'Unchecked_Access; - - -- Dynamically allocated objects: they are attached to a doubly linked - -- list, so that an element can be finalized at any moment by means of - -- an unchecked deallocation. Attachement is protected against - -- multi-threaded access. - - elsif Nb_Link = 2 then - - Locked_Processing : begin - SSL.Lock_Task.all; - Obj.Next := L.Next; - Obj.Prev := L.Next.Prev; - L.Next.Prev := Obj'Unchecked_Access; - L.Next := Obj'Unchecked_Access; - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Locked_Processing; - - -- Attachement of arrays to the final list (used only for objects - -- returned by function). Obj, in this case is the last element, - -- but all other elements are already threaded after it. We just - -- attach the rest of the final list at the end of the array list. - - elsif Nb_Link = 3 then - declare - P : Finalizable_Ptr := Obj'Unchecked_Access; - - begin - while P.Next /= null loop - P := P.Next; - end loop; - - P.Next := L; - L := Obj'Unchecked_Access; - end; - - -- Make the object completely unattached (case of a library-level, - -- Finalize_Storage_Only object). - - elsif Nb_Link = 4 then - Obj.Prev := null; - Obj.Next := null; - end if; - end Attach_To_Final_List; - - --------------------- - -- Deep_Tag_Adjust -- - --------------------- - - procedure Deep_Tag_Adjust - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer) - is - V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); - Controller : constant RC_Ptr := Get_Deep_Controller (A); - - begin - if Controller /= null then - Adjust (Controller.all); - Attach_To_Final_List (L, Controller.all, B); - end if; - - -- Is controlled - - if V.all in Finalizable then - Adjust (V.all); - Attach_To_Final_List (L, Finalizable (V.all), 1); - end if; - end Deep_Tag_Adjust; - - --------------------- - -- Deep_Tag_Attach -- - ---------------------- - - procedure Deep_Tag_Attach - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer) - is - V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); - Controller : constant RC_Ptr := Get_Deep_Controller (A); - - begin - if Controller /= null then - Attach_To_Final_List (L, Controller.all, B); - end if; - - -- Is controlled - - if V.all in Finalizable then - Attach_To_Final_List (L, V.all, B); - end if; - end Deep_Tag_Attach; - - ----------------------- - -- Deep_Tag_Finalize -- - ----------------------- - - procedure Deep_Tag_Finalize - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Boolean) - is - pragma Warnings (Off, L); - - V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); - Controller : constant RC_Ptr := Get_Deep_Controller (A); - - begin - if Controller /= null then - if B then - Finalize_One (Controller.all); - else - Finalize (Controller.all); - end if; - end if; - - -- Is controlled - - if V.all in Finalizable then - if B then - Finalize_One (V.all); - else - Finalize (V.all); - end if; - end if; - end Deep_Tag_Finalize; - - ------------------------- - -- Deep_Tag_Initialize -- - ------------------------- - - procedure Deep_Tag_Initialize - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer) - is - V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); - Controller : constant RC_Ptr := Get_Deep_Controller (A); - - begin - -- This procedure should not be called if the object has no - -- controlled components - - if Controller = null then - raise Program_Error; - - -- Has controlled components - - else - Initialize (Controller.all); - Attach_To_Final_List (L, Controller.all, B); - end if; - - -- Is controlled - - if V.all in Finalizable then - Initialize (V.all); - Attach_To_Final_List (Controller.F, Finalizable (Controller.all), 1); - end if; - end Deep_Tag_Initialize; - - ----------------------------- - -- Detach_From_Final_List -- - ----------------------------- - - -- We know that the detach object is neither at the beginning nor at the - -- end of the list, thank's to the dummy First and Last Elements but the - -- object may not be attached at all if it is Finalize_Storage_Only - - procedure Detach_From_Final_List (Obj : in out Finalizable) is - begin - - -- When objects are not properly attached to a doubly linked list do - -- not try to detach them. The only case where it can happen is when - -- dealing with Finalize_Storage_Only objects which are not always - -- attached to the finalization list. - - if Obj.Next /= null and then Obj.Prev /= null then - SSL.Lock_Task.all; - Obj.Next.Prev := Obj.Prev; - Obj.Prev.Next := Obj.Next; - SSL.Unlock_Task.all; - end if; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Detach_From_Final_List; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Limited_Record_Controller) is - begin - Finalize_List (Object.F); - end Finalize; - - -------------------------- - -- Finalize_Global_List -- - -------------------------- - - procedure Finalize_Global_List is - begin - -- There are three case here: - - -- a. the application uses tasks, in which case Finalize_Global_Tasks - -- will defer abort. - - -- b. the application doesn't use tasks but uses other tasking - -- constructs, such as ATCs and protected objects. In this case, - -- the binder will call Finalize_Global_List instead of - -- Finalize_Global_Tasks, letting abort undeferred, and leading - -- to assertion failures in the GNULL - - -- c. the application doesn't use any tasking construct in which case - -- deferring abort isn't necessary. - - -- Until another solution is found to deal with case b, we need to - -- call abort_defer here to pass the checks, but we do not need to - -- undefer abort, since Finalize_Global_List is the last procedure - -- called before exiting the partition. - - SSL.Abort_Defer.all; - Finalize_List (Global_Final_List); - end Finalize_Global_List; - - ------------------- - -- Finalize_List -- - ------------------- - - procedure Finalize_List (L : Finalizable_Ptr) is - P : Finalizable_Ptr := L; - Q : Finalizable_Ptr; - - type Fake_Exception_Occurence is record - Id : Exception_Id; - end record; - type Ptr is access all Fake_Exception_Occurence; - - function To_Ptr is new - Unchecked_Conversion (Exception_Occurrence_Access, Ptr); - - X : Exception_Id := Null_Id; - - begin - -- If abort is allowed, we get the current exception before starting - -- to finalize in order to check if we are in the abort case if an - -- exception is raised. When abort is not allowed, avoid accessing the - -- current exception since this can be a pretty costly operation in - -- programs using controlled types heavily. - - if System.Restrictions.Abort_Allowed then - X := To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id; - end if; - - while P /= null loop - Q := P.Next; - Finalize (P.all); - P := Q; - end loop; - - exception - when E_Occ : others => - Raise_From_Finalize ( - Q, - X = Standard'Abort_Signal'Identity, - E_Occ); - end Finalize_List; - - ------------------ - -- Finalize_One -- - ------------------ - - procedure Finalize_One (Obj : in out Finalizable) is - begin - Detach_From_Final_List (Obj); - Finalize (Obj); - exception - when E_Occ : others => Raise_From_Finalize (null, False, E_Occ); - end Finalize_One; - - ------------------------- - -- Get_Deep_Controller -- - ------------------------- - - function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is - The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag; - Offset : SSE.Storage_Offset := RC_Offset (The_Tag); - - begin - -- Fetch the controller from the Parent or above if necessary - -- when there are no controller at this level - - while Offset = -2 loop - The_Tag := Ada.Tags.Parent_Tag (The_Tag); - Offset := RC_Offset (The_Tag); - end loop; - - -- No Controlled component case - - if Offset = 0 then - return null; - - -- The _controller Offset is known statically - - elsif Offset > 0 then - return To_RC_Ptr (Obj + Offset); - - -- At this stage, we know that the controller is part of the - -- ancestor corresponding to the tag "The_Tag" and that its parent - -- is variable sized. We assume that the _controller is the first - -- compoment right after the parent. - - -- ??? note that it may not be true if there are new discriminants - - else -- Offset = -1 - - declare - -- define a faked record controller to avoid generating - -- unnecessary expanded code for controlled types - - type Faked_Record_Controller is record - Tag, Prec, Next : Address; - end record; - - -- Reconstruction of a type with characteristics - -- comparable to the original type - - D : constant := SSE.Storage_Offset (Storage_Unit - 1); - - type Parent_Type is new SSE.Storage_Array - (1 .. (Parent_Size (Obj, The_Tag) + D) / - SSE.Storage_Offset (Storage_Unit)); - for Parent_Type'Alignment use Address'Alignment; - - type Faked_Type_Of_Obj is record - Parent : Parent_Type; - Controller : Faked_Record_Controller; - end record; - - type Obj_Ptr is access all Faked_Type_Of_Obj; - function To_Obj_Ptr is - new Unchecked_Conversion (Address, Obj_Ptr); - - begin - return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address); - end; - end if; - end Get_Deep_Controller; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Limited_Record_Controller) is - pragma Warnings (Off, Object); - begin - null; - end Initialize; - - procedure Initialize (Object : in out Record_Controller) is - begin - Object.My_Address := Object'Address; - end Initialize; - - ------------------------- - -- Raise_From_Finalize -- - ------------------------- - - procedure Raise_From_Finalize - (L : Finalizable_Ptr; - From_Abort : Boolean; - E_Occ : Exception_Occurrence) - is - Msg : constant String := Exception_Message (E_Occ); - P : Finalizable_Ptr := L; - Q : Finalizable_Ptr; - - begin - -- We already got an exception. We now finalize the remainder of - -- the list, ignoring all further exceptions. - - while P /= null loop - Q := P.Next; - - begin - Finalize (P.all); - exception - when others => null; - end; - - P := Q; - end loop; - - -- If finalization from an Abort, then nothing to do - - if From_Abort then - null; - - -- If no message, then add our own message saying what happened - - elsif Msg = "" then - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => "exception " & - Exception_Name (E_Occ) & - " raised during finalization"); - - -- If there was a message, pass it on - - else - Raise_Exception_No_Defer (Program_Error'Identity, Msg); - end if; - end Raise_From_Finalize; - --- Initialization of package, set Adafinal soft link - -begin - SSL.Finalize_Global_List := Finalize_Global_List'Access; - -end System.Finalization_Implementation; |