------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT RUN-TIME COMPONENTS --
|
-- 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 --
|
-- 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 --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
|
-- --
|
-- --
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
-- --
|
-- --
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
-- version 3.1, as published by the Free Software Foundation. --
|
-- version 3.1, as published by the Free Software Foundation. --
|
-- --
|
-- --
|
-- You should have received a copy of the GNU General Public License and --
|
-- You should have received a copy of the GNU General Public License and --
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
-- <http://www.gnu.org/licenses/>. --
|
-- <http://www.gnu.org/licenses/>. --
|
-- --
|
-- --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
with Ada.Exceptions;
|
with Ada.Exceptions;
|
with Ada.Tags;
|
with Ada.Tags;
|
|
|
with System.Soft_Links;
|
with System.Soft_Links;
|
|
|
with System.Restrictions;
|
with System.Restrictions;
|
|
|
package body System.Finalization_Implementation is
|
package body System.Finalization_Implementation is
|
|
|
use Ada.Exceptions;
|
use Ada.Exceptions;
|
use System.Finalization_Root;
|
use System.Finalization_Root;
|
|
|
package SSL renames System.Soft_Links;
|
package SSL renames System.Soft_Links;
|
|
|
use type SSE.Storage_Offset;
|
use type SSE.Storage_Offset;
|
|
|
-----------------------
|
-----------------------
|
-- Local Subprograms --
|
-- Local Subprograms --
|
-----------------------
|
-----------------------
|
|
|
type RC_Ptr is access all Record_Controller;
|
type RC_Ptr is access all Record_Controller;
|
|
|
function To_RC_Ptr is
|
function To_RC_Ptr is
|
new Ada.Unchecked_Conversion (Address, RC_Ptr);
|
new Ada.Unchecked_Conversion (Address, RC_Ptr);
|
|
|
procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
|
procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
|
pragma Import
|
pragma Import
|
(Ada, Raise_From_Controlled_Operation,
|
(Ada, Raise_From_Controlled_Operation,
|
"ada__exceptions__raise_from_controlled_operation");
|
"ada__exceptions__raise_from_controlled_operation");
|
pragma No_Return (Raise_From_Controlled_Operation);
|
pragma No_Return (Raise_From_Controlled_Operation);
|
-- Raise Program_Error from an exception that occurred during an Adjust or
|
-- Raise Program_Error from an exception that occurred during an Adjust or
|
-- Finalize operation. We use this rather kludgy Ada Import interface
|
-- Finalize operation. We use this rather kludgy Ada Import interface
|
-- because this procedure is not available in the visible part of the
|
-- because this procedure is not available in the visible part of the
|
-- Ada.Exceptions spec.
|
-- Ada.Exceptions spec.
|
|
|
procedure Raise_From_Finalize
|
procedure Raise_From_Finalize
|
(L : Finalizable_Ptr;
|
(L : Finalizable_Ptr;
|
From_Abort : Boolean;
|
From_Abort : Boolean;
|
E_Occ : Exception_Occurrence);
|
E_Occ : Exception_Occurrence);
|
-- Deal with an exception raised during finalization of a list. L is a
|
-- 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
|
-- 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
|
-- if the finalization actions come from an abort rather than a normal
|
-- exit. E_Occ represents the exception being raised.
|
-- exit. E_Occ represents the exception being raised.
|
|
|
function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset;
|
function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset;
|
pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset");
|
pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset");
|
|
|
function Parent_Size (Obj : Address; T : Ada.Tags.Tag)
|
function Parent_Size (Obj : Address; T : Ada.Tags.Tag)
|
return SSE.Storage_Count;
|
return SSE.Storage_Count;
|
pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
|
pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
|
|
|
function Get_Deep_Controller (Obj : System.Address) return RC_Ptr;
|
function Get_Deep_Controller (Obj : System.Address) return RC_Ptr;
|
-- Given the address (obj) of a tagged object, return a
|
-- Given the address (obj) of a tagged object, return a
|
-- pointer to the record controller of this object.
|
-- pointer to the record controller of this object.
|
|
|
------------
|
------------
|
-- Adjust --
|
-- Adjust --
|
------------
|
------------
|
|
|
overriding procedure Adjust (Object : in out Record_Controller) is
|
overriding procedure Adjust (Object : in out Record_Controller) is
|
|
|
First_Comp : Finalizable_Ptr;
|
First_Comp : Finalizable_Ptr;
|
My_Offset : constant SSE.Storage_Offset :=
|
My_Offset : constant SSE.Storage_Offset :=
|
Object.My_Address - Object'Address;
|
Object.My_Address - Object'Address;
|
|
|
procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
|
procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
|
-- Subtract the offset to the pointer
|
-- Subtract the offset to the pointer
|
|
|
procedure Reverse_Adjust (P : Finalizable_Ptr);
|
procedure Reverse_Adjust (P : Finalizable_Ptr);
|
-- Adjust the components in the reverse order in which they are stored
|
-- Adjust the components in the reverse order in which they are stored
|
-- on the finalization list. (Adjust and Finalization are not done in
|
-- on the finalization list. (Adjust and Finalization are not done in
|
-- the same order)
|
-- the same order)
|
|
|
----------------
|
----------------
|
-- Ptr_Adjust --
|
-- Ptr_Adjust --
|
----------------
|
----------------
|
|
|
procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
|
procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
|
begin
|
begin
|
if Ptr /= null then
|
if Ptr /= null then
|
Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset);
|
Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset);
|
end if;
|
end if;
|
end Ptr_Adjust;
|
end Ptr_Adjust;
|
|
|
--------------------
|
--------------------
|
-- Reverse_Adjust --
|
-- Reverse_Adjust --
|
--------------------
|
--------------------
|
|
|
procedure Reverse_Adjust (P : Finalizable_Ptr) is
|
procedure Reverse_Adjust (P : Finalizable_Ptr) is
|
begin
|
begin
|
if P /= null then
|
if P /= null then
|
Ptr_Adjust (P.Next);
|
Ptr_Adjust (P.Next);
|
Reverse_Adjust (P.Next);
|
Reverse_Adjust (P.Next);
|
Adjust (P.all);
|
Adjust (P.all);
|
Object.F := P; -- Successfully adjusted, so place in list
|
Object.F := P; -- Successfully adjusted, so place in list
|
end if;
|
end if;
|
end Reverse_Adjust;
|
end Reverse_Adjust;
|
|
|
-- Start of processing for Adjust
|
-- Start of processing for Adjust
|
|
|
begin
|
begin
|
-- Adjust the components and their finalization pointers next. We must
|
-- Adjust the components and their finalization pointers next. We must
|
-- protect against an exception in some call to Adjust, so we keep
|
-- protect against an exception in some call to Adjust, so we keep
|
-- pointing to the list of successfully adjusted components, which can
|
-- pointing to the list of successfully adjusted components, which can
|
-- be finalized if an exception is raised.
|
-- be finalized if an exception is raised.
|
|
|
First_Comp := Object.F;
|
First_Comp := Object.F;
|
Object.F := null; -- nothing adjusted yet.
|
Object.F := null; -- nothing adjusted yet.
|
Ptr_Adjust (First_Comp); -- set address of first component.
|
Ptr_Adjust (First_Comp); -- set address of first component.
|
Reverse_Adjust (First_Comp);
|
Reverse_Adjust (First_Comp);
|
|
|
-- Then Adjust the controller itself
|
-- Then Adjust the controller itself
|
|
|
Object.My_Address := Object'Address;
|
Object.My_Address := Object'Address;
|
|
|
exception
|
exception
|
when others =>
|
when others =>
|
-- Finalize those components that were successfully adjusted, and
|
-- Finalize those components that were successfully adjusted, and
|
-- propagate exception. The object itself is not yet attached to
|
-- propagate exception. The object itself is not yet attached to
|
-- global finalization list, so we cannot rely on the outer call to
|
-- global finalization list, so we cannot rely on the outer call to
|
-- Clean to take care of these components.
|
-- Clean to take care of these components.
|
|
|
Finalize (Object);
|
Finalize (Object);
|
raise;
|
raise;
|
end Adjust;
|
end Adjust;
|
|
|
--------------------------
|
--------------------------
|
-- Attach_To_Final_List --
|
-- Attach_To_Final_List --
|
--------------------------
|
--------------------------
|
|
|
procedure Attach_To_Final_List
|
procedure Attach_To_Final_List
|
(L : in out Finalizable_Ptr;
|
(L : in out Finalizable_Ptr;
|
Obj : in out Finalizable;
|
Obj : in out Finalizable;
|
Nb_Link : Short_Short_Integer)
|
Nb_Link : Short_Short_Integer)
|
is
|
is
|
begin
|
begin
|
-- Simple case: attachment to a one way list
|
-- Simple case: attachment to a one way list
|
|
|
if Nb_Link = 1 then
|
if Nb_Link = 1 then
|
Obj.Next := L;
|
Obj.Next := L;
|
L := Obj'Unchecked_Access;
|
L := Obj'Unchecked_Access;
|
|
|
-- Dynamically allocated objects: they are attached to a doubly linked
|
-- Dynamically allocated objects: they are attached to a doubly linked
|
-- list, so that an element can be finalized at any moment by means of
|
-- list, so that an element can be finalized at any moment by means of
|
-- an unchecked deallocation. Attachment is protected against
|
-- an unchecked deallocation. Attachment is protected against
|
-- multi-threaded access.
|
-- multi-threaded access.
|
|
|
elsif Nb_Link = 2 then
|
elsif Nb_Link = 2 then
|
|
|
-- Raise Program_Error if we're trying to allocate an object in a
|
-- Raise Program_Error if we're trying to allocate an object in a
|
-- collection whose finalization has already started.
|
-- collection whose finalization has already started.
|
|
|
if L = Collection_Finalization_Started then
|
if L = Collection_Finalization_Started then
|
raise Program_Error with
|
raise Program_Error with
|
"allocation after collection finalization started";
|
"allocation after collection finalization started";
|
end if;
|
end if;
|
|
|
Locked_Processing : begin
|
Locked_Processing : begin
|
SSL.Lock_Task.all;
|
SSL.Lock_Task.all;
|
Obj.Next := L.Next;
|
Obj.Next := L.Next;
|
Obj.Prev := L.Next.Prev;
|
Obj.Prev := L.Next.Prev;
|
L.Next.Prev := Obj'Unchecked_Access;
|
L.Next.Prev := Obj'Unchecked_Access;
|
L.Next := Obj'Unchecked_Access;
|
L.Next := Obj'Unchecked_Access;
|
SSL.Unlock_Task.all;
|
SSL.Unlock_Task.all;
|
|
|
exception
|
exception
|
when others =>
|
when others =>
|
SSL.Unlock_Task.all;
|
SSL.Unlock_Task.all;
|
raise;
|
raise;
|
end Locked_Processing;
|
end Locked_Processing;
|
|
|
-- Attachment of arrays to the final list (used only for objects
|
-- Attachment of arrays to the final list (used only for objects
|
-- returned by function). Obj, in this case is the last element,
|
-- returned by function). Obj, in this case is the last element,
|
-- but all other elements are already threaded after it. We just
|
-- 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.
|
-- attach the rest of the final list at the end of the array list.
|
|
|
elsif Nb_Link = 3 then
|
elsif Nb_Link = 3 then
|
declare
|
declare
|
P : Finalizable_Ptr := Obj'Unchecked_Access;
|
P : Finalizable_Ptr := Obj'Unchecked_Access;
|
|
|
begin
|
begin
|
while P.Next /= null loop
|
while P.Next /= null loop
|
P := P.Next;
|
P := P.Next;
|
end loop;
|
end loop;
|
|
|
P.Next := L;
|
P.Next := L;
|
L := Obj'Unchecked_Access;
|
L := Obj'Unchecked_Access;
|
end;
|
end;
|
|
|
-- Make the object completely unattached (case of a library-level,
|
-- Make the object completely unattached (case of a library-level,
|
-- Finalize_Storage_Only object).
|
-- Finalize_Storage_Only object).
|
|
|
elsif Nb_Link = 4 then
|
elsif Nb_Link = 4 then
|
Obj.Prev := null;
|
Obj.Prev := null;
|
Obj.Next := null;
|
Obj.Next := null;
|
end if;
|
end if;
|
end Attach_To_Final_List;
|
end Attach_To_Final_List;
|
|
|
---------------------
|
---------------------
|
-- Deep_Tag_Attach --
|
-- Deep_Tag_Attach --
|
----------------------
|
----------------------
|
|
|
procedure Deep_Tag_Attach
|
procedure Deep_Tag_Attach
|
(L : in out SFR.Finalizable_Ptr;
|
(L : in out SFR.Finalizable_Ptr;
|
A : System.Address;
|
A : System.Address;
|
B : Short_Short_Integer)
|
B : Short_Short_Integer)
|
is
|
is
|
V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
|
V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
|
Controller : constant RC_Ptr := Get_Deep_Controller (A);
|
Controller : constant RC_Ptr := Get_Deep_Controller (A);
|
|
|
begin
|
begin
|
if Controller /= null then
|
if Controller /= null then
|
Attach_To_Final_List (L, Controller.all, B);
|
Attach_To_Final_List (L, Controller.all, B);
|
end if;
|
end if;
|
|
|
-- Is controlled
|
-- Is controlled
|
|
|
if V.all in Finalizable then
|
if V.all in Finalizable then
|
Attach_To_Final_List (L, V.all, B);
|
Attach_To_Final_List (L, V.all, B);
|
end if;
|
end if;
|
end Deep_Tag_Attach;
|
end Deep_Tag_Attach;
|
|
|
-----------------------------
|
-----------------------------
|
-- Detach_From_Final_List --
|
-- Detach_From_Final_List --
|
-----------------------------
|
-----------------------------
|
|
|
-- We know that the detach object is neither at the beginning nor at the
|
-- We know that the detach object is neither at the beginning nor at the
|
-- end of the list, thanks to the dummy First and Last Elements, but the
|
-- end of the list, thanks to the dummy First and Last Elements, but the
|
-- object may not be attached at all if it is Finalize_Storage_Only
|
-- object may not be attached at all if it is Finalize_Storage_Only
|
|
|
procedure Detach_From_Final_List (Obj : in out Finalizable) is
|
procedure Detach_From_Final_List (Obj : in out Finalizable) is
|
begin
|
begin
|
-- When objects are not properly attached to a doubly linked list do
|
-- 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
|
-- not try to detach them. The only case where it can happen is when
|
-- dealing with Finalize_Storage_Only objects which are not always
|
-- dealing with Finalize_Storage_Only objects which are not always
|
-- attached to the finalization list.
|
-- attached to the finalization list.
|
|
|
if Obj.Next /= null and then Obj.Prev /= null then
|
if Obj.Next /= null and then Obj.Prev /= null then
|
SSL.Lock_Task.all;
|
SSL.Lock_Task.all;
|
Obj.Next.Prev := Obj.Prev;
|
Obj.Next.Prev := Obj.Prev;
|
Obj.Prev.Next := Obj.Next;
|
Obj.Prev.Next := Obj.Next;
|
|
|
-- Reset the pointers so that a new finalization of the same object
|
-- Reset the pointers so that a new finalization of the same object
|
-- has no effect on the finalization list.
|
-- has no effect on the finalization list.
|
|
|
Obj.Next := null;
|
Obj.Next := null;
|
Obj.Prev := null;
|
Obj.Prev := null;
|
|
|
SSL.Unlock_Task.all;
|
SSL.Unlock_Task.all;
|
end if;
|
end if;
|
|
|
exception
|
exception
|
when others =>
|
when others =>
|
SSL.Unlock_Task.all;
|
SSL.Unlock_Task.all;
|
raise;
|
raise;
|
end Detach_From_Final_List;
|
end Detach_From_Final_List;
|
|
|
--------------
|
--------------
|
-- Finalize --
|
-- Finalize --
|
--------------
|
--------------
|
|
|
overriding procedure Finalize (Object : in out Limited_Record_Controller) is
|
overriding procedure Finalize (Object : in out Limited_Record_Controller) is
|
begin
|
begin
|
Finalize_List (Object.F);
|
Finalize_List (Object.F);
|
end Finalize;
|
end Finalize;
|
|
|
--------------------------
|
--------------------------
|
-- Finalize_Global_List --
|
-- Finalize_Global_List --
|
--------------------------
|
--------------------------
|
|
|
procedure Finalize_Global_List is
|
procedure Finalize_Global_List is
|
begin
|
begin
|
-- There are three case here:
|
-- There are three case here:
|
|
|
-- a. the application uses tasks, in which case Finalize_Global_Tasks
|
-- a. the application uses tasks, in which case Finalize_Global_Tasks
|
-- will defer abort.
|
-- will defer abort.
|
|
|
-- b. the application doesn't use tasks but uses other tasking
|
-- b. the application doesn't use tasks but uses other tasking
|
-- constructs, such as ATCs and protected objects. In this case,
|
-- constructs, such as ATCs and protected objects. In this case,
|
-- the binder will call Finalize_Global_List instead of
|
-- the binder will call Finalize_Global_List instead of
|
-- Finalize_Global_Tasks, letting abort undeferred, and leading
|
-- Finalize_Global_Tasks, letting abort undeferred, and leading
|
-- to assertion failures in the GNULL
|
-- to assertion failures in the GNULL
|
|
|
-- c. the application doesn't use any tasking construct in which case
|
-- c. the application doesn't use any tasking construct in which case
|
-- deferring abort isn't necessary.
|
-- deferring abort isn't necessary.
|
|
|
-- Until another solution is found to deal with case b, we need to
|
-- 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
|
-- call abort_defer here to pass the checks, but we do not need to
|
-- undefer abort, since Finalize_Global_List is the last procedure
|
-- undefer abort, since Finalize_Global_List is the last procedure
|
-- called before exiting the partition.
|
-- called before exiting the partition.
|
|
|
SSL.Abort_Defer.all;
|
SSL.Abort_Defer.all;
|
Finalize_List (Global_Final_List);
|
Finalize_List (Global_Final_List);
|
end Finalize_Global_List;
|
end Finalize_Global_List;
|
|
|
-------------------
|
-------------------
|
-- Finalize_List --
|
-- Finalize_List --
|
-------------------
|
-------------------
|
|
|
procedure Finalize_List (L : Finalizable_Ptr) is
|
procedure Finalize_List (L : Finalizable_Ptr) is
|
P : Finalizable_Ptr := L;
|
P : Finalizable_Ptr := L;
|
Q : Finalizable_Ptr;
|
Q : Finalizable_Ptr;
|
|
|
type Fake_Exception_Occurence is record
|
type Fake_Exception_Occurence is record
|
Id : Exception_Id;
|
Id : Exception_Id;
|
end record;
|
end record;
|
type Ptr is access all Fake_Exception_Occurence;
|
type Ptr is access all Fake_Exception_Occurence;
|
|
|
function To_Ptr is new
|
function To_Ptr is new
|
Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
|
Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
|
|
|
X : Exception_Id := Null_Id;
|
X : Exception_Id := Null_Id;
|
|
|
begin
|
begin
|
-- If abort is allowed, we get the current exception before starting
|
-- 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
|
-- 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
|
-- exception is raised. When abort is not allowed, avoid accessing the
|
-- current exception since this can be a pretty costly operation in
|
-- current exception since this can be a pretty costly operation in
|
-- programs using controlled types heavily.
|
-- programs using controlled types heavily.
|
|
|
if System.Restrictions.Abort_Allowed then
|
if System.Restrictions.Abort_Allowed then
|
X := To_Ptr (SSL.Get_Current_Excep.all).Id;
|
X := To_Ptr (SSL.Get_Current_Excep.all).Id;
|
end if;
|
end if;
|
|
|
while P /= null loop
|
while P /= null loop
|
Q := P.Next;
|
Q := P.Next;
|
Finalize (P.all);
|
Finalize (P.all);
|
P := Q;
|
P := Q;
|
end loop;
|
end loop;
|
|
|
exception
|
exception
|
when E_Occ : others =>
|
when E_Occ : others =>
|
Raise_From_Finalize (
|
Raise_From_Finalize (
|
Q,
|
Q,
|
X = Standard'Abort_Signal'Identity,
|
X = Standard'Abort_Signal'Identity,
|
E_Occ);
|
E_Occ);
|
end Finalize_List;
|
end Finalize_List;
|
|
|
------------------
|
------------------
|
-- Finalize_One --
|
-- Finalize_One --
|
------------------
|
------------------
|
|
|
procedure Finalize_One (Obj : in out Finalizable) is
|
procedure Finalize_One (Obj : in out Finalizable) is
|
begin
|
begin
|
Detach_From_Final_List (Obj);
|
Detach_From_Final_List (Obj);
|
Finalize (Obj);
|
Finalize (Obj);
|
exception
|
exception
|
when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
|
when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
|
end Finalize_One;
|
end Finalize_One;
|
|
|
-------------------------
|
-------------------------
|
-- Get_Deep_Controller --
|
-- Get_Deep_Controller --
|
-------------------------
|
-------------------------
|
|
|
function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is
|
function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is
|
The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag;
|
The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag;
|
Offset : SSE.Storage_Offset := RC_Offset (The_Tag);
|
Offset : SSE.Storage_Offset := RC_Offset (The_Tag);
|
|
|
begin
|
begin
|
-- Fetch the controller from the Parent or above if necessary
|
-- Fetch the controller from the Parent or above if necessary
|
-- when there are no controller at this level.
|
-- when there are no controller at this level.
|
|
|
while Offset = -2 loop
|
while Offset = -2 loop
|
The_Tag := Ada.Tags.Parent_Tag (The_Tag);
|
The_Tag := Ada.Tags.Parent_Tag (The_Tag);
|
Offset := RC_Offset (The_Tag);
|
Offset := RC_Offset (The_Tag);
|
end loop;
|
end loop;
|
|
|
-- No Controlled component case
|
-- No Controlled component case
|
|
|
if Offset = 0 then
|
if Offset = 0 then
|
return null;
|
return null;
|
|
|
-- The _controller Offset is known statically
|
-- The _controller Offset is known statically
|
|
|
elsif Offset > 0 then
|
elsif Offset > 0 then
|
return To_RC_Ptr (Obj + Offset);
|
return To_RC_Ptr (Obj + Offset);
|
|
|
-- At this stage, we know that the controller is part of the
|
-- At this stage, we know that the controller is part of the
|
-- ancestor corresponding to the tag "The_Tag" and that its parent
|
-- ancestor corresponding to the tag "The_Tag" and that its parent
|
-- is variable sized. We assume that the _controller is the first
|
-- is variable sized. We assume that the _controller is the first
|
-- component right after the parent.
|
-- component right after the parent.
|
|
|
-- ??? note that it may not be true if there are new discriminants
|
-- ??? note that it may not be true if there are new discriminants
|
|
|
else -- Offset = -1
|
else -- Offset = -1
|
|
|
declare
|
declare
|
-- define a faked record controller to avoid generating
|
-- define a faked record controller to avoid generating
|
-- unnecessary expanded code for controlled types
|
-- unnecessary expanded code for controlled types
|
|
|
type Faked_Record_Controller is record
|
type Faked_Record_Controller is record
|
Tag, Prec, Next : Address;
|
Tag, Prec, Next : Address;
|
end record;
|
end record;
|
|
|
-- Reconstruction of a type with characteristics
|
-- Reconstruction of a type with characteristics
|
-- comparable to the original type
|
-- comparable to the original type
|
|
|
D : constant := SSE.Storage_Offset (Storage_Unit - 1);
|
D : constant := SSE.Storage_Offset (Storage_Unit - 1);
|
|
|
type Parent_Type is new SSE.Storage_Array
|
type Parent_Type is new SSE.Storage_Array
|
(1 .. (Parent_Size (Obj, The_Tag) + D) /
|
(1 .. (Parent_Size (Obj, The_Tag) + D) /
|
SSE.Storage_Offset (Storage_Unit));
|
SSE.Storage_Offset (Storage_Unit));
|
for Parent_Type'Alignment use Address'Alignment;
|
for Parent_Type'Alignment use Address'Alignment;
|
|
|
type Faked_Type_Of_Obj is record
|
type Faked_Type_Of_Obj is record
|
Parent : Parent_Type;
|
Parent : Parent_Type;
|
Controller : Faked_Record_Controller;
|
Controller : Faked_Record_Controller;
|
end record;
|
end record;
|
|
|
type Obj_Ptr is access all Faked_Type_Of_Obj;
|
type Obj_Ptr is access all Faked_Type_Of_Obj;
|
function To_Obj_Ptr is
|
function To_Obj_Ptr is
|
new Ada.Unchecked_Conversion (Address, Obj_Ptr);
|
new Ada.Unchecked_Conversion (Address, Obj_Ptr);
|
|
|
begin
|
begin
|
return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
|
return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
|
end;
|
end;
|
end if;
|
end if;
|
end Get_Deep_Controller;
|
end Get_Deep_Controller;
|
|
|
----------------
|
----------------
|
-- Initialize --
|
-- Initialize --
|
----------------
|
----------------
|
|
|
overriding procedure Initialize
|
overriding procedure Initialize
|
(Object : in out Limited_Record_Controller)
|
(Object : in out Limited_Record_Controller)
|
is
|
is
|
pragma Warnings (Off, Object);
|
pragma Warnings (Off, Object);
|
begin
|
begin
|
null;
|
null;
|
end Initialize;
|
end Initialize;
|
|
|
overriding procedure Initialize (Object : in out Record_Controller) is
|
overriding procedure Initialize (Object : in out Record_Controller) is
|
begin
|
begin
|
Object.My_Address := Object'Address;
|
Object.My_Address := Object'Address;
|
end Initialize;
|
end Initialize;
|
|
|
---------------------
|
---------------------
|
-- Move_Final_List --
|
-- Move_Final_List --
|
---------------------
|
---------------------
|
|
|
procedure Move_Final_List
|
procedure Move_Final_List
|
(From : in out SFR.Finalizable_Ptr;
|
(From : in out SFR.Finalizable_Ptr;
|
To : Finalizable_Ptr_Ptr)
|
To : Finalizable_Ptr_Ptr)
|
is
|
is
|
begin
|
begin
|
-- This is currently called at the end of the return statement, and the
|
-- This is currently called at the end of the return statement, and the
|
-- caller does NOT defer aborts. We need to defer aborts to prevent
|
-- caller does NOT defer aborts. We need to defer aborts to prevent
|
-- mangling the finalization lists.
|
-- mangling the finalization lists.
|
|
|
SSL.Abort_Defer.all;
|
SSL.Abort_Defer.all;
|
|
|
-- Put the return statement's finalization list onto the caller's one,
|
-- Put the return statement's finalization list onto the caller's one,
|
-- thus transferring responsibility for finalization of the return
|
-- thus transferring responsibility for finalization of the return
|
-- object to the caller.
|
-- object to the caller.
|
|
|
Attach_To_Final_List (To.all, From.all, Nb_Link => 3);
|
Attach_To_Final_List (To.all, From.all, Nb_Link => 3);
|
|
|
-- Empty the return statement's finalization list, so that when the
|
-- Empty the return statement's finalization list, so that when the
|
-- cleanup code executes, there will be nothing to finalize.
|
-- cleanup code executes, there will be nothing to finalize.
|
From := null;
|
From := null;
|
|
|
SSL.Abort_Undefer.all;
|
SSL.Abort_Undefer.all;
|
end Move_Final_List;
|
end Move_Final_List;
|
|
|
-------------------------
|
-------------------------
|
-- Raise_From_Finalize --
|
-- Raise_From_Finalize --
|
-------------------------
|
-------------------------
|
|
|
procedure Raise_From_Finalize
|
procedure Raise_From_Finalize
|
(L : Finalizable_Ptr;
|
(L : Finalizable_Ptr;
|
From_Abort : Boolean;
|
From_Abort : Boolean;
|
E_Occ : Exception_Occurrence)
|
E_Occ : Exception_Occurrence)
|
is
|
is
|
P : Finalizable_Ptr := L;
|
P : Finalizable_Ptr := L;
|
Q : Finalizable_Ptr;
|
Q : Finalizable_Ptr;
|
|
|
begin
|
begin
|
-- We already got an exception. We now finalize the remainder of
|
-- We already got an exception. We now finalize the remainder of
|
-- the list, ignoring all further exceptions.
|
-- the list, ignoring all further exceptions.
|
|
|
while P /= null loop
|
while P /= null loop
|
Q := P.Next;
|
Q := P.Next;
|
|
|
begin
|
begin
|
Finalize (P.all);
|
Finalize (P.all);
|
exception
|
exception
|
when others => null;
|
when others => null;
|
end;
|
end;
|
|
|
P := Q;
|
P := Q;
|
end loop;
|
end loop;
|
|
|
if From_Abort then
|
if From_Abort then
|
-- If finalization from an Abort, then nothing to do
|
-- If finalization from an Abort, then nothing to do
|
|
|
null;
|
null;
|
|
|
else
|
else
|
-- Else raise Program_Error with an appropriate message
|
-- Else raise Program_Error with an appropriate message
|
|
|
Raise_From_Controlled_Operation (E_Occ);
|
Raise_From_Controlled_Operation (E_Occ);
|
end if;
|
end if;
|
end Raise_From_Finalize;
|
end Raise_From_Finalize;
|
|
|
-- Initialization of package, set Adafinal soft link
|
-- Initialization of package, set Adafinal soft link
|
|
|
begin
|
begin
|
SSL.Finalize_Global_List := Finalize_Global_List'Access;
|
SSL.Finalize_Global_List := Finalize_Global_List'Access;
|
end System.Finalization_Implementation;
|
end System.Finalization_Implementation;
|
|
|