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-2015, 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 limited length (including the terminator) 155 156 L := 0; 157 while L < Limit loop 158 L := L + 1; 159 exit when S.all = Terminator; 160 Increment (S); 161 end loop; 162 163 Copy_Array (Source, Target, L); 164 end Copy_Terminated_Array; 165 166 --------------- 167 -- Decrement -- 168 --------------- 169 170 procedure Decrement (Ref : in out Pointer) is 171 begin 172 Ref := Ref - 1; 173 end Decrement; 174 175 --------------- 176 -- Increment -- 177 --------------- 178 179 procedure Increment (Ref : in out Pointer) is 180 begin 181 Ref := Ref + 1; 182 end Increment; 183 184 ----------- 185 -- Value -- 186 ----------- 187 188 function Value 189 (Ref : Pointer; 190 Terminator : Element := Default_Terminator) return Element_Array 191 is 192 P : Pointer; 193 L : constant Index_Base := Index'First; 194 H : Index_Base; 195 196 begin 197 if Ref = null then 198 raise Dereference_Error; 199 200 else 201 H := L; 202 P := Ref; 203 204 loop 205 exit when P.all = Terminator; 206 H := Index_Base'Succ (H); 207 Increment (P); 208 end loop; 209 210 declare 211 subtype A is Element_Array (L .. H); 212 213 type PA is access A; 214 for PA'Size use System.Parameters.ptr_bits; 215 function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); 216 217 begin 218 return To_PA (Ref).all; 219 end; 220 end if; 221 end Value; 222 223 function Value 224 (Ref : Pointer; 225 Length : ptrdiff_t) return Element_Array 226 is 227 L : Index_Base; 228 H : Index_Base; 229 230 begin 231 if Ref = null then 232 raise Dereference_Error; 233 234 -- For length zero, we need to return a null slice, but we can't make 235 -- the bounds of this slice Index'First, since this could cause a 236 -- Constraint_Error if Index'First = Index'Base'First. 237 238 elsif Length <= 0 then 239 declare 240 pragma Warnings (Off); -- kill warnings since X not assigned 241 X : Element_Array (Index'Succ (Index'First) .. Index'First); 242 pragma Warnings (On); 243 244 begin 245 return X; 246 end; 247 248 -- Normal case (length non-zero) 249 250 else 251 L := Index'First; 252 H := Index'Val (Index'Pos (Index'First) + Length - 1); 253 254 declare 255 subtype A is Element_Array (L .. H); 256 257 type PA is access A; 258 for PA'Size use System.Parameters.ptr_bits; 259 function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); 260 261 begin 262 return To_PA (Ref).all; 263 end; 264 end if; 265 end Value; 266 267 -------------------- 268 -- Virtual_Length -- 269 -------------------- 270 271 function Virtual_Length 272 (Ref : Pointer; 273 Terminator : Element := Default_Terminator) return ptrdiff_t 274 is 275 P : Pointer; 276 C : ptrdiff_t; 277 278 begin 279 if Ref = null then 280 raise Dereference_Error; 281 282 else 283 C := 0; 284 P := Ref; 285 286 while P.all /= Terminator loop 287 C := C + 1; 288 Increment (P); 289 end loop; 290 291 return C; 292 end if; 293 end Virtual_Length; 294 295end Interfaces.C.Pointers; 296