+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- --
--- $Revision: 1.2.10.1 $
--- --
--- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, 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 Ada.Unchecked_Conversion;
-with System.Storage_Elements;
-with System.Soft_Links;
-
-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 --
- -----------------------
-
- function To_Finalizable_Ptr is
- new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);
-
- function To_Addr is
- new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);
-
- type RC_Ptr is access all Record_Controller;
-
- function To_RC_Ptr is
- new Ada.Unchecked_Conversion (Address, RC_Ptr);
-
- procedure Raise_Exception_No_Defer
- (E : in Exception_Id;
- Message : in 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) return SSE.Storage_Count;
- pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
-
- function Get_RC_Dynamically (Obj : Address) return Address;
- -- Given an the address of an object (obj) of a tagged extension with
- -- controlled component, computes the address of the record controller
- -- located just after the _parent field
-
- -------------
- -- 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);
- -- Adjust 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)
-
- 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;
-
- 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;
- 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);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
-
- begin
- -- Has controlled components
-
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
- Adjust (Controller.all);
- Attach_To_Final_List (L, Controller.all, B);
-
- -- Is controlled
-
- elsif 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);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
-
- begin
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
- Attach_To_Final_List (L, Controller.all, B);
-
- -- Is controlled
-
- elsif 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
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
-
- begin
- -- Has controlled components
-
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
- if B then
- Finalize_One (Controller.all);
- else
- Finalize (Controller.all);
- end if;
-
- -- Is controlled
-
- elsif 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);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
-
- begin
- -- This procedure should not be called if the object has no
- -- controlled components
-
- if Offset = 0 then
-
- raise Program_Error;
-
- -- Has controlled components
-
- else
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
- end if;
-
- Initialize (Controller.all);
- Attach_To_Final_List (L, Controller.all, B);
-
- -- 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.
-
- 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 abortion
- -- 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 abortion, 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_Occurrence is record
- Id : Exception_Id;
- end record;
- type Ptr is access all Fake_Exception_Occurrence;
-
- -- Let's get the current exception before starting to finalize in
- -- order to check if we are in the abort case if an exception is
- -- raised.
-
- function To_Ptr is new
- Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
- X : Exception_Id :=
- To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
-
- begin
- 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_RC_Dynamically --
- ------------------------
-
- function Get_RC_Dynamically (Obj : Address) return Address is
-
- -- 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 := Storage_Unit - 1;
-
- type Faked_Type_Of_Obj is record
- Parent : SSE.Storage_Array
- (1 .. (Parent_Size (Obj) + D) / Storage_Unit);
- Controller : Faked_Record_Controller;
- end record;
-
- type Obj_Ptr is access all Faked_Type_Of_Obj;
- function To_Obj_Ptr is new Ada.Unchecked_Conversion (Address, Obj_Ptr);
-
- begin
- return To_Obj_Ptr (Obj).Controller'Address;
- end Get_RC_Dynamically;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Object : in out Limited_Record_Controller) is
- 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.Adafinal := Finalize_Global_List'Access;
-
-end System.Finalization_Implementation;
projects / msp430-gcc.git / blobdiff