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-2011, 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 := Target; 106 S : Pointer := Source; 107 108 begin 109 if S = null or else T = null then 110 raise Dereference_Error; 111 112 else 113 for J in 1 .. Length loop 114 T.all := S.all; 115 Increment (T); 116 Increment (S); 117 end loop; 118 end if; 119 end Copy_Array; 120 121 --------------------------- 122 -- Copy_Terminated_Array -- 123 --------------------------- 124 125 procedure Copy_Terminated_Array 126 (Source : Pointer; 127 Target : Pointer; 128 Limit : ptrdiff_t := ptrdiff_t'Last; 129 Terminator : Element := Default_Terminator) 130 is 131 S : Pointer := Source; 132 T : Pointer := Target; 133 L : ptrdiff_t := Limit; 134 135 begin 136 if S = null or else T = null then 137 raise Dereference_Error; 138 139 else 140 while L > 0 loop 141 T.all := S.all; 142 exit when T.all = Terminator; 143 Increment (T); 144 Increment (S); 145 L := L - 1; 146 end loop; 147 end if; 148 end Copy_Terminated_Array; 149 150 --------------- 151 -- Decrement -- 152 --------------- 153 154 procedure Decrement (Ref : in out Pointer) is 155 begin 156 Ref := Ref - 1; 157 end Decrement; 158 159 --------------- 160 -- Increment -- 161 --------------- 162 163 procedure Increment (Ref : in out Pointer) is 164 begin 165 Ref := Ref + 1; 166 end Increment; 167 168 ----------- 169 -- Value -- 170 ----------- 171 172 function Value 173 (Ref : Pointer; 174 Terminator : Element := Default_Terminator) return Element_Array 175 is 176 P : Pointer; 177 L : constant Index_Base := Index'First; 178 H : Index_Base; 179 180 begin 181 if Ref = null then 182 raise Dereference_Error; 183 184 else 185 H := L; 186 P := Ref; 187 188 loop 189 exit when P.all = Terminator; 190 H := Index_Base'Succ (H); 191 Increment (P); 192 end loop; 193 194 declare 195 subtype A is Element_Array (L .. H); 196 197 type PA is access A; 198 for PA'Size use System.Parameters.ptr_bits; 199 function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); 200 201 begin 202 return To_PA (Ref).all; 203 end; 204 end if; 205 end Value; 206 207 function Value 208 (Ref : Pointer; 209 Length : ptrdiff_t) return Element_Array 210 is 211 L : Index_Base; 212 H : Index_Base; 213 214 begin 215 if Ref = null then 216 raise Dereference_Error; 217 218 -- For length zero, we need to return a null slice, but we can't make 219 -- the bounds of this slice Index'First, since this could cause a 220 -- Constraint_Error if Index'First = Index'Base'First. 221 222 elsif Length <= 0 then 223 declare 224 pragma Warnings (Off); -- kill warnings since X not assigned 225 X : Element_Array (Index'Succ (Index'First) .. Index'First); 226 pragma Warnings (On); 227 228 begin 229 return X; 230 end; 231 232 -- Normal case (length non-zero) 233 234 else 235 L := Index'First; 236 H := Index'Val (Index'Pos (Index'First) + Length - 1); 237 238 declare 239 subtype A is Element_Array (L .. H); 240 241 type PA is access A; 242 for PA'Size use System.Parameters.ptr_bits; 243 function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); 244 245 begin 246 return To_PA (Ref).all; 247 end; 248 end if; 249 end Value; 250 251 -------------------- 252 -- Virtual_Length -- 253 -------------------- 254 255 function Virtual_Length 256 (Ref : Pointer; 257 Terminator : Element := Default_Terminator) return ptrdiff_t 258 is 259 P : Pointer; 260 C : ptrdiff_t; 261 262 begin 263 if Ref = null then 264 raise Dereference_Error; 265 266 else 267 C := 0; 268 P := Ref; 269 270 while P.all /= Terminator loop 271 C := C + 1; 272 Increment (P); 273 end loop; 274 275 return C; 276 end if; 277 end Virtual_Length; 278 279end Interfaces.C.Pointers; 280