1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- I N T E R F A C E S . C . P O I N T E R S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2014, 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 32with Interfaces.C.Strings; use Interfaces.C.Strings; 33with System; use System; 34 35with Ada.Unchecked_Conversion; 36 37package body Interfaces.C.Pointers is 38 39 type Addr is mod 2 ** System.Parameters.ptr_bits; 40 41 function To_Pointer is new Ada.Unchecked_Conversion (Addr, Pointer); 42 function To_Addr is new Ada.Unchecked_Conversion (Pointer, Addr); 43 function To_Addr is new Ada.Unchecked_Conversion (ptrdiff_t, Addr); 44 function To_Ptrdiff is new Ada.Unchecked_Conversion (Addr, ptrdiff_t); 45 46 Elmt_Size : constant ptrdiff_t := 47 (Element_Array'Component_Size 48 + Storage_Unit - 1) / Storage_Unit; 49 50 subtype Index_Base is Index'Base; 51 52 --------- 53 -- "+" -- 54 --------- 55 56 function "+" (Left : Pointer; Right : ptrdiff_t) return Pointer is 57 begin 58 if Left = null then 59 raise Pointer_Error; 60 end if; 61 62 return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right)); 63 end "+"; 64 65 function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer is 66 begin 67 if Right = null then 68 raise Pointer_Error; 69 end if; 70 71 return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right)); 72 end "+"; 73 74 --------- 75 -- "-" -- 76 --------- 77 78 function "-" (Left : Pointer; Right : ptrdiff_t) return Pointer is 79 begin 80 if Left = null then 81 raise Pointer_Error; 82 end if; 83 84 return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size)); 85 end "-"; 86 87 function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t is 88 begin 89 if Left = null or else Right = null then 90 raise Pointer_Error; 91 end if; 92 93 return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size; 94 end "-"; 95 96 ---------------- 97 -- Copy_Array -- 98 ---------------- 99 100 procedure Copy_Array 101 (Source : Pointer; 102 Target : Pointer; 103 Length : ptrdiff_t) 104 is 105 T : Pointer; 106 S : Pointer; 107 108 begin 109 if Source = null or else Target = null then 110 raise Dereference_Error; 111 112 -- Forward copy 113 114 elsif To_Addr (Target) <= To_Addr (Source) then 115 T := Target; 116 S := Source; 117 for J in 1 .. Length loop 118 T.all := S.all; 119 Increment (T); 120 Increment (S); 121 end loop; 122 123 -- Backward copy 124 125 else 126 T := Target + Length; 127 S := Source + Length; 128 for J in 1 .. Length loop 129 Decrement (T); 130 Decrement (S); 131 T.all := S.all; 132 end loop; 133 end if; 134 end Copy_Array; 135 136 --------------------------- 137 -- Copy_Terminated_Array -- 138 --------------------------- 139 140 procedure Copy_Terminated_Array 141 (Source : Pointer; 142 Target : Pointer; 143 Limit : ptrdiff_t := ptrdiff_t'Last; 144 Terminator : Element := Default_Terminator) 145 is 146 L : ptrdiff_t; 147 S : Pointer := Source; 148 149 begin 150 if Source = null or Target = null then 151 raise Dereference_Error; 152 end if; 153 154 -- Compute array length (including the terminator) 155 156 L := 1; 157 while S.all /= Terminator and then L < Limit loop 158 L := L + 1; 159 Increment (S); 160 end loop; 161 162 Copy_Array (Source, Target, L); 163 end Copy_Terminated_Array; 164 165 --------------- 166 -- Decrement -- 167 --------------- 168 169 procedure Decrement (Ref : in out Pointer) is 170 begin 171 Ref := Ref - 1; 172 end Decrement; 173 174 --------------- 175 -- Increment -- 176 --------------- 177 178 procedure Increment (Ref : in out Pointer) is 179 begin 180 Ref := Ref + 1; 181 end Increment; 182 183 ----------- 184 -- Value -- 185 ----------- 186 187 function Value 188 (Ref : Pointer; 189 Terminator : Element := Default_Terminator) return Element_Array 190 is 191 P : Pointer; 192 L : constant Index_Base := Index'First; 193 H : Index_Base; 194 195 begin 196 if Ref = null then 197 raise Dereference_Error; 198 199 else 200 H := L; 201 P := Ref; 202 203 loop 204 exit when P.all = Terminator; 205 H := Index_Base'Succ (H); 206 Increment (P); 207 end loop; 208 209 declare 210 subtype A is Element_Array (L .. H); 211 212 type PA is access A; 213 for PA'Size use System.Parameters.ptr_bits; 214 function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); 215 216 begin 217 return To_PA (Ref).all; 218 end; 219 end if; 220 end Value; 221 222 function Value 223 (Ref : Pointer; 224 Length : ptrdiff_t) return Element_Array 225 is 226 L : Index_Base; 227 H : Index_Base; 228 229 begin 230 if Ref = null then 231 raise Dereference_Error; 232 233 -- For length zero, we need to return a null slice, but we can't make 234 -- the bounds of this slice Index'First, since this could cause a 235 -- Constraint_Error if Index'First = Index'Base'First. 236 237 elsif Length <= 0 then 238 declare 239 pragma Warnings (Off); -- kill warnings since X not assigned 240 X : Element_Array (Index'Succ (Index'First) .. Index'First); 241 pragma Warnings (On); 242 243 begin 244 return X; 245 end; 246 247 -- Normal case (length non-zero) 248 249 else 250 L := Index'First; 251 H := Index'Val (Index'Pos (Index'First) + Length - 1); 252 253 declare 254 subtype A is Element_Array (L .. H); 255 256 type PA is access A; 257 for PA'Size use System.Parameters.ptr_bits; 258 function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); 259 260 begin 261 return To_PA (Ref).all; 262 end; 263 end if; 264 end Value; 265 266 -------------------- 267 -- Virtual_Length -- 268 -------------------- 269 270 function Virtual_Length 271 (Ref : Pointer; 272 Terminator : Element := Default_Terminator) return ptrdiff_t 273 is 274 P : Pointer; 275 C : ptrdiff_t; 276 277 begin 278 if Ref = null then 279 raise Dereference_Error; 280 281 else 282 C := 0; 283 P := Ref; 284 285 while P.all /= Terminator loop 286 C := C + 1; 287 Increment (P); 288 end loop; 289 290 return C; 291 end if; 292 end Virtual_Length; 293 294end Interfaces.C.Pointers; 295