------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M . P O O L _ L O C A L -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2002, 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- 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. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with System.Memory; with System.Storage_Elements; with Unchecked_Conversion; package body System.Pool_Local is package SSE renames System.Storage_Elements; use type SSE.Storage_Offset; Pointer_Size : constant SSE.Storage_Offset := Address'Size / Storage_Unit; Pointers_Size : constant SSE.Storage_Offset := 2 * Pointer_Size; type Acc_Address is access all Address; function To_Acc_Address is new Unchecked_Conversion (Address, Acc_Address); ----------------------- -- Local Subprograms -- ----------------------- function Next (A : Address) return Acc_Address; pragma Inline (Next); -- Given an address of a block, return an access to the next block function Prev (A : Address) return Acc_Address; pragma Inline (Prev); -- Given an address of a block, return an access to the previous block -------------- -- Allocate -- -------------- procedure Allocate (Pool : in out Unbounded_Reclaim_Pool; Address : out System.Address; Storage_Size : SSE.Storage_Count; Alignment : SSE.Storage_Count) is pragma Warnings (Off, Alignment); Allocated : constant System.Address := Memory.Alloc (Memory.size_t (Storage_Size + Pointers_Size)); begin -- The call to Alloc returns an address whose alignment is compatible -- with the worst case alignment requirement for the machine; thus the -- Alignment argument can be safely ignored. if Allocated = Null_Address then raise Storage_Error; else Address := Allocated + Pointers_Size; Next (Allocated).all := Pool.First; Prev (Allocated).all := Null_Address; if Pool.First /= Null_Address then Prev (Pool.First).all := Allocated; end if; Pool.First := Allocated; end if; end Allocate; ---------------- -- Deallocate -- ---------------- procedure Deallocate (Pool : in out Unbounded_Reclaim_Pool; Address : System.Address; Storage_Size : SSE.Storage_Count; Alignment : SSE.Storage_Count) is pragma Warnings (Off, Storage_Size); pragma Warnings (Off, Alignment); Allocated : constant System.Address := Address - Pointers_Size; begin if Prev (Allocated).all = Null_Address then Pool.First := Next (Allocated).all; Prev (Pool.First).all := Null_Address; else Next (Prev (Allocated).all).all := Next (Allocated).all; end if; if Next (Allocated).all /= Null_Address then Prev (Next (Allocated).all).all := Prev (Allocated).all; end if; Memory.Free (Allocated); end Deallocate; -------------- -- Finalize -- -------------- procedure Finalize (Pool : in out Unbounded_Reclaim_Pool) is N : System.Address := Pool.First; Allocated : System.Address; begin while N /= Null_Address loop Allocated := N; N := Next (N).all; Memory.Free (Allocated); end loop; end Finalize; ---------- -- Next -- ---------- function Next (A : Address) return Acc_Address is begin return To_Acc_Address (A); end Next; ---------- -- Prev -- ---------- function Prev (A : Address) return Acc_Address is begin return To_Acc_Address (A + Pointer_Size); end Prev; end System.Pool_Local;