1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . M E M O R Y --
9 -- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- This is the default implementation of this package
34 -- This implementation assumes that the underlying malloc/free/realloc
35 -- implementation is thread safe, and thus, no additional lock is required.
36 -- Note that we still need to defer abort because on most systems, an
37 -- asynchronous signal (as used for implementing asynchronous abort of
38 -- task) cannot safely be handled while malloc is executing.
40 -- If you are not using Ada constructs containing the "abort" keyword, then
41 -- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from
44 pragma Compiler_Unit_Warning
;
47 with System
.Parameters
;
48 with System
.Soft_Links
;
50 package body System
.Memory
is
52 use System
.Soft_Links
;
54 function c_malloc
(Size
: System
.CRTL
.size_t
) return System
.Address
55 renames System
.CRTL
.malloc
;
57 procedure c_free
(Ptr
: System
.Address
)
58 renames System
.CRTL
.free
;
61 (Ptr
: System
.Address
; Size
: System
.CRTL
.size_t
) return System
.Address
62 renames System
.CRTL
.realloc
;
68 function Alloc
(Size
: size_t
) return System
.Address
is
69 Result
: System
.Address
;
71 if Parameters
.No_Abort
then
72 Result
:= c_malloc
(System
.CRTL
.size_t
(Size
));
75 Result
:= c_malloc
(System
.CRTL
.size_t
(Size
));
79 if Result
= System
.Null_Address
then
80 -- If Size = 0, we can't allocate 0 bytes, because then two different
81 -- allocators, one of which has Size = 0, could return pointers that
82 -- compare equal, which is wrong. (Nonnull pointers compare equal if
83 -- and only if they designate the same object, and two different
84 -- allocators allocate two different objects).
86 -- malloc(0) is defined to allocate a non-zero-sized object (in which
87 -- case we won't get here, and all is well) or NULL, in which case we
88 -- get here. We also get here in case of error. So check for the
89 -- zero-size case, and allocate 1 byte. Otherwise, raise
92 -- We check for zero size here, rather than at the start, for
99 if Size
= size_t
'Last then
100 raise Storage_Error
with "object too large";
103 raise Storage_Error
with "heap exhausted";
113 procedure Free
(Ptr
: System
.Address
) is
115 if Parameters
.No_Abort
then
129 (Ptr
: System
.Address
;
131 return System
.Address
133 Result
: System
.Address
;
135 if Parameters
.No_Abort
then
136 Result
:= c_realloc
(Ptr
, System
.CRTL
.size_t
(Size
));
139 Result
:= c_realloc
(Ptr
, System
.CRTL
.size_t
(Size
));
143 if Result
= System
.Null_Address
then
144 if Size
= size_t
'Last then
145 raise Storage_Error
with "object too large";
148 raise Storage_Error
with "heap exhausted";