home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / s-finimp.adb < prev    next >
Text File  |  1996-09-28  |  7KB  |  231 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --    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   --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.20 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Ada.Finalization; use Ada.Finalization;
  27. with System.Storage_Elements; use System.Storage_Elements;
  28. with Ada.Unchecked_Conversion;
  29. package body System.Finalization_Implementation is
  30.  
  31.  
  32.    --------------------------
  33.    -- Attach_To_Final_List --
  34.    --------------------------
  35.  
  36.    procedure Attach_To_Final_List
  37.      (L   : in out Finalizable_Ptr;
  38.       Obj : in out Finalizable)
  39.    is
  40.    begin
  41.       if L /= null then
  42.          Obj.Next := L;
  43.          L.Prev := Obj'Unchecked_Access;
  44.       else
  45.          Obj.Next := null;
  46.       end if;
  47.  
  48.       Obj.Prev := null;
  49.       L := Obj'Unchecked_Access;
  50.    end Attach_To_Final_List;
  51.  
  52.    ----------------------------
  53.    -- Detach_From_Final_List --
  54.    ----------------------------
  55.  
  56.    procedure Detach_From_Final_List
  57.      (L   : in out Finalizable_Ptr;
  58.       Obj : in out Finalizable)
  59.    is
  60.    begin
  61.       if Obj.Prev = null then
  62.  
  63.          --  It must be the first of the list
  64.  
  65.          L := Obj.Next;
  66.  
  67.       else
  68.          Obj.Prev.Next := Obj.Next;
  69.       end if;
  70.  
  71.       if Obj.Next /= null then
  72.          Obj.Next.Prev := Obj.Prev;
  73.          Obj.Next := null;
  74.       end if;
  75.  
  76.       Obj.Prev := null;
  77.    end Detach_From_Final_List;
  78.  
  79.    -------------------
  80.    -- Finalize_List --
  81.    -------------------
  82.  
  83.    procedure Finalize_List (L : Finalizable_Ptr) is
  84.       P     : Finalizable_Ptr := L;
  85.       Q     : Finalizable_Ptr;
  86.       Error : Boolean := False;
  87.  
  88.    begin
  89.       while P /= null loop
  90.          Q := P.Next;
  91.          begin
  92.             Finalize (P.all);
  93.          exception
  94.             when others => Error := True;
  95.          end;
  96.          P := Q;
  97.       end loop;
  98.  
  99.       if Error then
  100.          raise Program_Error;
  101.       end if;
  102.    end Finalize_List;
  103.  
  104.    --------------------------
  105.    -- Finalize_Global_List --
  106.    --------------------------
  107.  
  108.    procedure Finalize_Global_List is
  109.    begin
  110.       Finalize_List (Global_Final_List);
  111.    end Finalize_Global_List;
  112.  
  113.    ------------------
  114.    -- Finalize_One --
  115.    ------------------
  116.  
  117.    procedure Finalize_One
  118.      (From   : in out Finalizable_Ptr;
  119.       Obj    : in out  Finalizable) is
  120.  
  121.    begin
  122.       if Obj.Prev = null then
  123.  
  124.          --  It must be the first of the list
  125.  
  126.          From := Obj.Next;
  127.  
  128.       else
  129.          Obj.Prev.Next := Obj.Next;
  130.       end if;
  131.  
  132.       if Obj.Next /= null then
  133.          Obj.Next.Prev := Obj.Prev;
  134.       end if;
  135.  
  136.       Finalize (Root_Controlled'Class (Obj));
  137.  
  138.    exception
  139.       when others => raise Program_Error;
  140.    end Finalize_One;
  141.  
  142.    ----------------------------------
  143.    -- Record_Controller Management --
  144.    ----------------------------------
  145.  
  146.    ----------------
  147.    -- Initialize --
  148.    ----------------
  149.  
  150.    procedure Initialize (Object : in out Limited_Record_Controller) is
  151.    begin
  152.       null;
  153.    end Initialize;
  154.  
  155.    procedure Initialize (Object : in out Record_Controller) is
  156.    begin
  157.       Object.My_Address := Object'Address;
  158.    end Initialize;
  159.  
  160.    -------------
  161.    --  Adjust --
  162.    -------------
  163.  
  164.    procedure Adjust (Object : in out Root_Controlled) is
  165.    begin
  166.  
  167.       --  It should not be possible to call this Adjust.
  168.       raise Program_Error;
  169.    end Adjust;
  170.  
  171.    procedure Adjust (Object : in out Record_Controller) is
  172.  
  173.       My_Offset : constant Storage_Offset
  174.         := Object.My_Address - Object'Address;
  175.  
  176.       P : Finalizable_Ptr;
  177.  
  178.       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
  179.       --  Substract the offset to the pointer
  180.  
  181.       procedure Reverse_Adjust (P : Finalizable_Ptr);
  182.       --  Ajust the components in the reverse order in which they are stored
  183.       --  on the finalization list. (Adjust and Finalization are not done in
  184.       --  the same order)
  185.  
  186.       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
  187.          function To_Addr is
  188.            new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);
  189.  
  190.          function To_Ptr is
  191.            new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);
  192.  
  193.       begin
  194.          if Ptr /= null then
  195.             Ptr := To_Ptr (To_Addr (Ptr) - My_Offset);
  196.          end if;
  197.       end Ptr_Adjust;
  198.  
  199.       procedure Reverse_Adjust (P : Finalizable_Ptr) is
  200.       begin
  201.          if P /= null then
  202.             Ptr_Adjust (P.Next);
  203.             Ptr_Adjust (P.Prev);
  204.             Reverse_Adjust (P.Next);
  205.             Adjust (P.all);
  206.          end if;
  207.       end Reverse_Adjust;
  208.  
  209.    begin
  210.  
  211.       --  Adjust the components and their finalization pointers next
  212.  
  213.       Ptr_Adjust (Object.F);
  214.       Reverse_Adjust (Object.F);
  215.  
  216.       --  then Adjust the object itself
  217.  
  218.       Object.My_Address := Object'Address;
  219.    end Adjust;
  220.  
  221.    --------------
  222.    -- Finalize --
  223.    --------------
  224.  
  225.    procedure Finalize   (Object : in out Limited_Record_Controller) is
  226.    begin
  227.       Finalize_List (Object.F);
  228.    end Finalize;
  229.  
  230. end System.Finalization_Implementation;
  231.