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-2013, 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
32--  This is the VMS 64 bit implementation of this package
33
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.
39
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
42--  this unit.
43
44pragma Compiler_Unit_Warning;
45
46with Ada.Exceptions;
47with System.Soft_Links;
48with System.Parameters;
49with System.CRTL;
50
51package body System.Memory is
52
53   use Ada.Exceptions;
54   use System.Soft_Links;
55
56   function c_malloc (Size : System.CRTL.size_t) return System.Address
57    renames System.CRTL.malloc;
58
59   procedure c_free (Ptr : System.Address)
60     renames System.CRTL.free;
61
62   function c_realloc
63     (Ptr : System.Address; Size : System.CRTL.size_t) return System.Address
64     renames System.CRTL.realloc;
65
66   Gnat_Heap_Size : Integer;
67   pragma Import (C, Gnat_Heap_Size, "__gl_heap_size");
68   --  Set by Feature logical GNAT$NO_MALLOC_64 and/or Binder switch -Hnn
69
70   -----------
71   -- Alloc --
72   -----------
73
74   function Alloc (Size : size_t) return System.Address is
75      Result      : System.Address;
76      Actual_Size : size_t := Size;
77
78   begin
79      if Gnat_Heap_Size = 32 then
80         return Alloc32 (Size);
81      end if;
82
83      if Size = size_t'Last then
84         Raise_Exception (Storage_Error'Identity, "object too large");
85      end if;
86
87      --  Change size from zero to non-zero. We still want a proper pointer
88      --  for the zero case because pointers to zero length objects have to
89      --  be distinct, but we can't just go ahead and allocate zero bytes,
90      --  since some malloc's return zero for a zero argument.
91
92      if Size = 0 then
93         Actual_Size := 1;
94      end if;
95
96      if Parameters.No_Abort then
97         Result := c_malloc (System.CRTL.size_t (Actual_Size));
98      else
99         Abort_Defer.all;
100         Result := c_malloc (System.CRTL.size_t (Actual_Size));
101         Abort_Undefer.all;
102      end if;
103
104      if Result = System.Null_Address then
105         Raise_Exception (Storage_Error'Identity, "heap exhausted");
106      end if;
107
108      return Result;
109   end Alloc;
110
111   -------------
112   -- Alloc32 --
113   -------------
114
115   function Alloc32 (Size : size_t) return System.Address is
116      Result      : System.Address;
117      Actual_Size : size_t := Size;
118
119   begin
120      if Size = size_t'Last then
121         Raise_Exception (Storage_Error'Identity, "object too large");
122      end if;
123
124      --  Change size from zero to non-zero. We still want a proper pointer
125      --  for the zero case because pointers to zero length objects have to
126      --  be distinct, but we can't just go ahead and allocate zero bytes,
127      --  since some malloc's return zero for a zero argument.
128
129      if Size = 0 then
130         Actual_Size := 1;
131      end if;
132
133      if Parameters.No_Abort then
134         Result := C_malloc32 (Actual_Size);
135      else
136         Abort_Defer.all;
137         Result := C_malloc32 (Actual_Size);
138         Abort_Undefer.all;
139      end if;
140
141      if Result = System.Null_Address then
142         Raise_Exception (Storage_Error'Identity, "heap exhausted");
143      end if;
144
145      return Result;
146   end Alloc32;
147
148   ----------
149   -- Free --
150   ----------
151
152   procedure Free (Ptr : System.Address) is
153   begin
154      if Parameters.No_Abort then
155         c_free (Ptr);
156      else
157         Abort_Defer.all;
158         c_free (Ptr);
159         Abort_Undefer.all;
160      end if;
161   end Free;
162
163   -------------
164   -- Realloc --
165   -------------
166
167   function Realloc
168     (Ptr  : System.Address;
169      Size : size_t)
170      return System.Address
171   is
172      Result      : System.Address;
173      Actual_Size : constant size_t := Size;
174
175   begin
176      if Gnat_Heap_Size = 32 then
177         return Realloc32 (Ptr, Size);
178      end if;
179
180      if Size = size_t'Last then
181         Raise_Exception (Storage_Error'Identity, "object too large");
182      end if;
183
184      if Parameters.No_Abort then
185         Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
186      else
187         Abort_Defer.all;
188         Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
189         Abort_Undefer.all;
190      end if;
191
192      if Result = System.Null_Address then
193         Raise_Exception (Storage_Error'Identity, "heap exhausted");
194      end if;
195
196      return Result;
197   end Realloc;
198
199   ---------------
200   -- Realloc32 --
201   ---------------
202
203   function Realloc32
204     (Ptr  : System.Address;
205      Size : size_t)
206      return System.Address
207   is
208      Result      : System.Address;
209      Actual_Size : constant size_t := Size;
210
211   begin
212      if Size = size_t'Last then
213         Raise_Exception (Storage_Error'Identity, "object too large");
214      end if;
215
216      if Parameters.No_Abort then
217         Result := C_realloc32 (Ptr, Actual_Size);
218      else
219         Abort_Defer.all;
220         Result := C_realloc32 (Ptr, Actual_Size);
221         Abort_Undefer.all;
222      end if;
223
224      if Result = System.Null_Address then
225         Raise_Exception (Storage_Error'Identity, "heap exhausted");
226      end if;
227
228      return Result;
229   end Realloc32;
230end System.Memory;
231