File : s-memory-xi.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                         S Y S T E M . M E M O R Y                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2010, 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 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  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 
  32 --  This is the simplified implementation of this package, for use with a
  33 --  configurable run-time library.
  34 
  35 --  This implementation assumes that the underlying malloc/free/realloc
  36 --  implementation is *not* thread safe, and thus, explicit lock is required.
  37 
  38 with Ada.Exceptions;
  39 
  40 with System.Soft_Links;
  41 
  42 package body System.Memory is
  43 
  44    use Ada.Exceptions;
  45    use System.Soft_Links;
  46 
  47    function c_malloc (Size : size_t) return System.Address;
  48    pragma Import (C, c_malloc, "malloc");
  49 
  50    procedure c_free (Ptr : System.Address);
  51    pragma Import (C, c_free, "free");
  52 
  53    function c_realloc
  54      (Ptr : System.Address; Size : size_t) return System.Address;
  55    pragma Import (C, c_realloc, "realloc");
  56 
  57    -----------
  58    -- Alloc --
  59    -----------
  60 
  61    function Alloc (Size : size_t) return System.Address is
  62       Result      : System.Address;
  63       Actual_Size : size_t := Size;
  64 
  65    begin
  66       if Size = size_t'Last then
  67          Raise_Exception (Storage_Error'Identity, "object too large");
  68       end if;
  69 
  70       --  Change size from zero to non-zero. We still want a proper pointer
  71       --  for the zero case because pointers to zero length objects have to
  72       --  be distinct, but we can't just go ahead and allocate zero bytes,
  73       --  since some malloc's return zero for a zero argument.
  74 
  75       if Size = 0 then
  76          Actual_Size := 1;
  77       end if;
  78 
  79       Lock_Task.all;
  80 
  81       Result := c_malloc (Actual_Size);
  82 
  83       Unlock_Task.all;
  84 
  85       if Result = System.Null_Address then
  86          Raise_Exception (Storage_Error'Identity, "heap exhausted");
  87       end if;
  88 
  89       return Result;
  90    end Alloc;
  91 
  92    ----------
  93    -- Free --
  94    ----------
  95 
  96    procedure Free (Ptr : System.Address) is
  97    begin
  98       Lock_Task.all;
  99 
 100       c_free (Ptr);
 101 
 102       Unlock_Task.all;
 103    end Free;
 104 
 105    -------------
 106    -- Realloc --
 107    -------------
 108 
 109    function Realloc
 110      (Ptr  : System.Address;
 111       Size : size_t)
 112      return System.Address
 113    is
 114       Result : System.Address;
 115 
 116    begin
 117       if Size = size_t'Last then
 118          Raise_Exception (Storage_Error'Identity, "object too large");
 119       end if;
 120 
 121       Lock_Task.all;
 122 
 123       Result := c_realloc (Ptr, Size);
 124 
 125       Unlock_Task.all;
 126 
 127       if Result = System.Null_Address then
 128          Raise_Exception (Storage_Error'Identity, "heap exhausted");
 129       end if;
 130 
 131       return Result;
 132    end Realloc;
 133 
 134 end System.Memory;