File : i-cpoint.adb
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 -- --
19 -- --
20 -- --
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 with Interfaces.C.Strings; use Interfaces.C.Strings;
33 with System; use System;
34
35 with Ada.Unchecked_Conversion;
36
37 package 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
295 end Interfaces.C.Pointers;