1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- SYSTEM.STORAGE_POOLS.SUBPOOLS.FINALIZATION -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2011-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Unchecked_Deallocation; 33 34with System.Finalization_Masters; use System.Finalization_Masters; 35 36package body System.Storage_Pools.Subpools.Finalization is 37 38 ----------------------------- 39 -- Finalize_And_Deallocate -- 40 ----------------------------- 41 42 procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is 43 procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr); 44 45 begin 46 -- Do nothing if the subpool was never created or never used. The latter 47 -- case may arise with an array of subpool implementations. 48 49 if Subpool = null 50 or else Subpool.Owner = null 51 or else Subpool.Node = null 52 then 53 return; 54 end if; 55 56 -- Clean up all controlled objects chained on the subpool's master 57 58 Finalize (Subpool.Master); 59 60 -- Remove the subpool from its owner's list of subpools 61 62 Detach (Subpool.Node); 63 64 -- Destroy the associated doubly linked list node which was created in 65 -- Set_Pool_Of_Subpools. 66 67 Free (Subpool.Node); 68 69 -- Dispatch to the user-defined implementation of Deallocate_Subpool. It 70 -- is important to first set Subpool.Owner to null, because RM-13.11.5 71 -- requires that "The subpool no longer belongs to any pool" BEFORE 72 -- calling Deallocate_Subpool. The actual dispatching call required is: 73 -- 74 -- Deallocate_Subpool(Pool_Of_Subpool(Subpool).all, Subpool); 75 -- 76 -- but that can't be taken literally, because Pool_Of_Subpool will 77 -- return null. 78 79 declare 80 Owner : constant Any_Storage_Pool_With_Subpools_Ptr := Subpool.Owner; 81 begin 82 Subpool.Owner := null; 83 Deallocate_Subpool (Owner.all, Subpool); 84 end; 85 86 Subpool := null; 87 end Finalize_And_Deallocate; 88 89end System.Storage_Pools.Subpools.Finalization; 90