------------------------------------------------------------------------------
--                                                                          --
--                         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-2005 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 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       : 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; T : Ada.Tags.Tag)
     return SSE.Storage_Count;
   pragma Import (Ada, Parent_Size, "ada__tags__parent_size");

   function Parent_Tag (T : Ada.Tags.Tag) return Ada.Tags.Tag;
   pragma Import (Ada, Parent_Tag, "ada__tags__parent_tag");

   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;
      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 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_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 := 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.Adafinal := Finalize_Global_List'Access;

end System.Finalization_Implementation;