-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
with System.Soft_Links;
with Unchecked_Conversion;
+with System.Restrictions;
package body System.Finalization_Implementation is
-- Start of processing for Adjust
begin
- -- Adjust the components and their finalization pointers next.
- -- We must protect against an exception in some call to Adjust, so
- -- we keep pointing to the list of successfully adjusted components,
- -- which can be finalized if an exception is raised.
+ -- Adjust the components and their finalization pointers next. We must
+ -- protect against an exception in some call to Adjust, so we keep
+ -- pointing to the list of successfully adjusted components, which can
+ -- be finalized if an exception is raised.
First_Comp := Object.F;
Object.F := null; -- nothing adjusted yet.
when others =>
-- Finalize those components that were successfully adjusted, and
-- propagate exception. The object itself is not yet attached to
- -- global finalization list, so we cannot rely on the outer call
- -- to Clean to take care of these components.
+ -- global finalization list, so we cannot rely on the outer call to
+ -- Clean to take care of these components.
Finalize (Object);
raise;
Obj.Next := L;
L := Obj'Unchecked_Access;
- -- 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 multi-threaded access.
+ -- 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
+ -- multi-threaded access.
elsif Nb_Link = 2 then
procedure Detach_From_Final_List (Obj : in out Finalizable) is
begin
- -- 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 dealing with Finalize_Storage_Only objects
- -- which are not always attached.
+ -- 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
+ -- dealing with Finalize_Storage_Only objects which are not always
+ -- attached to the finalization list.
if Obj.Next /= null and then Obj.Prev /= null then
SSL.Lock_Task.all;
end record;
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
- Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
+ Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
- X : constant Exception_Id :=
- To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
+ X : Exception_Id := Null_Id;
begin
+ -- 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
+ -- exception is raised. When abort is not allowed, avoid accessing the
+ -- current exception since this can be a pretty costly operation in
+ -- programs using controlled types heavily.
+
+ 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);
begin
Detach_From_Final_List (Obj);
Finalize (Obj);
-
exception
when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
end Finalize_One;
Offset : SSE.Storage_Offset := RC_Offset (The_Tag);
begin
-
-- Fetch the controller from the Parent or above if necessary
-- when there are no controller at this level
-- 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.
+
+ -- ??? note that it may not be true if there are new discriminants
else -- Offset = -1
procedure Initialize (Object : in out Limited_Record_Controller) is
pragma Warnings (Off, Object);
-
begin
null;
end Initialize;