-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
with Ada.Tags;
-with Ada.Unchecked_Conversion;
+
with System.Storage_Elements;
with System.Soft_Links;
+with Unchecked_Conversion;
+
package body System.Finalization_Implementation is
use Ada.Exceptions;
-- Local Subprograms --
-----------------------
- function To_Finalizable_Ptr is
- new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);
-
- function To_Addr is
- new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);
-
type RC_Ptr is access all Record_Controller;
function To_RC_Ptr is
- new Ada.Unchecked_Conversion (Address, RC_Ptr);
+ new Unchecked_Conversion (Address, RC_Ptr);
procedure Raise_Exception_No_Defer
(E : in Exception_Id;
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) return SSE.Storage_Count;
+ function Parent_Size (Obj : Address; T : Ada.Tags.Tag)
+ return SSE.Storage_Count;
pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
- function Get_RC_Dynamically (Obj : Address) return Address;
- -- Given an the address of an object (obj) of a tagged extension with
- -- controlled component, computes the address of the record controller
- -- located just after the _parent field
+ 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 --
- -------------
+ ------------
+ -- Adjust --
+ ------------
procedure Adjust (Object : in out Record_Controller) is
Object.My_Address - Object'Address;
procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
- -- Subtract the offset to the pointer
+ -- Substract the offset to the pointer
procedure Reverse_Adjust (P : Finalizable_Ptr);
- -- Adjust the components in the reverse order in which they are stored
+ -- 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
end if;
end Ptr_Adjust;
+ --------------------
+ -- Reverse_Adjust --
+ --------------------
+
procedure Reverse_Adjust (P : Finalizable_Ptr) is
begin
if P /= null then
L := Obj'Unchecked_Access;
end;
end if;
-
end Attach_To_Final_List;
---------------------
A : System.Address;
B : Short_Short_Integer)
is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
- -- Has controlled components
-
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
+ if Controller /= null then
Adjust (Controller.all);
Attach_To_Final_List (L, Controller.all, B);
+ end if;
-- Is controlled
- elsif V.all in Finalizable then
+ if V.all in Finalizable then
Adjust (V.all);
Attach_To_Final_List (L, Finalizable (V.all), 1);
end if;
A : System.Address;
B : Short_Short_Integer)
is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
+ if Controller /= null then
Attach_To_Final_List (L, Controller.all, B);
+ end if;
-- Is controlled
- elsif V.all in Finalizable then
+ if V.all in Finalizable then
Attach_To_Final_List (L, V.all, B);
end if;
end Deep_Tag_Attach;
is
pragma Warnings (Off, L);
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
- -- Has controlled components
-
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
+ if Controller /= null then
if B then
Finalize_One (Controller.all);
else
Finalize (Controller.all);
end if;
+ end if;
-- Is controlled
- elsif V.all in Finalizable then
+ if V.all in Finalizable then
if B then
Finalize_One (V.all);
else
A : System.Address;
B : Short_Short_Integer)
is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ 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 Offset = 0 then
-
+ if Controller = null then
raise Program_Error;
-- Has controlled components
else
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
+ Initialize (Controller.all);
+ Attach_To_Final_List (L, Controller.all, B);
end if;
- Initialize (Controller.all);
- Attach_To_Final_List (L, Controller.all, B);
-
-- Is controlled
if V.all in Finalizable then
P : Finalizable_Ptr := L;
Q : Finalizable_Ptr;
- type Fake_Exception_Occurrence is record
+ type Fake_Exception_Occurence is record
Id : Exception_Id;
end record;
- type Ptr is access all Fake_Exception_Occurrence;
+ type Ptr is access all Fake_Exception_Occurence;
-- Let's get the current exception before starting to finalize in
-- order to check if we are in the abort case if an exception is
-- raised.
function To_Ptr is new
- Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
- X : Exception_Id :=
- To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
+ Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
+
+ X : constant Exception_Id :=
+ To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
begin
while P /= null loop
when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
end Finalize_One;
- ------------------------
- -- Get_RC_Dynamically --
- ------------------------
+ -------------------------
+ -- Get_Deep_Controller --
+ -------------------------
- function Get_RC_Dynamically (Obj : Address) return Address is
+ 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);
- -- define a faked record controller to avoid generating
- -- unnecessary expanded code for controlled types
+ begin
- type Faked_Record_Controller is record
- Tag, Prec, Next : Address;
- end record;
+ -- Fetch the controller from the Parent or above if necessary
+ -- when there are no controller at this level
- -- Reconstruction of a type with characteristics
- -- comparable to the original type
+ while Offset = -2 loop
+ The_Tag := Parent_Tag (The_Tag);
+ Offset := RC_Offset (The_Tag);
+ end loop;
- D : constant := Storage_Unit - 1;
+ -- No Controlled component case
- type Faked_Type_Of_Obj is record
- Parent : SSE.Storage_Array
- (1 .. (Parent_Size (Obj) + D) / Storage_Unit);
- Controller : Faked_Record_Controller;
- end record;
+ if Offset = 0 then
+ return null;
- type Obj_Ptr is access all Faked_Type_Of_Obj;
- function To_Obj_Ptr is new Ada.Unchecked_Conversion (Address, Obj_Ptr);
+ -- The _controller Offset is known statically
- begin
- return To_Obj_Ptr (Obj).Controller'Address;
- end Get_RC_Dynamically;
+ 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 --
OSDN Git Service
