Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-nbnbin.adb @ 145:1830386684a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents
children
comparison
equal deleted inserted replaced
131:84e7813d76e9 145:1830386684a0
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2019, 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
32 with Ada.Unchecked_Deallocation;
33 with Ada.Characters.Conversions; use Ada.Characters.Conversions;
34
35 with Interfaces; use Interfaces;
36
37 with System.Generic_Bignums;
38
39 package body Ada.Numerics.Big_Numbers.Big_Integers is
40
41 package Bignums is new
42 System.Generic_Bignums (Use_Secondary_Stack => False);
43 use Bignums, System;
44
45 procedure Free is new Ada.Unchecked_Deallocation (Bignum_Data, Bignum);
46
47 function Get_Bignum (Arg : Big_Integer) return Bignum is
48 (if Arg.Value.C = System.Null_Address
49 then raise Constraint_Error with "invalid big integer"
50 else To_Bignum (Arg.Value.C));
51 -- Check for validity of Arg and return the Bignum value stored in Arg.
52 -- Raise Constraint_Error if Arg is uninitialized.
53
54 procedure Set_Bignum (Arg : out Big_Integer; Value : Bignum)
55 with Inline;
56 -- Set the Bignum value stored in Arg to Value
57
58 ----------------
59 -- Set_Bignum --
60 ----------------
61
62 procedure Set_Bignum (Arg : out Big_Integer; Value : Bignum) is
63 begin
64 Arg.Value.C := To_Address (Value);
65 end Set_Bignum;
66
67 --------------
68 -- Is_Valid --
69 --------------
70
71 function Is_Valid (Arg : Big_Integer) return Boolean is
72 (Arg.Value.C /= System.Null_Address);
73
74 ---------
75 -- "=" --
76 ---------
77
78 function "=" (L, R : Big_Integer) return Boolean is
79 begin
80 return Big_EQ (Get_Bignum (L), Get_Bignum (R));
81 end "=";
82
83 ---------
84 -- "<" --
85 ---------
86
87 function "<" (L, R : Big_Integer) return Boolean is
88 begin
89 return Big_LT (Get_Bignum (L), Get_Bignum (R));
90 end "<";
91
92 ----------
93 -- "<=" --
94 ----------
95
96 function "<=" (L, R : Big_Integer) return Boolean is
97 begin
98 return Big_LE (Get_Bignum (L), Get_Bignum (R));
99 end "<=";
100
101 ---------
102 -- ">" --
103 ---------
104
105 function ">" (L, R : Big_Integer) return Boolean is
106 begin
107 return Big_GT (Get_Bignum (L), Get_Bignum (R));
108 end ">";
109
110 ----------
111 -- ">=" --
112 ----------
113
114 function ">=" (L, R : Big_Integer) return Boolean is
115 begin
116 return Big_GE (Get_Bignum (L), Get_Bignum (R));
117 end ">=";
118
119 --------------------
120 -- To_Big_Integer --
121 --------------------
122
123 function To_Big_Integer (Arg : Integer) return Big_Integer is
124 Result : Big_Integer;
125 begin
126 Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg)));
127 return Result;
128 end To_Big_Integer;
129
130 ----------------
131 -- To_Integer --
132 ----------------
133
134 function To_Integer (Arg : Big_Integer) return Integer is
135 begin
136 return Integer (From_Bignum (Get_Bignum (Arg)));
137 end To_Integer;
138
139 ------------------------
140 -- Signed_Conversions --
141 ------------------------
142
143 package body Signed_Conversions is
144
145 --------------------
146 -- To_Big_Integer --
147 --------------------
148
149 function To_Big_Integer (Arg : Int) return Big_Integer is
150 Result : Big_Integer;
151 begin
152 Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg)));
153 return Result;
154 end To_Big_Integer;
155
156 ----------------------
157 -- From_Big_Integer --
158 ----------------------
159
160 function From_Big_Integer (Arg : Big_Integer) return Int is
161 begin
162 return Int (From_Bignum (Get_Bignum (Arg)));
163 end From_Big_Integer;
164
165 end Signed_Conversions;
166
167 --------------------------
168 -- Unsigned_Conversions --
169 --------------------------
170
171 package body Unsigned_Conversions is
172
173 --------------------
174 -- To_Big_Integer --
175 --------------------
176
177 function To_Big_Integer (Arg : Int) return Big_Integer is
178 Result : Big_Integer;
179 begin
180 Set_Bignum (Result, To_Bignum (Unsigned_64 (Arg)));
181 return Result;
182 end To_Big_Integer;
183
184 ----------------------
185 -- From_Big_Integer --
186 ----------------------
187
188 function From_Big_Integer (Arg : Big_Integer) return Int is
189 begin
190 return Int (From_Bignum (Get_Bignum (Arg)));
191 end From_Big_Integer;
192
193 end Unsigned_Conversions;
194
195 ---------------
196 -- To_String --
197 ---------------
198
199 Hex_Chars : constant array (0 .. 15) of Character := "0123456789ABCDEF";
200
201 function To_String
202 (Arg : Big_Integer; Width : Field := 0; Base : Number_Base := 10)
203 return String
204 is
205 Big_Base : constant Big_Integer := To_Big_Integer (Integer (Base));
206
207 function Add_Base (S : String) return String;
208 -- Add base information if Base /= 10
209
210 function Leading_Padding
211 (Str : String;
212 Min_Length : Field;
213 Char : Character := ' ') return String;
214 -- Return padding of Char concatenated with Str so that the resulting
215 -- string is at least Min_Length long.
216
217 function Image (Arg : Big_Integer) return String;
218 -- Return image of Arg, assuming Arg is positive.
219
220 function Image (N : Natural) return String;
221 -- Return image of N, with no leading space.
222
223 --------------
224 -- Add_Base --
225 --------------
226
227 function Add_Base (S : String) return String is
228 begin
229 if Base = 10 then
230 return S;
231 else
232 return Image (Base) & "#" & S & "#";
233 end if;
234 end Add_Base;
235
236 -----------
237 -- Image --
238 -----------
239
240 function Image (N : Natural) return String is
241 S : constant String := Natural'Image (N);
242 begin
243 return S (2 .. S'Last);
244 end Image;
245
246 function Image (Arg : Big_Integer) return String is
247 begin
248 if Arg < Big_Base then
249 return (1 => Hex_Chars (To_Integer (Arg)));
250 else
251 return Image (Arg / Big_Base)
252 & Hex_Chars (To_Integer (Arg rem Big_Base));
253 end if;
254 end Image;
255
256 ---------------------
257 -- Leading_Padding --
258 ---------------------
259
260 function Leading_Padding
261 (Str : String;
262 Min_Length : Field;
263 Char : Character := ' ') return String is
264 begin
265 return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0)
266 => Char) & Str;
267 end Leading_Padding;
268
269 begin
270 if Arg < To_Big_Integer (0) then
271 return Leading_Padding ("-" & Add_Base (Image (-Arg)), Width);
272 else
273 return Leading_Padding (" " & Add_Base (Image (Arg)), Width);
274 end if;
275 end To_String;
276
277 -----------------
278 -- From_String --
279 -----------------
280
281 function From_String (Arg : String) return Big_Integer is
282 Result : Big_Integer;
283 begin
284 -- ??? only support Long_Long_Integer, good enough for now
285 Set_Bignum (Result, To_Bignum (Long_Long_Integer'Value (Arg)));
286 return Result;
287 end From_String;
288
289 ---------------
290 -- Put_Image --
291 ---------------
292
293 procedure Put_Image
294 (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
295 Arg : Big_Integer) is
296 begin
297 Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg)));
298 end Put_Image;
299
300 ---------
301 -- "+" --
302 ---------
303
304 function "+" (L : Big_Integer) return Big_Integer is
305 Result : Big_Integer;
306 begin
307 Set_Bignum (Result, new Bignum_Data'(Get_Bignum (L).all));
308 return Result;
309 end "+";
310
311 ---------
312 -- "-" --
313 ---------
314
315 function "-" (L : Big_Integer) return Big_Integer is
316 Result : Big_Integer;
317 begin
318 Set_Bignum (Result, Big_Neg (Get_Bignum (L)));
319 return Result;
320 end "-";
321
322 -----------
323 -- "abs" --
324 -----------
325
326 function "abs" (L : Big_Integer) return Big_Integer is
327 Result : Big_Integer;
328 begin
329 Set_Bignum (Result, Big_Abs (Get_Bignum (L)));
330 return Result;
331 end "abs";
332
333 ---------
334 -- "+" --
335 ---------
336
337 function "+" (L, R : Big_Integer) return Big_Integer is
338 Result : Big_Integer;
339 begin
340 Set_Bignum (Result, Big_Add (Get_Bignum (L), Get_Bignum (R)));
341 return Result;
342 end "+";
343
344 ---------
345 -- "-" --
346 ---------
347
348 function "-" (L, R : Big_Integer) return Big_Integer is
349 Result : Big_Integer;
350 begin
351 Set_Bignum (Result, Big_Sub (Get_Bignum (L), Get_Bignum (R)));
352 return Result;
353 end "-";
354
355 ---------
356 -- "*" --
357 ---------
358
359 function "*" (L, R : Big_Integer) return Big_Integer is
360 Result : Big_Integer;
361 begin
362 Set_Bignum (Result, Big_Mul (Get_Bignum (L), Get_Bignum (R)));
363 return Result;
364 end "*";
365
366 ---------
367 -- "/" --
368 ---------
369
370 function "/" (L, R : Big_Integer) return Big_Integer is
371 Result : Big_Integer;
372 begin
373 Set_Bignum (Result, Big_Div (Get_Bignum (L), Get_Bignum (R)));
374 return Result;
375 end "/";
376
377 -----------
378 -- "mod" --
379 -----------
380
381 function "mod" (L, R : Big_Integer) return Big_Integer is
382 Result : Big_Integer;
383 begin
384 Set_Bignum (Result, Big_Mod (Get_Bignum (L), Get_Bignum (R)));
385 return Result;
386 end "mod";
387
388 -----------
389 -- "rem" --
390 -----------
391
392 function "rem" (L, R : Big_Integer) return Big_Integer is
393 Result : Big_Integer;
394 begin
395 Set_Bignum (Result, Big_Rem (Get_Bignum (L), Get_Bignum (R)));
396 return Result;
397 end "rem";
398
399 ----------
400 -- "**" --
401 ----------
402
403 function "**" (L : Big_Integer; R : Natural) return Big_Integer is
404 begin
405 -- Explicitly check for validity before allocating Exp so that
406 -- the call to Get_Bignum below cannot raise an exception before
407 -- we get a chance to free Exp.
408
409 if not Is_Valid (L) then
410 raise Constraint_Error with "invalid big integer";
411 end if;
412
413 declare
414 Exp : Bignum := To_Bignum (Long_Long_Integer (R));
415 Result : Big_Integer;
416 begin
417 Set_Bignum (Result, Big_Exp (Get_Bignum (L), Exp));
418 Free (Exp);
419 return Result;
420 end;
421 end "**";
422
423 ---------
424 -- Min --
425 ---------
426
427 function Min (L, R : Big_Integer) return Big_Integer is
428 (if L < R then L else R);
429
430 ---------
431 -- Max --
432 ---------
433
434 function Max (L, R : Big_Integer) return Big_Integer is
435 (if L > R then L else R);
436
437 -----------------------------
438 -- Greatest_Common_Divisor --
439 -----------------------------
440
441 function Greatest_Common_Divisor (L, R : Big_Integer) return Big_Positive is
442 function GCD (A, B : Big_Integer) return Big_Integer;
443 -- Recursive internal version
444
445 ---------
446 -- GCD --
447 ---------
448
449 function GCD (A, B : Big_Integer) return Big_Integer is
450 begin
451 if Is_Zero (Get_Bignum (B)) then
452 return A;
453 else
454 return GCD (B, A rem B);
455 end if;
456 end GCD;
457
458 begin
459 return GCD (abs L, abs R);
460 end Greatest_Common_Divisor;
461
462 ------------
463 -- Adjust --
464 ------------
465
466 procedure Adjust (This : in out Controlled_Bignum) is
467 begin
468 if This.C /= System.Null_Address then
469 This.C := To_Address (new Bignum_Data'(To_Bignum (This.C).all));
470 end if;
471 end Adjust;
472
473 --------------
474 -- Finalize --
475 --------------
476
477 procedure Finalize (This : in out Controlled_Bignum) is
478 Tmp : Bignum := To_Bignum (This.C);
479 begin
480 Free (Tmp);
481 This.C := System.Null_Address;
482 end Finalize;
483
484 end Ada.Numerics.Big_Numbers.Big_Integers;