1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.Numerics.Aux; use Ada.Numerics.Aux;
34 package body Ada.Numerics.Generic_Complex_Types is
36 subtype R is Real'Base;
38 Two_Pi : constant R := R (2.0) * Pi;
39 Half_Pi : constant R := Pi / R (2.0);
45 function "*" (Left, Right : Complex) return Complex is
47 Scale : constant R := R (R'Machine_Radix) ** ((R'Machine_Emax - 1) / 2);
48 -- In case of overflow, scale the operands by the largest power of the
49 -- radix (to avoid rounding error), so that the square of the scale does
50 -- not overflow itself.
56 X := Left.Re * Right.Re - Left.Im * Right.Im;
57 Y := Left.Re * Right.Im + Left.Im * Right.Re;
59 -- If either component overflows, try to scale (skip in fast math mode)
61 if not Standard'Fast_Math then
63 -- Note that the test below is written as a negation. This is to
64 -- account for the fact that X and Y may be NaNs, because both of
65 -- their operands could overflow. Given that all operations on NaNs
66 -- return false, the test can only be written thus.
68 if not (abs (X) <= R'Last) then
69 X := Scale**2 * ((Left.Re / Scale) * (Right.Re / Scale) -
70 (Left.Im / Scale) * (Right.Im / Scale));
73 if not (abs (Y) <= R'Last) then
74 Y := Scale**2 * ((Left.Re / Scale) * (Right.Im / Scale)
75 + (Left.Im / Scale) * (Right.Re / Scale));
82 function "*" (Left, Right : Imaginary) return Real'Base is
84 return -(R (Left) * R (Right));
87 function "*" (Left : Complex; Right : Real'Base) return Complex is
89 return Complex'(Left.Re * Right, Left.Im * Right);
92 function "*" (Left : Real'Base; Right : Complex) return Complex is
94 return (Left * Right.Re, Left * Right.Im);
97 function "*" (Left : Complex; Right : Imaginary) return Complex is
99 return Complex'(-(Left.Im * R (Right)), Left.Re * R (Right));
102 function "*" (Left : Imaginary; Right : Complex) return Complex is
104 return Complex'(-(R (Left) * Right.Im), R (Left) * Right.Re);
107 function "*" (Left : Imaginary; Right : Real'Base) return Imaginary is
109 return Left * Imaginary (Right);
112 function "*" (Left : Real'Base; Right : Imaginary) return Imaginary is
114 return Imaginary (Left * R (Right));
121 function "**" (Left : Complex; Right : Integer) return Complex is
122 Result : Complex := (1.0, 0.0);
123 Factor : Complex := Left;
124 Exp : Integer := Right;
127 -- We use the standard logarithmic approach, Exp gets shifted right
128 -- testing successive low order bits and Factor is the value of the
129 -- base raised to the next power of 2. For positive exponents we
130 -- multiply the result by this factor, for negative exponents, we
131 -- divide by this factor.
135 -- For a positive exponent, if we get a constraint error during
136 -- this loop, it is an overflow, and the constraint error will
137 -- simply be passed on to the caller.
140 if Exp rem 2 /= 0 then
141 Result := Result * Factor;
144 Factor := Factor * Factor;
152 -- For the negative exponent case, a constraint error during this
153 -- calculation happens if Factor gets too large, and the proper
154 -- response is to return 0.0, since what we essentially have is
155 -- 1.0 / infinity, and the closest model number will be zero.
159 if Exp rem 2 /= 0 then
160 Result := Result * Factor;
163 Factor := Factor * Factor;
167 return R'(1.0) / Result;
170 when Constraint_Error =>
176 function "**" (Left : Imaginary; Right : Integer) return Complex is
177 M : constant R := R (Left) ** Right;
180 when 0 => return (M, 0.0);
181 when 1 => return (0.0, M);
182 when 2 => return (-M, 0.0);
183 when 3 => return (0.0, -M);
184 when others => raise Program_Error;
192 function "+" (Right : Complex) return Complex is
197 function "+" (Left, Right : Complex) return Complex is
199 return Complex'(Left.Re + Right.Re, Left.Im + Right.Im);
202 function "+" (Right : Imaginary) return Imaginary is
207 function "+" (Left, Right : Imaginary) return Imaginary is
209 return Imaginary (R (Left) + R (Right));
212 function "+" (Left : Complex; Right : Real'Base) return Complex is
214 return Complex'(Left.Re + Right, Left.Im);
217 function "+" (Left : Real'Base; Right : Complex) return Complex is
219 return Complex'(Left + Right.Re, Right.Im);
222 function "+" (Left : Complex; Right : Imaginary) return Complex is
224 return Complex'(Left.Re, Left.Im + R (Right));
227 function "+" (Left : Imaginary; Right : Complex) return Complex is
229 return Complex'(Right.Re, R (Left) + Right.Im);
232 function "+" (Left : Imaginary; Right : Real'Base) return Complex is
234 return Complex'(Right, R (Left));
237 function "+" (Left : Real'Base; Right : Imaginary) return Complex is
239 return Complex'(Left, R (Right));
246 function "-" (Right : Complex) return Complex is
248 return (-Right.Re, -Right.Im);
251 function "-" (Left, Right : Complex) return Complex is
253 return (Left.Re - Right.Re, Left.Im - Right.Im);
256 function "-" (Right : Imaginary) return Imaginary is
258 return Imaginary (-R (Right));
261 function "-" (Left, Right : Imaginary) return Imaginary is
263 return Imaginary (R (Left) - R (Right));
266 function "-" (Left : Complex; Right : Real'Base) return Complex is
268 return Complex'(Left.Re - Right, Left.Im);
271 function "-" (Left : Real'Base; Right : Complex) return Complex is
273 return Complex'(Left - Right.Re, -Right.Im);
276 function "-" (Left : Complex; Right : Imaginary) return Complex is
278 return Complex'(Left.Re, Left.Im - R (Right));
281 function "-" (Left : Imaginary; Right : Complex) return Complex is
283 return Complex'(-Right.Re, R (Left) - Right.Im);
286 function "-" (Left : Imaginary; Right : Real'Base) return Complex is
288 return Complex'(-Right, R (Left));
291 function "-" (Left : Real'Base; Right : Imaginary) return Complex is
293 return Complex'(Left, -R (Right));
300 function "/" (Left, Right : Complex) return Complex is
301 a : constant R := Left.Re;
302 b : constant R := Left.Im;
303 c : constant R := Right.Re;
304 d : constant R := Right.Im;
307 if c = 0.0 and then d = 0.0 then
308 raise Constraint_Error;
310 return Complex'(Re => ((a * c) + (b * d)) / (c ** 2 + d ** 2),
311 Im => ((b * c) - (a * d)) / (c ** 2 + d ** 2));
315 function "/" (Left, Right : Imaginary) return Real'Base is
317 return R (Left) / R (Right);
320 function "/" (Left : Complex; Right : Real'Base) return Complex is
322 return Complex'(Left.Re / Right, Left.Im / Right);
325 function "/" (Left : Real'Base; Right : Complex) return Complex is
326 a : constant R := Left;
327 c : constant R := Right.Re;
328 d : constant R := Right.Im;
330 return Complex'(Re => (a * c) / (c ** 2 + d ** 2),
331 Im => -((a * d) / (c ** 2 + d ** 2)));
334 function "/" (Left : Complex; Right : Imaginary) return Complex is
335 a : constant R := Left.Re;
336 b : constant R := Left.Im;
337 d : constant R := R (Right);
340 return (b / d, -(a / d));
343 function "/" (Left : Imaginary; Right : Complex) return Complex is
344 b : constant R := R (Left);
345 c : constant R := Right.Re;
346 d : constant R := Right.Im;
349 return (Re => b * d / (c ** 2 + d ** 2),
350 Im => b * c / (c ** 2 + d ** 2));
353 function "/" (Left : Imaginary; Right : Real'Base) return Imaginary is
355 return Imaginary (R (Left) / Right);
358 function "/" (Left : Real'Base; Right : Imaginary) return Imaginary is
360 return Imaginary (-(Left / R (Right)));
367 function "<" (Left, Right : Imaginary) return Boolean is
369 return R (Left) < R (Right);
376 function "<=" (Left, Right : Imaginary) return Boolean is
378 return R (Left) <= R (Right);
385 function ">" (Left, Right : Imaginary) return Boolean is
387 return R (Left) > R (Right);
394 function ">=" (Left, Right : Imaginary) return Boolean is
396 return R (Left) >= R (Right);
403 function "abs" (Right : Imaginary) return Real'Base is
405 return abs R (Right);
412 function Argument (X : Complex) return Real'Base is
413 a : constant R := X.Re;
414 b : constant R := X.Im;
423 return R'Copy_Sign (Pi, b);
435 arg := R (Atan (Double (abs (b / a))));
454 when Constraint_Error =>
462 function Argument (X : Complex; Cycle : Real'Base) return Real'Base is
465 return Argument (X) * Cycle / Two_Pi;
467 raise Argument_Error;
471 ----------------------------
472 -- Compose_From_Cartesian --
473 ----------------------------
475 function Compose_From_Cartesian (Re, Im : Real'Base) return Complex is
478 end Compose_From_Cartesian;
480 function Compose_From_Cartesian (Re : Real'Base) return Complex is
483 end Compose_From_Cartesian;
485 function Compose_From_Cartesian (Im : Imaginary) return Complex is
487 return (0.0, R (Im));
488 end Compose_From_Cartesian;
490 ------------------------
491 -- Compose_From_Polar --
492 ------------------------
494 function Compose_From_Polar (
495 Modulus, Argument : Real'Base)
499 if Modulus = 0.0 then
502 return (Modulus * R (Cos (Double (Argument))),
503 Modulus * R (Sin (Double (Argument))));
505 end Compose_From_Polar;
507 function Compose_From_Polar (
508 Modulus, Argument, Cycle : Real'Base)
514 if Modulus = 0.0 then
517 elsif Cycle > 0.0 then
518 if Argument = 0.0 then
519 return (Modulus, 0.0);
521 elsif Argument = Cycle / 4.0 then
522 return (0.0, Modulus);
524 elsif Argument = Cycle / 2.0 then
525 return (-Modulus, 0.0);
527 elsif Argument = 3.0 * Cycle / R (4.0) then
528 return (0.0, -Modulus);
530 Arg := Two_Pi * Argument / Cycle;
531 return (Modulus * R (Cos (Double (Arg))),
532 Modulus * R (Sin (Double (Arg))));
535 raise Argument_Error;
537 end Compose_From_Polar;
543 function Conjugate (X : Complex) return Complex is
545 return Complex'(X.Re, -X.Im);
552 function Im (X : Complex) return Real'Base is
557 function Im (X : Imaginary) return Real'Base is
566 function Modulus (X : Complex) return Real'Base is
574 -- To compute (a**2 + b**2) ** (0.5) when a**2 may be out of bounds,
575 -- compute a * (1 + (b/a) **2) ** (0.5). On a machine where the
576 -- squaring does not raise constraint_error but generates infinity,
577 -- we can use an explicit comparison to determine whether to use
578 -- the scaling expression.
580 -- The scaling expression is computed in double format throughout
581 -- in order to prevent inaccuracies on machines where not all
582 -- immediate expressions are rounded, such as PowerPC.
584 -- ??? same weird test, why not Re2 > R'Last ???
585 if not (Re2 <= R'Last) then
586 raise Constraint_Error;
590 when Constraint_Error =>
591 return R (Double (abs (X.Re))
592 * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2));
598 -- ??? same weird test
599 if not (Im2 <= R'Last) then
600 raise Constraint_Error;
604 when Constraint_Error =>
605 return R (Double (abs (X.Im))
606 * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2));
609 -- Now deal with cases of underflow. If only one of the squares
610 -- underflows, return the modulus of the other component. If both
611 -- squares underflow, use scaling as above.
624 if abs (X.Re) > abs (X.Im) then
626 R (Double (abs (X.Re))
627 * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2));
630 R (Double (abs (X.Im))
631 * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2));
642 -- In all other cases, the naive computation will do
645 return R (Sqrt (Double (Re2 + Im2)));
653 function Re (X : Complex) return Real'Base is
662 procedure Set_Im (X : in out Complex; Im : Real'Base) is
667 procedure Set_Im (X : out Imaginary; Im : Real'Base) is
676 procedure Set_Re (X : in out Complex; Re : Real'Base) is
681 end Ada.Numerics.Generic_Complex_Types;