File : s-gcmain-cert.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUNTIME COMPONENTS --
4 -- --
5 -- S Y S T E M . G E N E R I C _ C _ M A T H _ I N T E R F A C E --
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 -- This is the Cert specific version of s-gcmain.adb.
33
34 -- The separate version is necessary, because this system does not
35 -- provide an implementation of tanh, among other hyperbolic functions.
36 -- The run time currently has no code to implement this function,
37 -- so the only short term option was to remove the hyperbolic functions.
38
39 with Ada.Numerics; use Ada.Numerics;
40
41 package body System.Generic_C_Math_Interface is
42
43 subtype T is Float_Type'Base;
44
45 -- The implementations of these functions start with a summary
46 -- of the Ada requirements for the following:
47 -- * Principal branch of multivalued functions
48 -- * Conditions for raising exceptions
49 -- * Prescribed function results
50 -- * Tightly approximated function results (strict mode only)
51
52 -- Implementation choices are explained after the summary for each
53 -- elementary function. Exceptions are raised either by checking
54 -- the arguments or the C function result. Prescribed results are
55 -- satisfied by referring to corresponding requirements in C,
56 -- standard implementation practice or by explicit special-casing
57 -- in the code below.
58
59 -- If one of the arguments of a function is a NaN, the function
60 -- will return a NaN value or raise Argument_Error. Generally, for
61 -- functions that require Argument_Error to be raised for some
62 -- arguments will also raise Argument_Error for NaN arguments.
63
64 -- Many comparisons for special cases are inverted using "not" in
65 -- order to make sure the condition is false for NaN values,
66 -- using the principle that any comparison involving a NaN argument
67 -- evaluates to false.
68
69 -- Principal branch:
70 -- Describes function result for cases where the mathematical
71 -- function is multivalued.
72
73 -- Exceptions:
74 -- Describes in what situations exceptions such as
75 -- Argument_Error and Constraint_Error must be raised.
76 -- In addition to these required exceptions, Constraint_Error
77 -- may also be raised instead of yielding an infinity value
78 -- for types T where T'Machine_Overflows is True.
79
80 -- Prescribed results:
81 -- Describes identities that must be satisfied.
82
83 -- Tightly approximated results:
84 -- Describes arguments for which the function result must
85 -- be in the model interval of the mathematical result.
86 -- This is required for strict mode.
87
88 -- Special values:
89 -- These are implementation-defined results arguments with
90 -- special values such as infinities (represented by +Inf and -Inf)
91 -- not-a-number values (written as NaN). Where consistent with the
92 -- Ada standard, the implementation satisfies the identities given
93 -- in Chapter F.9 of the C standard.
94
95 ----------
96 -- "**" --
97 ----------
98
99 -- Principle branch:
100 -- The result is nonnegative.
101
102 -- Required exceptions:
103 -- Argument_Error is raised when Left < 0.0, Left is a NaN
104 -- or when Left = 0.0 and Right = 0.0.
105 -- Constraint_Error is raised when Left = 0.0 and Right < 0.0.
106
107 -- Prescribed results:
108 -- (1) Left ** 0.0 = 1.0
109 -- (2) Left ** 1.0 = Left
110 -- (3) 0.0 ** Right = 0.0
111 -- (4) 1.0 ** Right = 1.0
112
113 -- The prescribed result (1) is satisfied by C_Pow.
114 -- Result (2) is not, and therefore is special-cased.
115 -- For case (3) this implementation always returns +0.0,
116 -- while C_Pow would return -0.0 when Left = -0.0 and Right a positive
117 -- odd integer. This would seem inconsistent with the required principle
118 -- branch, although it is debatable whether -0.0 is negative.
119 -- For case (4), C_Pow would return NaN, so a special case is required.
120
121 function "**" (Left, Right : Float_Type'Base) return Float_Type'Base is
122 begin
123 if Left <= 0.0 then
124 if not (Left = 0.0) or else not (Right /= 0.0) then
125 raise Argument_Error;
126
127 elsif not (Right >= 0.0) then
128 raise Constraint_Error;
129
130 else
131 -- Left = 0.0 and Right > 0.0
132
133 return 0.0;
134 end if;
135
136 elsif Right = 1.0 then
137 return Left;
138
139 elsif Left = 1.0 then
140 return 1.0;
141 end if;
142
143 return C_Pow (Left, Right);
144 end "**";
145
146 ------------
147 -- Arccos --
148 ------------
149
150 -- (Natural cycle)
151
152 -- Principal branch:
153 -- The result is in the quadrant containing the point (X, 1.0).
154 -- This quadrant is I or II; thus, the Arccos function ranges
155 -- from 0.0 to approximately Pi.
156
157 -- Exceptions:
158 -- Argument_Error is raised when abs (X) > 1.0
159
160 -- Tightly approximated results:
161 -- Arccos (0.0) = Pi / 2.0;
162
163 -- Since C mandates a NaN result for abs (X) > 1.0 and testing
164 -- for a NaN only requires a single test without calling the "abs"
165 -- function, the result is checked rather than the argument.
166
167 function Arccos (X : Float_Type'Base) return Float_Type'Base is
168 R : T;
169
170 begin
171 R := C_Acos (X);
172
173 if R /= R then
174 raise Argument_Error;
175 else
176 return R;
177 end if;
178 end Arccos;
179
180 -- (Arbitrary cycle)
181
182 -- Principal branch:
183 -- The result is in the quadrant containing the point (X, 1.0).
184 -- This quadrant is I or II; thus, the Arccos function ranges
185 -- from 0.0 to approximately Cycle / 2.0.
186
187 -- Exceptions:
188 -- Argument_Error is raised when abs (X) > 1.0 or when Cycle <= 0.0
189 -- or when either parameter is a NaN
190
191 -- Prescribed results:
192 -- Arccos (1.0) = 0.0
193
194 -- Tightly approximated results:
195 -- Arccos (0.0) = Cycle / 4.0
196
197 -- Since C mandates a NaN result for abs (X) > 1.0 and testing for a NaN
198 -- only requires a single test without calling the "abs" function, the
199 -- result is checked rather than the argument. The tightly approximated
200 -- result may not be obtained by dividing the C_Acos result by Pi, since
201 -- these are transcedental numbers.
202
203 function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base is
204 begin
205 if not (Cycle > 0.0) then
206 raise Argument_Error;
207
208 elsif not (abs X < 1.0) then
209 if X = 1.0 then
210 return 0.0;
211
212 elsif X = -1.0 then
213 return Cycle / 2.0;
214 end if;
215
216 raise Argument_Error;
217 end if;
218
219 if X = 0.0 then
220 return Cycle / 4.0;
221 end if;
222
223 return C_Acos (X) / (Pi / 2.0) * (Cycle / 4.0);
224 end Arccos;
225
226 ------------
227 -- Arccot --
228 ------------
229
230 -- Natural cycle
231
232 function Arccot
233 (X : Float_Type'Base;
234 Y : Float_Type'Base := 1.0) return Float_Type'Base
235 is
236 begin
237 -- Just reverse arguments
238
239 return Arctan (Y, X);
240 end Arccot;
241
242 -- Arbitrary cycle
243
244 function Arccot
245 (X : Float_Type'Base;
246 Y : Float_Type'Base := 1.0;
247 Cycle : Float_Type'Base) return Float_Type'Base
248 is
249 begin
250 -- Just reverse arguments
251
252 return Arctan (Y, X, Cycle);
253 end Arccot;
254
255 ------------
256 -- Arcsin --
257 ------------
258
259 -- (Natural cycle)
260
261 -- Principal branch:
262 -- The result of the Arcsin function is in the quadrant containing the
263 -- the point (1.0, X). This quadrant is I or IV; thus, the range of the
264 -- function is approximately -Pi/2.0 to Pi/2.0.
265
266 -- Exceptions:
267 -- Argument_Error is raised when abs X > 1.0 or X is a NaN
268
269 -- Prescribed results:
270 -- Arcsin (0.0) = 0.0
271
272 -- Tightly approximated results:
273 -- Arcsin (1.0) = Pi / 2.0
274 -- Arcsin (-1.0) = -Pi / 2.0
275
276 -- The prescribed result is guaranteed by C, but the tightly approximated
277 -- results are not.
278
279 function Arcsin (X : Float_Type'Base) return Float_Type'Base is
280 Y : constant T := abs X;
281
282 begin
283 if not (Y < 1.0) then
284 if X = 1.0 then
285 return Pi / 2.0;
286
287 elsif X = -1.0 then
288 return -Pi / 2.0;
289
290 else
291 raise Argument_Error;
292 end if;
293 end if;
294
295 return C_Asin (X);
296 end Arcsin;
297
298 -- (Arbitrary cycle)
299
300 -- Principal branch:
301 -- The result of the Arcsin function is in the quadrant containing the
302 -- the point (1.0, X). This quadrant is I or IV; thus, the range of the
303 -- function is approximately -Cycle/4.0 to Cycle/4.0.
304
305 -- Exceptions:
306 -- Argument_Error is raised when abs X > 1.0 or X is a NaN
307 -- or when Cycle <= 0.0 or Cycle is a NaN
308
309 -- Prescribed results:
310 -- Arcsin (0.0) = 0.0
311
312 -- Tightly approximated results:
313 -- Arcsin (1.0) = Cycle / 4.0
314 -- Arcsin (-1.0) = -Cycle / 4.0
315
316 -- The prescribed result is guaranteed by C, but the tightly approximated
317 -- results are not.
318
319 function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base is
320 Y : constant T := abs X;
321
322 begin
323 if not (Cycle > 0.0) then
324 raise Argument_Error;
325
326 elsif not (Y < 1.0) then
327 if X = 1.0 then
328 return Cycle / 4.0;
329
330 elsif X = -1.0 then
331 return -Cycle / 4.0;
332
333 else
334 raise Argument_Error;
335 end if;
336 end if;
337
338 return C_Asin (X) / (Pi / 2.0) * (Cycle / 4.0);
339 end Arcsin;
340
341 ------------
342 -- Arctan --
343 ------------
344
345 -- (Natural cycle)
346
347 -- Principal branch:
348 -- The results are in the quadrant containing the point (X, Y).
349 -- This may be any quadrant (I through IV) when the parameter X is
350 -- specified, but it is restricted to quadrants I and IV when that
351 -- parameter is omitted. Thus the range when that parameter is
352 -- specified is approximately -Pi to Pi; when omitted the range is
353 -- -Pi/2.0 to Pi/2.0.
354
355 -- Exceptions:
356 -- Argument_Error is raised when both X and Y have the value zero.
357
358 -- Prescribed results:
359 -- Arctan ( X, 0.0) = 0.0, when X > 0.0
360
361 -- Tightly approximated results:
362 -- Arctan (0.0, Y) = Pi/2.0, when Y > 0.0
363 -- Arctan (0.0, Y) = -Pi/2.0, when Y < 0.0
364 -- Arctan ( X, +0.0) = +Pi, when X < 0.0
365 -- Arctan ( X, -0.0) = -Pi, when X < 0.0
366
367 -- The prescribed result and tightly approximated results are all
368 -- guaranteed by C.
369
370 function Arctan
371 (Y : Float_Type'Base;
372 X : Float_Type'Base := 1.0) return Float_Type'Base
373 is
374 begin
375 if not (X /= 0.0) and then not (Y /= 0.0) then
376 raise Argument_Error;
377 end if;
378
379 return C_Atan2 (Y, X);
380 end Arctan;
381
382 -- (Arbitrary cycle)
383
384 -- Principal branch:
385 -- The results are in the quadrant containing the point (X, Y).
386 -- This may be any quadrant (I through IV) when the parameter X is
387 -- specified, but it is restricted to quadrants I and IV when that
388 -- parameter is omitted. Thus the range when that parameter is
389 -- specified is approximately -Cycle/2.0 to Cycle/2.0; when omitted
390 -- the range is -Cycle/4.0 to Cycle/4.0.
391
392 -- Exceptions:
393 -- Argument_Error is raised when both X and Y have the value zero,
394 -- or when Cycle <= 0.0 or Cycle is a NaN.
395
396 -- Prescribed results:
397 -- Arctan ( X, 0.0, Cycle) = 0.0, when X > 0.0
398
399 -- Tightly approximated results:
400 -- Arctan (0.0, Y, Cycle) = Cycle/4.0, when Y > 0.0
401 -- Arctan (0.0, Y, Cycle) = -Cycle/4.0, when Y < 0.0
402 -- Arctan ( X, +0.0, Cycle) = Cycle/2.0, when X < 0.0
403 -- Arctan ( X, -0.0, Cycle) = -Cycle/2.0, when X < 0.0
404
405 -- The prescribed result and tightly approximated results are all
406 -- guaranteed by C.
407
408 function Arctan
409 (Y : Float_Type'Base;
410 X : Float_Type'Base := 1.0;
411 Cycle : Float_Type'Base) return Float_Type'Base
412 is
413 begin
414 if not (Cycle > 0.0) then
415 raise Argument_Error;
416 end if;
417
418 if X = 0.0 then
419 if Y = 0.0 then
420 raise Argument_Error;
421
422 elsif Y > 0.0 then
423 return Cycle / 4.0;
424
425 elsif Y < 0.0 then
426 return -Cycle / 4.0;
427 end if;
428
429 -- Y is a NaN
430
431 elsif Y = 0.0 then
432 -- X /= 0
433
434 if X > 0.0 then
435 return 0.0;
436
437 elsif X < 0.0 then
438 return T'Copy_Sign (Cycle / 2.0, Y);
439 end if;
440
441 -- X is a NaN
442 end if;
443
444 return C_Atan2 (Y, X) * Cycle / (2.0 * Pi);
445 end Arctan;
446
447 ---------
448 -- Cos --
449 ---------
450
451 -- (Natural cycle)
452
453 -- Prescribed results:
454 -- Cos (0.0) = 1.0
455
456 -- Special values:
457 -- Cos (X), where X is positive or negative infinity returns NaN value
458
459 -- The C_Cos function satisfies all requirements
460
461 function Cos (X : Float_Type'Base) return Float_Type'Base is
462 begin
463 return C_Cos (X);
464 end Cos;
465
466 -- (Arbitrary cycle)
467
468 -- Exceptions:
469 -- Argument_Error is raised when Cycle <= 0
470
471 -- Prescribed results:
472 -- Cos (X) = 0.0, when X is K * Cycle / 4.0 with odd integer K
473 -- Cos (X) = 1.0, when X is K * Cycle, with integer K
474 -- Cos (X) = -1.0, with X is K * Cycle / 2.0, with odd integer K
475
476 -- Special values:
477 -- Cos (X), where X is positive or negative infinity returns a
478 -- NaN value.
479
480 function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base is
481 begin
482 -- Just reuse the code for Sin. The potential small
483 -- loss of speed is negligible with proper (front-end) inlining.
484
485 return -Sin (abs X - Cycle * 0.25, Cycle);
486 end Cos;
487
488 ---------
489 -- Cot --
490 ---------
491
492 -- (natural cycle)
493
494 -- Exceptions:
495 -- Constraint_Error is raised when X = 0.0
496
497 -- As there is no cotangent function defined for C99, it is implemented
498 -- here in terms of the regular tangent function.
499
500 function Cot (X : Float_Type'Base) return Float_Type'Base is
501 begin
502 if X = 0.0 then
503 raise Constraint_Error;
504 end if;
505
506 return 1.0 / C_Tan (X);
507 end Cot;
508
509 -- (arbitrary cycle)
510
511 -- Exceptions:
512 -- Argument_Error is raised when Cycle <= 0
513 -- Constraint_Error is raised when X = K * Cycle / 2.0, with integer K
514
515 -- Prescribed results:
516 -- Cot (X) = 0.0, when X is K * Cycle / 4.0 with odd integer K
517
518 -- Special values:
519 -- Cot (X), where X is positive or negative infinity returns NaN value
520
521 function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base is
522 T, TA : Float_Type'Base;
523
524 begin
525 if not (Cycle > 0.0) then
526 raise Argument_Error;
527 end if;
528
529 T := Float_Type'Base'Remainder (X, Cycle) / Cycle;
530 TA := abs T;
531
532 if T = 0.0 or else TA = 0.5 then
533 raise Constraint_Error;
534 end if;
535
536 if TA = 0.25 then
537 return 0.0;
538 end if;
539
540 return 1.0 / C_Tan (T * 2.0 * Pi);
541 end Cot;
542
543 ---------
544 -- Exp --
545 ---------
546
547 -- Prescribed results:
548 -- Exp (0.0) = 1.0
549
550 -- Special values:
551 -- Exp (X) = +0.0, for X is negative infinity
552 -- Exp (X) = X, for X is positive infinity
553 -- and Float_Type'Machine_Overflows = False
554
555 -- The C_Exp function satisfies all Ada requirements
556
557 function Exp (X : Float_Type'Base) return Float_Type'Base is
558 begin
559 return C_Exp (X);
560 end Exp;
561
562 ---------
563 -- Log --
564 ---------
565
566 -- (natural base)
567
568 -- Exceptions:
569 -- Argument is raised when X < 0.0
570 -- Constraint_Error is raised when X = 0.0
571
572 -- Prescribed results:
573 -- Log (1.0) = 0.0;
574
575 -- Special values:
576 -- Log (X) = X, for X is positive infinity
577
578 -- Apart from exceptions, the C_Log function satisfies all constraints
579
580 function Log (X : Float_Type'Base) return Float_Type'Base is
581 begin
582 if X <= 0.0 then
583 if X < 0.0 then
584 raise Argument_Error;
585 end if;
586
587 raise Constraint_Error;
588 end if;
589
590 return C_Log (X);
591 end Log;
592
593 -- (arbitrary base)
594
595 -- Exceptions:
596 -- Argument is raised when X < 0.0, Base <= 0.0 or Base = 1.0
597 -- Constraint_Error is raised when X = 0.0
598
599 -- Prescribed results:
600 -- Log (1.0, Base) = 0.0
601
602 -- Special values:
603 -- Log (X, Base) = X, for X is positive infinity
604
605 -- Apart from exceptions, the C_Log function satisfies all constraints
606
607 function Log (X, Base : Float_Type'Base) return Float_Type'Base is
608 begin
609 -- Try to execute the common case of X > 0.0 and Base > 1.0 with
610 -- minimal checks.
611
612 if X <= 0.0 or else Base <= 1.0 then
613 if X < 0.0 or else Base <= 0.0 or else Base = 1.0 then
614 raise Argument_Error;
615 end if;
616
617 if X = 0.0 then
618 raise Constraint_Error;
619 end if;
620 end if;
621
622 return C_Log (X) / C_Log (Base);
623 end Log;
624
625 ---------
626 -- Sin --
627 ---------
628
629 -- (Natural cycle)
630
631 -- Prescribed results:
632 -- Sin (+0.0) = +0.0
633 -- Sin (-0.0) = -0.0
634
635 -- Special values:
636 -- Sin (X), where X is positive or negative infinity returns a
637 -- NaN value.
638
639 -- The C_Sin function satisfies all requirements
640
641 function Sin (X : Float_Type'Base) return Float_Type'Base is
642 begin
643 return C_Sin (X);
644 end Sin;
645
646 -- (Arbitrary cycle)
647
648 -- Exceptions:
649 -- Argument_Error is raised when Cycle <= 0
650
651 -- Prescribed results:
652 -- Sin (-0.0) = -0.0
653 -- Sin (+0.0) = +0.0
654 -- Sin (X) = 1.0, when X is K * Cycle + Cycle / 4.0, with integer K
655 -- Sin (X) = -1.0, with X is K * Cycle - Cycle / 4.0, with integer K
656
657 -- Special values:
658 -- Sin (X), where X is positive or negative infinity returns NaN value
659
660 function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base is
661 T : Float_Type'Base;
662
663 begin
664 if not (Cycle > 0.0) then
665 raise Argument_Error;
666 end if;
667
668 T := Float_Type'Base'Remainder (X, Cycle);
669
670 -- The following reduction reduces the argument to the interval
671 -- [-0.5 Cycle, 0.5 * Cycle]. The entire reduction is exact.
672
673 if T > 0.25 * Cycle then
674 T := 0.5 * Cycle - T;
675
676 elsif T < -0.25 * Cycle then
677 T := -T - 0.5 * Cycle;
678 end if;
679
680 return C_Sin (T / Cycle * 2.0 * Pi);
681 end Sin;
682
683 ----------
684 -- Sqrt --
685 ----------
686
687 -- Principle branch:
688 -- The result is nonnegative.
689
690 -- Exceptions:
691 -- Argument_Error is raised when X < 0.0
692
693 -- Prescribed results:
694 -- Sqrt (-0.0) = -0.0
695 -- Sqrt (+0.0) = +0.0
696 -- Sqrt (1.0) = 1.0
697
698 -- Special values:
699 -- Sqrt (X) = X, for X is positive infinity
700
701 -- C_Sqrt satisfies all requirements
702
703 function Sqrt (X : Float_Type'Base) return Float_Type'Base is
704 begin
705 if not (X >= 0.0) then
706 raise Argument_Error;
707 end if;
708
709 return C_Sqrt (X);
710 end Sqrt;
711
712 ---------
713 -- Tan --
714 ---------
715
716 -- (natural cycle)
717
718 -- Prescribed results:
719 -- Tan (-0.0) = -0.0
720 -- Tan (+0.0) = +0.0
721
722 -- Special values:
723 -- Tan (X) returns a NaN value, when X is positive or negative infinity
724
725 -- The C_Tan function satisfies all requirements
726
727 function Tan (X : Float_Type'Base) return Float_Type'Base is
728 begin
729 return C_Tan (X);
730 end Tan;
731
732 -- (arbitrary cycle)
733
734 -- Exceptions:
735 -- Argument_Error is raised for Cycle <= 0.0
736
737 -- Prescribed results:
738 -- Tan (-0.0, Cycle) = -0.0
739 -- Tan (+0.0, Cycle) = +0.0
740 -- Tan (X, Cycle) = 0, for X a multiple of Cycle / 2.0
741
742 -- Special values:
743 -- Tan (X, Cycle) returns a NaN value, when X is positive or
744 -- negative infinity
745
746 function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base is
747 T : Float_Type'Base;
748 TA : Float_Type'Base;
749
750 begin
751 if not (Cycle > 0.0) then
752 raise Argument_Error;
753 end if;
754
755 T := Float_Type'Base'Remainder (X, Cycle) / Cycle;
756 TA := abs T;
757
758 -- The TA = 0.75 case is not needed because the remainder function
759 -- is defined so that it never returns a value greater than Cycle/2,
760 -- the value of TA will always be less than or equal to 0.5. Therefore,
761 -- the condition TA = 0.75 can never be true.
762
763 if TA = 0.25 then
764 raise Constraint_Error;
765 end if;
766
767 if TA = 0.5 then
768 return 0.0;
769 end if;
770
771 return C_Tan (T * 2.0 * Pi);
772 end Tan;
773
774 end System.Generic_C_Math_Interface;