1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- ADA.NUMERICS.BIG_NUMBERS.BIG_REALS -- 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-- This is the default version of this package, based on Big_Integers only. 33 34with Ada.Characters.Conversions; use Ada.Characters.Conversions; 35 36package body Ada.Numerics.Big_Numbers.Big_Reals is 37 38 use Big_Integers; 39 40 procedure Normalize (Arg : in out Big_Real); 41 -- Normalize Arg by ensuring that Arg.Den is always positive and that 42 -- Arg.Num and Arg.Den always have a GCD of 1. 43 44 -------------- 45 -- Is_Valid -- 46 -------------- 47 48 function Is_Valid (Arg : Big_Real) return Boolean is 49 (Is_Valid (Arg.Num) and then Is_Valid (Arg.Den)); 50 51 --------- 52 -- "/" -- 53 --------- 54 55 function "/" (Num, Den : Big_Integer) return Big_Real is 56 Result : Big_Real; 57 begin 58 if Den = To_Big_Integer (0) then 59 raise Constraint_Error with "divide by zero"; 60 end if; 61 62 Result.Num := Num; 63 Result.Den := Den; 64 Normalize (Result); 65 return Result; 66 end "/"; 67 68 --------------- 69 -- Numerator -- 70 --------------- 71 72 function Numerator (Arg : Big_Real) return Big_Integer is (Arg.Num); 73 74 ----------------- 75 -- Denominator -- 76 ----------------- 77 78 function Denominator (Arg : Big_Real) return Big_Positive is (Arg.Den); 79 80 --------- 81 -- "=" -- 82 --------- 83 84 function "=" (L, R : Big_Real) return Boolean is 85 (abs L.Num = abs R.Num and then L.Den = R.Den); 86 87 --------- 88 -- "<" -- 89 --------- 90 91 function "<" (L, R : Big_Real) return Boolean is 92 (abs L.Num * R.Den < abs R.Num * L.Den); 93 94 ---------- 95 -- "<=" -- 96 ---------- 97 98 function "<=" (L, R : Big_Real) return Boolean is (not (R < L)); 99 100 --------- 101 -- ">" -- 102 --------- 103 104 function ">" (L, R : Big_Real) return Boolean is (R < L); 105 106 ---------- 107 -- ">=" -- 108 ---------- 109 110 function ">=" (L, R : Big_Real) return Boolean is (not (L < R)); 111 112 ----------------------- 113 -- Float_Conversions -- 114 ----------------------- 115 116 package body Float_Conversions is 117 118 ----------------- 119 -- To_Big_Real -- 120 ----------------- 121 122 function To_Big_Real (Arg : Num) return Big_Real is 123 begin 124 return From_String (Arg'Image); 125 end To_Big_Real; 126 127 ------------------- 128 -- From_Big_Real -- 129 ------------------- 130 131 function From_Big_Real (Arg : Big_Real) return Num is 132 begin 133 return Num'Value (To_String (Arg)); 134 end From_Big_Real; 135 136 end Float_Conversions; 137 138 ----------------------- 139 -- Fixed_Conversions -- 140 ----------------------- 141 142 package body Fixed_Conversions is 143 144 ----------------- 145 -- To_Big_Real -- 146 ----------------- 147 148 function To_Big_Real (Arg : Num) return Big_Real is 149 begin 150 return From_String (Arg'Image); 151 end To_Big_Real; 152 153 ------------------- 154 -- From_Big_Real -- 155 ------------------- 156 157 function From_Big_Real (Arg : Big_Real) return Num is 158 begin 159 return Num'Value (To_String (Arg)); 160 end From_Big_Real; 161 162 end Fixed_Conversions; 163 164 --------------- 165 -- To_String -- 166 --------------- 167 168 function To_String 169 (Arg : Big_Real; Fore : Field := 2; Aft : Field := 3; Exp : Field := 0) 170 return String 171 is 172 Zero : constant Big_Integer := To_Big_Integer (0); 173 Ten : constant Big_Integer := To_Big_Integer (10); 174 175 function Leading_Padding 176 (Str : String; 177 Min_Length : Field; 178 Char : Character := ' ') return String; 179 -- Return padding of Char concatenated with Str so that the resulting 180 -- string is at least Min_Length long. 181 182 function Trailing_Padding 183 (Str : String; 184 Length : Field; 185 Char : Character := '0') return String; 186 -- Return Str with trailing Char removed, and if needed either 187 -- truncated or concatenated with padding of Char so that the resulting 188 -- string is Length long. 189 190 function Image (N : Natural) return String; 191 -- Return image of N, with no leading space. 192 193 function Numerator_Image 194 (Num : Big_Integer; 195 After : Natural) return String; 196 -- Return image of Num as a float value with After digits after the "." 197 -- and taking Fore, Aft, Exp into account. 198 199 ----------- 200 -- Image -- 201 ----------- 202 203 function Image (N : Natural) return String is 204 S : constant String := Natural'Image (N); 205 begin 206 return S (2 .. S'Last); 207 end Image; 208 209 --------------------- 210 -- Leading_Padding -- 211 --------------------- 212 213 function Leading_Padding 214 (Str : String; 215 Min_Length : Field; 216 Char : Character := ' ') return String is 217 begin 218 if Str = "" then 219 return Leading_Padding ("0", Min_Length, Char); 220 else 221 return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0) 222 => Char) & Str; 223 end if; 224 end Leading_Padding; 225 226 ---------------------- 227 -- Trailing_Padding -- 228 ---------------------- 229 230 function Trailing_Padding 231 (Str : String; 232 Length : Field; 233 Char : Character := '0') return String is 234 begin 235 if Str'Length > 0 and then Str (Str'Last) = Char then 236 for J in reverse Str'Range loop 237 if Str (J) /= '0' then 238 return Trailing_Padding 239 (Str (Str'First .. J), Length, Char); 240 end if; 241 end loop; 242 end if; 243 244 if Str'Length >= Length then 245 return Str (Str'First .. Str'First + Length - 1); 246 else 247 return Str & 248 (1 .. Integer'Max (Integer (Length) - Str'Length, 0) 249 => Char); 250 end if; 251 end Trailing_Padding; 252 253 --------------------- 254 -- Numerator_Image -- 255 --------------------- 256 257 function Numerator_Image 258 (Num : Big_Integer; 259 After : Natural) return String 260 is 261 Tmp : constant String := To_String (Num); 262 Str : constant String (1 .. Tmp'Last - 1) := Tmp (2 .. Tmp'Last); 263 Index : Integer; 264 265 begin 266 if After = 0 then 267 return Leading_Padding (Str, Fore) & "." 268 & Trailing_Padding ("0", Aft); 269 else 270 Index := Str'Last - After; 271 272 if Index < 0 then 273 return Leading_Padding ("0", Fore) 274 & "." 275 & Trailing_Padding ((1 .. -Index => '0') & Str, Aft) 276 & (if Exp = 0 then "" else "E+" & Image (Natural (Exp))); 277 else 278 return Leading_Padding (Str (Str'First .. Index), Fore) 279 & "." 280 & Trailing_Padding (Str (Index + 1 .. Str'Last), Aft) 281 & (if Exp = 0 then "" else "E+" & Image (Natural (Exp))); 282 end if; 283 end if; 284 end Numerator_Image; 285 286 begin 287 if Arg.Num < Zero then 288 declare 289 Str : String := To_String (-Arg, Fore, Aft, Exp); 290 begin 291 if Str (1) = ' ' then 292 for J in 1 .. Str'Last - 1 loop 293 if Str (J + 1) /= ' ' then 294 Str (J) := '-'; 295 exit; 296 end if; 297 end loop; 298 299 return Str; 300 else 301 return '-' & Str; 302 end if; 303 end; 304 else 305 -- Compute Num * 10^Aft so that we get Aft significant digits 306 -- in the integer part (rounded) to display. 307 308 return Numerator_Image 309 ((Arg.Num * Ten ** Aft) / Arg.Den, After => Exp + Aft); 310 end if; 311 end To_String; 312 313 ----------------- 314 -- From_String -- 315 ----------------- 316 317 function From_String (Arg : String) return Big_Real is 318 Ten : constant Big_Integer := To_Big_Integer (10); 319 Frac : Big_Integer; 320 Exp : Integer := 0; 321 Pow : Natural := 0; 322 Index : Natural := 0; 323 Last : Natural := Arg'Last; 324 325 begin 326 for J in reverse Arg'Range loop 327 if Arg (J) in 'e' | 'E' then 328 if Last /= Arg'Last then 329 raise Constraint_Error with "multiple exponents specified"; 330 end if; 331 332 Last := J - 1; 333 Exp := Integer'Value (Arg (J + 1 .. Arg'Last)); 334 Pow := 0; 335 336 elsif Arg (J) = '.' then 337 Index := J - 1; 338 exit; 339 else 340 Pow := Pow + 1; 341 end if; 342 end loop; 343 344 if Index = 0 then 345 raise Constraint_Error with "invalid real value"; 346 end if; 347 348 declare 349 Result : Big_Real; 350 begin 351 Result.Den := Ten ** Pow; 352 Result.Num := From_String (Arg (Arg'First .. Index)) * Result.Den; 353 Frac := From_String (Arg (Index + 2 .. Last)); 354 355 if Result.Num < To_Big_Integer (0) then 356 Result.Num := Result.Num - Frac; 357 else 358 Result.Num := Result.Num + Frac; 359 end if; 360 361 if Exp > 0 then 362 Result.Num := Result.Num * Ten ** Exp; 363 elsif Exp < 0 then 364 Result.Den := Result.Den * Ten ** (-Exp); 365 end if; 366 367 Normalize (Result); 368 return Result; 369 end; 370 end From_String; 371 372 -------------------------- 373 -- From_Quotient_String -- 374 -------------------------- 375 376 function From_Quotient_String (Arg : String) return Big_Real is 377 Index : Natural := 0; 378 begin 379 for J in Arg'First + 1 .. Arg'Last - 1 loop 380 if Arg (J) = '/' then 381 Index := J; 382 exit; 383 end if; 384 end loop; 385 386 if Index = 0 then 387 raise Constraint_Error with "no quotient found"; 388 end if; 389 390 return Big_Integers.From_String (Arg (Arg'First .. Index - 1)) / 391 Big_Integers.From_String (Arg (Index + 1 .. Arg'Last)); 392 end From_Quotient_String; 393 394 --------------- 395 -- Put_Image -- 396 --------------- 397 398 procedure Put_Image 399 (Stream : not null access Ada.Streams.Root_Stream_Type'Class; 400 Arg : Big_Real) is 401 begin 402 Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg))); 403 end Put_Image; 404 405 --------- 406 -- "+" -- 407 --------- 408 409 function "+" (L : Big_Real) return Big_Real is 410 Result : Big_Real; 411 begin 412 Result.Num := L.Num; 413 Result.Den := L.Den; 414 return Result; 415 end "+"; 416 417 --------- 418 -- "-" -- 419 --------- 420 421 function "-" (L : Big_Real) return Big_Real is 422 (Num => -L.Num, Den => L.Den); 423 424 ----------- 425 -- "abs" -- 426 ----------- 427 428 function "abs" (L : Big_Real) return Big_Real is 429 (Num => abs L.Num, Den => L.Den); 430 431 --------- 432 -- "+" -- 433 --------- 434 435 function "+" (L, R : Big_Real) return Big_Real is 436 Result : Big_Real; 437 begin 438 Result.Num := L.Num * R.Den + R.Num * L.Den; 439 Result.Den := L.Den * R.Den; 440 Normalize (Result); 441 return Result; 442 end "+"; 443 444 --------- 445 -- "-" -- 446 --------- 447 448 function "-" (L, R : Big_Real) return Big_Real is 449 Result : Big_Real; 450 begin 451 Result.Num := L.Num * R.Den - R.Num * L.Den; 452 Result.Den := L.Den * R.Den; 453 Normalize (Result); 454 return Result; 455 end "-"; 456 457 --------- 458 -- "*" -- 459 --------- 460 461 function "*" (L, R : Big_Real) return Big_Real is 462 Result : Big_Real; 463 begin 464 Result.Num := L.Num * R.Num; 465 Result.Den := L.Den * R.Den; 466 Normalize (Result); 467 return Result; 468 end "*"; 469 470 --------- 471 -- "/" -- 472 --------- 473 474 function "/" (L, R : Big_Real) return Big_Real is 475 Result : Big_Real; 476 begin 477 Result.Num := L.Num * R.Den; 478 Result.Den := L.Den * R.Num; 479 Normalize (Result); 480 return Result; 481 end "/"; 482 483 ---------- 484 -- "**" -- 485 ---------- 486 487 function "**" (L : Big_Real; R : Integer) return Big_Real is 488 Result : Big_Real; 489 begin 490 if R = 0 then 491 Result.Num := To_Big_Integer (1); 492 Result.Den := To_Big_Integer (1); 493 else 494 if R < 0 then 495 Result.Num := L.Den ** (-R); 496 Result.Den := L.Num ** (-R); 497 else 498 Result.Num := L.Num ** R; 499 Result.Den := L.Den ** R; 500 end if; 501 502 Normalize (Result); 503 end if; 504 505 return Result; 506 end "**"; 507 508 --------- 509 -- Min -- 510 --------- 511 512 function Min (L, R : Big_Real) return Big_Real is (if L < R then L else R); 513 514 --------- 515 -- Max -- 516 --------- 517 518 function Max (L, R : Big_Real) return Big_Real is (if L > R then L else R); 519 520 --------------- 521 -- Normalize -- 522 --------------- 523 524 procedure Normalize (Arg : in out Big_Real) is 525 begin 526 if Arg.Den < To_Big_Integer (0) then 527 Arg.Num := -Arg.Num; 528 Arg.Den := -Arg.Den; 529 end if; 530 531 declare 532 GCD : constant Big_Integer := 533 Greatest_Common_Divisor (Arg.Num, Arg.Den); 534 begin 535 Arg.Num := Arg.Num / GCD; 536 Arg.Den := Arg.Den / GCD; 537 end; 538 end Normalize; 539 540end Ada.Numerics.Big_Numbers.Big_Reals; 541