-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
with Ada.Exceptions;
with Ada.Tags;
-with System.Storage_Elements;
with System.Soft_Links;
with Unchecked_Conversion;
package SSL renames System.Soft_Links;
- package SSE renames System.Storage_Elements;
use type SSE.Storage_Offset;
-----------------------
new Unchecked_Conversion (Address, RC_Ptr);
procedure Raise_Exception_No_Defer
- (E : in Exception_Id;
- Message : in String := "");
+ (E : Exception_Id;
+ Message : String := "");
pragma Import (Ada, Raise_Exception_No_Defer,
"ada__exceptions__raise_exception_no_defer");
pragma No_Return (Raise_Exception_No_Defer);
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;
-- Given the address (obj) of a tagged object, return a
-- pointer to the record controller of this object.
Nb_Link : Short_Short_Integer)
is
begin
- -- Simple case: attachement to a one way list
+ -- Simple case: attachment to a one way list
if Nb_Link = 1 then
Obj.Next := L;
-- Dynamically allocated objects: they are attached to a doubly linked
-- list, so that an element can be finalized at any moment by means of
- -- an unchecked deallocation. Attachement is protected against
+ -- an unchecked deallocation. Attachment is protected against
-- multi-threaded access.
elsif Nb_Link = 2 then
+ -- Raise Program_Error if we're trying to allocate an object in a
+ -- collection whose finalization has already started.
+
+ if L = Collection_Finalization_Started then
+ raise Program_Error with
+ "allocation after collection finalization started";
+ end if;
+
Locked_Processing : begin
SSL.Lock_Task.all;
Obj.Next := L.Next;
raise;
end Locked_Processing;
- -- Attachement 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,
-- 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.
P.Next := L;
L := Obj'Unchecked_Access;
end;
- end if;
- end Attach_To_Final_List;
- ---------------------
- -- Deep_Tag_Adjust --
- ---------------------
+ -- Make the object completely unattached (case of a library-level,
+ -- Finalize_Storage_Only object).
- 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);
+ elsif Nb_Link = 4 then
+ Obj.Prev := null;
+ Obj.Next := null;
end if;
-
- -- Is controlled
-
- if V.all in Finalizable then
- Adjust (V.all);
- Attach_To_Final_List (L, Finalizable (V.all), 1);
- end if;
- end Deep_Tag_Adjust;
+ end Attach_To_Final_List;
---------------------
-- Deep_Tag_Attach --
end if;
end Deep_Tag_Attach;
- -----------------------
- -- Deep_Tag_Finalize --
- -----------------------
-
- 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;
-
- -- Is controlled
-
- 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;
-
- -------------------------
- -- Deep_Tag_Initialize --
- -------------------------
-
- 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
- -- This procedure should not be called if the object has no
- -- controlled components
-
- if Controller = null then
- raise Program_Error;
-
- -- Has controlled components
-
- else
- Initialize (Controller.all);
- Attach_To_Final_List (L, Controller.all, B);
- end if;
-
- -- Is controlled
-
- 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;
-
-----------------------------
-- Detach_From_Final_List --
-----------------------------
procedure Finalize_Global_List is
begin
-- There are three case here:
+
-- a. the application uses tasks, in which case Finalize_Global_Tasks
- -- will defer abortion
+ -- will defer abort.
+
-- b. the application doesn't use tasks but uses other tasking
-- constructs, such as ATCs and protected objects. In this case,
-- the binder will call Finalize_Global_List instead of
-- Finalize_Global_Tasks, letting abort undeferred, and leading
-- to assertion failures in the GNULL
+
-- c. the application doesn't use any tasking construct in which case
-- deferring abort isn't necessary.
- --
+
-- 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
- -- undefer abortion, since Finalize_Global_List is the last procedure
+ -- undefer abort, since Finalize_Global_List is the last procedure
-- called before exiting the partition.
SSL.Abort_Defer.all;
-- programs using controlled types heavily.
if System.Restrictions.Abort_Allowed then
- X := To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
+ X := To_Ptr (SSL.Get_Current_Excep.all).Id;
end if;
while P /= null loop
-- when there are no controller at this level
while Offset = -2 loop
- The_Tag := Parent_Tag (The_Tag);
+ The_Tag := Ada.Tags.Parent_Tag (The_Tag);
Offset := RC_Offset (The_Tag);
end loop;
Object.My_Address := Object'Address;
end Initialize;
+ ---------------------
+ -- Move_Final_List --
+ ---------------------
+
+ procedure Move_Final_List
+ (From : in out SFR.Finalizable_Ptr;
+ To : Finalizable_Ptr_Ptr)
+ is
+ begin
+ -- 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
+ -- mangling the finalization lists.
+
+ SSL.Abort_Defer.all;
+
+ -- Put the return statement's finalization list onto the caller's one,
+ -- thus transferring responsibility for finalization of the return
+ -- object to the caller.
+
+ Attach_To_Final_List (To.all, From.all, Nb_Link => 3);
+
+ -- Empty the return statement's finalization list, so that when the
+ -- cleanup code executes, there will be nothing to finalize.
+ From := null;
+
+ SSL.Abort_Undefer.all;
+ end Move_Final_List;
+
-------------------------
-- Raise_From_Finalize --
-------------------------
-- Initialization of package, set Adafinal soft link
begin
- SSL.Adafinal := Finalize_Global_List'Access;
+ SSL.Finalize_Global_List := Finalize_Global_List'Access;
end System.Finalization_Implementation;
OSDN Git Service
