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