From mboxrd@z Thu Jan 1 00:00:00 1970 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me X-Spam-Level: X-Spam-Status: No, score=0.6 required=5.0 tests=BAYES_00,FROM_WORDY, T_FILL_THIS_FORM_SHORT autolearn=no autolearn_force=no version=3.4.4 X-Google-Language: ENGLISH,ASCII-7-bit X-Google-Thread: 103376,d43feef35662cdd7,start X-Google-Attributes: gid103376,public From: Stephen Leake Subject: deallocating class-wide objects Date: 1998/07/06 Message-ID: X-Deja-AN: 368947227 Organization: NASA Goddard Space Flight Center -- Greenbelt, Maryland USA Newsgroups: comp.lang.ada Date: 1998-07-06T00:00:00+00:00 List-Id: When I run the code below (compiled with GNAT 3.10p, Windows NT 4.0), I get the following output (the Test_Storage_Pools package just adds debug statments to 'new' and 'free') : ./test_allocate.exe allocating 12 from Puppet_Storage_Pool deallocating 4 from Puppet_Storage_Pool allocating 8 from Puppet_Storage_Pool deallocating 4 from Puppet_Storage_Pool allocating 12 from Muppet_Storage_Pool deallocating 12 from Muppet_Storage_Pool The first two cases are wrong; it should deallocate the same amount it allocates. It appears that GNAT is deallocating just enough for the root type, rather than for the derived type. The third case deallocates the derived type directly, and works as expected. I can't bring myself to believe that GNAT has a bug this basic at this stage in the game. On the other hand, ObjectAda won't even compile this code (bug report in the works). Can anyone confirm that GNAT is wrong, or am I doing something erroneous? -- Stephe. with Ada.Text_IO; use Ada.Text_IO; with Ada.Unchecked_Deallocation; with Test_Storage_Pools; procedure Test_Allocate is type Puppet_Type is abstract tagged null record; type Puppet_Access_Type is access Puppet_Type'Class; Puppet_Storage_Pool_Name : aliased String := "Puppet_Storage_Pool"; Puppet_Storage_Pool : Test_Storage_Pools.Storage_Pool_Type (1000, Puppet_Storage_Pool_Name'access); for Puppet_Access_Type'Storage_Pool use Puppet_Storage_Pool; procedure Free_Puppet is new Ada.Unchecked_Deallocation (Puppet_Type'Class, Puppet_Access_Type); Muppet_Storage_Pool_Name : aliased String := "Muppet_Storage_Pool"; Muppet_Storage_Pool : Test_Storage_Pools.Storage_Pool_Type (1000, Muppet_Storage_Pool_Name'access); type Muppet_Type is new Puppet_Type with record Arms : Integer; Fingers : Integer; end record; type Muppet_Access_Type is access Muppet_Type'Class; for Muppet_Access_Type'Storage_Pool use Muppet_Storage_Pool; procedure Free_Muppet is new Ada.Unchecked_Deallocation (Muppet_Type'Class, Muppet_Access_Type); type Beanie_Type is new Puppet_Type with record Legs : Integer; end record; Puppet_1 : Puppet_Access_Type; Puppet_2 : Puppet_Access_Type; Muppet_3 : Muppet_Access_Type; begin Test_Storage_Pools.Set_Debug (Puppet_Storage_Pool, True); Test_Storage_Pools.Set_Debug (Muppet_Storage_Pool, True); Puppet_1 := new Muppet_Type'(2, 5); Free_Puppet (Puppet_1); New_Line; Puppet_2 := new Beanie_Type'(Legs => 4); Free_Puppet (Puppet_2); New_Line; Muppet_3 := new Muppet_Type'(3, 4); Free_Muppet (Muppet_3); end Test_Allocate; with Ada.Text_IO; with System.Address_To_Access_Conversions; with Ada.Exceptions; package body Test_Storage_Pools is Block_Header_Size : constant System.Storage_Elements.Storage_Count := System.Storage_Elements.Storage_Count (Block_Header_Type'Size / System.Storage_Elements.Storage_Element'Size); -- This would be cleaner if Address_To_Access_Conversions took the -- pointer type as parameter, instead of declaring it! package Address_To_Block_Access is new System.Address_To_Access_Conversions (Block_Header_Type); function To_Block_Access (Address : in System.Address) return Block_Access_Type is begin return Block_Access_Type (Address_To_Block_Access.To_Pointer (Address)); end To_Block_Access; function To_Address (Value : in Block_Access_Type) return System.Address is begin return Address_To_Block_Access.To_Address (Address_To_Block_Access.Object_Pointer (Value)); end To_Address; function Aligned_Address (Address : in System.Address; Alignment : in System.Storage_Elements.Storage_Count) return System.Address -- Adjust Address upwards to next Alignment. is use System.Storage_Elements; Aligned : Integer_Address := To_Integer (Address) + To_Integer (Address) rem Integer_Address (Alignment); begin return To_Address (Aligned); end Aligned_Address; ----------- -- Override Root_Storage_Pool operations procedure Allocate (Pool : in out Storage_Pool_Type; Storage_Address : out System.Address; Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count) is use System.Storage_Elements; use Ada.Exceptions; Block : Block_Access_Type := Pool.First_Free; Remaining_Block : Block_Access_Type; Aligned : System.Address; Prev : Block_Access_Type := null; begin if Pool.Debug then Ada.Text_Io.Put_Line ("allocating " & Storage_Count'Image (Size_In_Storage_Elements) & " from " & Pool.Name.all); end if; if Size_In_Storage_Elements < Block_Header_Size then Raise_Exception (Storage_Error'Identity, "Allocate: block size < header size"); end if; Find_Free_Fit : loop if Block = null then Raise_Exception (Storage_Error'Identity, "Allocate: pool full (or fragmented)"); end if; exit Find_Free_Fit when Block.Size >= Size_In_Storage_Elements; Prev := Block; Block := Block.Next; end loop Find_Free_Fit; Aligned := Aligned_Address (Address => To_Address (Block) + Size_In_Storage_Elements, Alignment => 8); if To_Integer (Aligned) + Integer_Address (Block_Header_Size) < To_Integer (To_Address (Block)) + Integer_Address (Block.Size) then Remaining_Block := To_Block_Access (Aligned); if Prev = null then -- Allocated from first free block. Pool.First_Free := Remaining_Block; else Prev.Next := Remaining_Block; end if; Remaining_Block.all := (Size => Block.Size - Size_In_Storage_Elements, Next => Block.Next); else -- Remaining space too small for a block. -- Just link to next free block. if Prev = null then -- Allocated from first free block. Pool.First_Free := Pool.First_Free.Next; else Prev.Next := Block.Next; end if; end if; Storage_Address := To_Address (Block); end Allocate; procedure Deallocate (Pool : in out Storage_Pool_Type; Storage_Address : in System.Address; Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count) is use System.Storage_Elements; Block : Block_Access_Type := To_Block_Access (Storage_Address); begin if Pool.Debug then Ada.Text_Io.Put_Line ("deallocating" & Storage_Count'Image (Size_In_Storage_Elements) & " from " & Pool.Name.all); end if; -- Add block to head of free list Block.all := (Size => Size_In_Storage_Elements, Next => Pool.First_Free); Pool.First_Free := Block; end Deallocate; function Storage_Size (Pool : Storage_Pool_Type) return System.Storage_Elements.Storage_Count is begin return Pool.Pool_Size; end Storage_Size; ----------- -- New operations procedure Set_Debug (Pool : in out Storage_Pool_Type; Debug : in Boolean) is begin Pool.Debug := Debug; end Set_Debug; procedure Initialize (Pool : in out Storage_Pool_Type) is use type System.Storage_Elements.Storage_Offset; use Ada.Exceptions; begin if Pool.Pool_Size < Block_Header_Size then Raise_Exception (Storage_Error'Identity, "Initialize: pool_size < header_size"); end if; Pool.Debug := False; Pool.First_Free := To_Block_Access (Aligned_Address (Address => Pool.Storage'Address, Alignment => 8)); Pool.First_Free.all := (Pool.Pool_Size, null); end Initialize; end Test_Storage_Pools; with System.Storage_Pools; with System.Storage_Elements; package Test_Storage_Pools is type Storage_Pool_Type (Pool_Size : System.Storage_Elements.Storage_Count; Name : access String) -- for debug messages is new System.Storage_Pools.Root_Storage_Pool with private; ----------- -- Override Root_Storage_Pool operations procedure Allocate (Pool : in out Storage_Pool_Type; Storage_Address : out System.Address; Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count); procedure Deallocate (Pool : in out Storage_Pool_Type; Storage_Address : in System.Address; Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count); function Storage_Size (Pool : in Storage_Pool_Type) return System.Storage_Elements.Storage_Count; ----------- -- New operations procedure Set_Debug (Pool : in out Storage_Pool_Type; Debug : in Boolean); -- If Debug is True, Allocate and Deallocate print helpful messages to -- Standard_Output. private procedure Initialize (Pool : in out Storage_Pool_Type); type Block_Header_Type; type Block_Access_Type is access all Block_Header_Type; type Block_Header_Type is record Size : System.Storage_Elements.Storage_Count; Next : Block_Access_Type; end record; type Storage_Pool_Type (Pool_Size : System.Storage_Elements.Storage_Count; Name : access String) is new System.Storage_Pools.Root_Storage_Pool with record Debug : Boolean; First_Free : Block_Access_Type; Storage : System.Storage_Elements.Storage_Array (1 .. Pool_Size); -- The first few elements of each free block contain the block header. -- Storage_Error is raised if a free block is smaller than the -- block header size. -- All blocks have alignment 8, to keep things simple. end record; end Test_Storage_Pools;