Geek Gadgets 1/ADE-1.bin/ade-bin/lib/gcc-lib/m68k-amigaos/2.7.2.1/adainclude/s-finimp.adb

Text File | 1995-10-17 | 6.5 KB | 231 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER 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.20 $                              --
--                                                                          --
--           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
--                                                                          --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software  Foundation; either version 2, or (at your option) any --
-- later version.  The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
-- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
-- Library  General  Public  License for  more  details.  You  should  have --
-- received  a copy of the GNU  Library  General Public License  along with --
-- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Finalization; use Ada.Finalization;
with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
package body System.Finalization_Implementation is


   --------------------------
   -- Attach_To_Final_List --
   --------------------------

   procedure Attach_To_Final_List
     (L   : in out Finalizable_Ptr;
      Obj : in out Finalizable)
   is
   begin
      if L /= null then
         Obj.Next := L;
         L.Prev := Obj'Unchecked_Access;
      else
         Obj.Next := null;
      end if;

      Obj.Prev := null;
      L := Obj'Unchecked_Access;
   end Attach_To_Final_List;

   ----------------------------
   -- Detach_From_Final_List --
   ----------------------------

   procedure Detach_From_Final_List
     (L   : in out Finalizable_Ptr;
      Obj : in out Finalizable)
   is
   begin
      if Obj.Prev = null then

         --  It must be the first of the list

         L := Obj.Next;

      else
         Obj.Prev.Next := Obj.Next;
      end if;

      if Obj.Next /= null then
         Obj.Next.Prev := Obj.Prev;
         Obj.Next := null;
      end if;

      Obj.Prev := null;
   end Detach_From_Final_List;

   -------------------
   -- Finalize_List --
   -------------------

   procedure Finalize_List (L : Finalizable_Ptr) is
      P     : Finalizable_Ptr := L;
      Q     : Finalizable_Ptr;
      Error : Boolean := False;

   begin
      while P /= null loop
         Q := P.Next;
         begin
            Finalize (P.all);
         exception
            when others => Error := True;
         end;
         P := Q;
      end loop;

      if Error then
         raise Program_Error;
      end if;
   end Finalize_List;

   --------------------------
   -- Finalize_Global_List --
   --------------------------

   procedure Finalize_Global_List is
   begin
      Finalize_List (Global_Final_List);
   end Finalize_Global_List;

   ------------------
   -- Finalize_One --
   ------------------

   procedure Finalize_One
     (From   : in out Finalizable_Ptr;
      Obj    : in out  Finalizable) is

   begin
      if Obj.Prev = null then

         --  It must be the first of the list

         From := Obj.Next;

      else
         Obj.Prev.Next := Obj.Next;
      end if;

      if Obj.Next /= null then
         Obj.Next.Prev := Obj.Prev;
      end if;

      Finalize (Root_Controlled'Class (Obj));

   exception
      when others => raise Program_Error;
   end Finalize_One;

   ----------------------------------
   -- Record_Controller Management --
   ----------------------------------

   ----------------
   -- 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;

   -------------
   --  Adjust --
   -------------

   procedure Adjust (Object : in out Root_Controlled) is
   begin

      --  It should not be possible to call this Adjust.
      raise Program_Error;
   end Adjust;

   procedure Adjust (Object : in out Record_Controller) is

      My_Offset : constant Storage_Offset
        := Object.My_Address - Object'Address;

      P : Finalizable_Ptr;

      procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
      --  Substract 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)

      procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
         function To_Addr is
           new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);

         function To_Ptr is
           new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);

      begin
         if Ptr /= null then
            Ptr := To_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);
            Ptr_Adjust (P.Prev);
            Reverse_Adjust (P.Next);
            Adjust (P.all);
         end if;
      end Reverse_Adjust;

   begin

      --  Adjust the components and their finalization pointers next

      Ptr_Adjust (Object.F);
      Reverse_Adjust (Object.F);

      --  then Adjust the object itself

      Object.My_Address := Object'Address;
   end Adjust;

   --------------
   -- Finalize --
   --------------

   procedure Finalize   (Object : in out Limited_Record_Controller) is
   begin
      Finalize_List (Object.F);
   end Finalize;

end System.Finalization_Implementation;