111
|
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 -- --
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
111
|
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 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;
|