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;
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);
procedure Raise_From_Finalize
(L : Finalizable_Ptr;
From_Abort : Boolean;
E_Occ : Exception_Occurrence);
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;
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);
procedure Reverse_Adjust (P : Finalizable_Ptr);
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; end if;
end Reverse_Adjust;
begin
First_Comp := Object.F;
Object.F := null; Ptr_Adjust (First_Comp); Reverse_Adjust (First_Comp);
Object.My_Address := Object'Address;
exception
when others =>
Finalize (Object);
raise;
end Adjust;
procedure Attach_To_Final_List
(L : in out Finalizable_Ptr;
Obj : in out Finalizable;
Nb_Link : Short_Short_Integer)
is
begin
if Nb_Link = 1 then
Obj.Next := L;
L := Obj'Unchecked_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;
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;
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;
if V.all in Finalizable then
Adjust (V.all);
Attach_To_Final_List (L, Finalizable (V.all), 1);
end if;
end Deep_Tag_Adjust;
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;
if V.all in Finalizable then
Attach_To_Final_List (L, V.all, B);
end if;
end Deep_Tag_Attach;
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;
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;
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
if Controller = null then
raise Program_Error;
else
Initialize (Controller.all);
Attach_To_Final_List (L, Controller.all, B);
end if;
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;
procedure Detach_From_Final_List (Obj : in out Finalizable) is
begin
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;
procedure Finalize (Object : in out Limited_Record_Controller) is
begin
Finalize_List (Object.F);
end Finalize;
procedure Finalize_Global_List is
begin
SSL.Abort_Defer.all;
Finalize_List (Global_Final_List);
end Finalize_Global_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 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;
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;
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
while Offset = -2 loop
The_Tag := Parent_Tag (The_Tag);
Offset := RC_Offset (The_Tag);
end loop;
if Offset = 0 then
return null;
elsif Offset > 0 then
return To_RC_Ptr (Obj + Offset);
else
declare
type Faked_Record_Controller is record
Tag, Prec, Next : Address;
end record;
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;
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;
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
while P /= null loop
Q := P.Next;
begin
Finalize (P.all);
exception
when others => null;
end;
P := Q;
end loop;
if From_Abort then
null;
elsif Msg = "" then
Raise_Exception_No_Defer
(E => Program_Error'Identity,
Message => "exception " &
Exception_Name (E_Occ) &
" raised during finalization");
else
Raise_Exception_No_Defer (Program_Error'Identity, Msg);
end if;
end Raise_From_Finalize;
begin
SSL.Adafinal := Finalize_Global_List'Access;
end System.Finalization_Implementation;