-- advantage of the C functions, e.g. in providing interface to hardware
-- provided versions of the elementary functions.
--- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan,
--- sinh, cosh, tanh from C library via math.h
+-- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan, sinh,
+-- cosh, tanh from C library via math.h
with Ada.Numerics.Aux;
Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696;
Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755;
+
Half_Log_Two : constant := Log_Two / 2;
subtype T is Float_Type'Base;
-----------------------
function Exp_Strict (X : Float_Type'Base) return Float_Type'Base;
- -- Cody/Waite routine, supposedly more precise than the library
- -- version. Currently only needed for Sinh/Cosh on X86 with the largest
- -- FP type.
+ -- Cody/Waite routine, supposedly more precise than the library version.
+ -- Currently only needed for Sinh/Cosh on X86 with the largest FP type.
function Local_Atan
(Y : Float_Type'Base;
A_Right := abs (Right);
-- If exponent is larger than one, compute integer exponen-
- -- tiation if possible, and evaluate fractional part with
- -- more precision. The relative error is now proportional
- -- to the fractional part of the exponent only.
+ -- tiation if possible, and evaluate fractional part with more
+ -- precision. The relative error is now proportional to the
+ -- fractional part of the exponent only.
if A_Right > 1.0
and then A_Right < Float_Type'Base (Integer'Last)
function Arccosh (X : Float_Type'Base) return Float_Type'Base is
begin
- -- Return positive branch of Log (X - Sqrt (X * X - 1.0)), or
- -- the proper approximation for X close to 1 or >> 1.
+ -- Return positive branch of Log (X - Sqrt (X * X - 1.0)), or the proper
+ -- approximation for X close to 1 or >> 1.
if X < 1.0 then
raise Argument_Error;
raise Argument_Error;
else
- -- 1.0 < abs X <= 2.0. One of X + 1.0 and X - 1.0 is exact, the
- -- other has error 0 or Epsilon.
+ -- 1.0 < abs X <= 2.0. One of X + 1.0 and X - 1.0 is exact, the other
+ -- has error 0 or Epsilon.
return 0.5 * (Log (abs (X + 1.0)) - Log (abs (X - 1.0)));
end if;
return Float_Type'Base
is
begin
- if X = 0.0
- and then Y = 0.0
- then
+ if X = 0.0 and then Y = 0.0 then
raise Argument_Error;
elsif Y = 0.0 then
end if;
elsif X = 0.0 then
- if Y > 0.0 then
- return Half_Pi;
- else -- Y < 0.0
- return -Half_Pi;
- end if;
+ return Float_Type'Copy_Sign (Half_Pi, Y);
else
return Local_Atan (Y, X);
if Cycle <= 0.0 then
raise Argument_Error;
- elsif X = 0.0
- and then Y = 0.0
- then
+ elsif X = 0.0 and then Y = 0.0 then
raise Argument_Error;
elsif Y = 0.0 then
end if;
elsif X = 0.0 then
- if Y > 0.0 then
- return Cycle / 4.0;
- else -- Y < 0.0
- return -(Cycle / 4.0);
- end if;
+ return Float_Type'Copy_Sign (Cycle / 4.0, Y);
else
return Local_Atan (Y, X) * Cycle / Two_Pi;
function Arctanh (X : Float_Type'Base) return Float_Type'Base is
A, B, D, A_Plus_1, A_From_1 : Float_Type'Base;
+
Mantissa : constant Integer := Float_Type'Base'Machine_Mantissa;
begin
-- why is above line commented out ???
else
- -- Use several piecewise linear approximations.
- -- A is close to X, chosen so 1.0 + A, 1.0 - A, and X - A are exact.
- -- The two scalings remove the low-order bits of X.
+ -- Use several piecewise linear approximations. A is close to X,
+ -- chosen so 1.0 + A, 1.0 - A, and X - A are exact. The two scalings
+ -- remove the low-order bits of X.
A := Float_Type'Base'Scaling (
Float_Type'Base (Long_Long_Integer
D := A_Plus_1 * A_From_1; -- 1 - A*A.
-- use one term of the series expansion:
- -- f (x + e) = f(x) + e * f'(x) + ..
+
+ -- f (x + e) = f(x) + e * f'(x) + ..
-- The derivative of Arctanh at A is 1/(1-A*A). Next term is
-- A*(B/D)**2 (if a quadratic approximation is ever needed).
return 0.5 * (Log (A_Plus_1) - Log (A_From_1)) + B / D;
-
- -- else
- -- return 0.5 * Log ((X + 1.0) / (1.0 - X));
- -- why are above lines commented out ???
end if;
end Arctanh;
function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base is
begin
- -- Just reuse the code for Sin. The potential small
- -- loss of speed is negligible with proper (front-end) inlining.
+ -- Just reuse the code for Sin. The potential small loss of speed is
+ -- negligible with proper (front-end) inlining.
return -Sin (abs X - Cycle * 0.25, Cycle);
end Cos;
-- Deal with case of Exp returning IEEE infinity. If Machine_Overflows
-- is False, then we can just leave it as an infinity (and indeed we
- -- prefer to do so). But if Machine_Overflows is True, then we have
- -- to raise a Constraint_Error exception as required by the RM.
+ -- prefer to do so). But if Machine_Overflows is True, then we have to
+ -- raise a Constraint_Error exception as required by the RM.
if Float_Type'Machine_Overflows and then not R'Valid then
raise Constraint_Error;
Raw_Atan : Float_Type'Base;
begin
- -- Z := (if abs Y > abs X then abs (X / Y) else abs (Y / X));
-
- -- Raw_Atan :=
- -- (if Z < Sqrt_Epsilon then Z
- -- elsif Z = 1.0 then Pi / 4.0
- -- else Float_Type'Base (Aux.Atan (Double (Z))));
-
- -- Replace above with IF statements for now (ASIS gnatelim problem???)
+ Z := (if abs Y > abs X then abs (X / Y) else abs (Y / X));
- if abs Y > abs X then
- Z := abs (X / Y);
- else
- Z := abs (Y / X);
- end if;
-
- if Z < Sqrt_Epsilon then
- Raw_Atan := Z;
- elsif Z = 1.0 then
- Raw_Atan := Pi / 4.0;
- else
- Raw_Atan := Float_Type'Base (Aux.Atan (Double (Z)));
- end if;
+ Raw_Atan :=
+ (if Z < Sqrt_Epsilon then Z
+ elsif Z = 1.0 then Pi / 4.0
+ else Float_Type'Base (Aux.Atan (Double (Z))));
if abs Y > abs X then
Raw_Atan := Half_Pi - Raw_Atan;
end if;
if X > 0.0 then
- if Y > 0.0 then
- return Raw_Atan;
- else -- Y < 0.0
- return -Raw_Atan;
- end if;
-
- else -- X < 0.0
- if Y > 0.0 then
- return Pi - Raw_Atan;
- else -- Y < 0.0
- return -(Pi - Raw_Atan);
- end if;
+ return Float_Type'Copy_Sign (Raw_Atan, Y);
+ else
+ return Float_Type'Copy_Sign (Pi - Raw_Atan, Y);
end if;
end Local_Atan;
if Cycle <= 0.0 then
raise Argument_Error;
+ -- If X is zero, return it as the result, preserving the argument sign.
+ -- Is this test really needed on any machine ???
+
elsif X = 0.0 then
- -- Is this test really needed on any machine ???
return X;
end if;
T := Float_Type'Base'Remainder (X, Cycle);
- -- The following two reductions reduce the argument
- -- to the interval [-0.25 * Cycle, 0.25 * Cycle].
- -- This reduction is exact and is needed to prevent
- -- inaccuracy that may result if the sinus function
- -- a different (more accurate) value of Pi in its
- -- reduction than is used in the multiplication with Two_Pi.
+ -- The following two reductions reduce the argument to the interval
+ -- [-0.25 * Cycle, 0.25 * Cycle]. This reduction is exact and is needed
+ -- to prevent inaccuracy that may result if the sinus function uses a
+ -- different (more accurate) value of Pi in its reduction than is used
+ -- in the multiplication with Two_Pi.
if abs T > 0.25 * Cycle then
T := 0.5 * Float_Type'Copy_Sign (Cycle, T) - T;
end if;
- -- Could test for 12.0 * abs T = Cycle, and return
- -- an exact value in those cases. It is not clear that
- -- this is worth the extra test though.
+ -- Could test for 12.0 * abs T = Cycle, and return an exact value in
+ -- those cases. It is not clear this is worth the extra test though.
return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi)));
end Sin;
elsif X = 0.0 then
return X;
-
end if;
return Float_Type'Base (Aux.Sqrt (Double (X)));
procedure Set_String;
-- Procedure used to distinguish between string and operator symbol.
- -- On entry the string has been scanned out, and its characters
- -- start at Token_Ptr and end one character before Scan_Ptr. On exit
- -- Token is set to Tok_String_Literal or Tok_Operator_Symbol as
- -- appropriate, and Token_Node is appropriately initialized. In
- -- addition, in the operator symbol case, Token_Name is
- -- appropriately set.
+ -- On entry the string has been scanned out, and its characters start
+ -- at Token_Ptr and end one character before Scan_Ptr. On exit Token
+ -- is set to Tok_String_Literal/Tok_Operator_Symbol as appropriate,
+ -- and Token_Node is appropriately initialized. In addition, in the
+ -- operator symbol case, Token_Name is appropriately set, and the
+ -- flags [Wide_]Wide_Character_Found are set appropriately.
---------------------------
-- Error_Bad_String_Char --
Delimiter := Source (Scan_Ptr);
Accumulate_Checksum (Delimiter);
+
Start_String;
+ Wide_Character_Found := False;
+ Wide_Wide_Character_Found := False;
Scan_Ptr := Scan_Ptr + 1;
-- Loop to scan out characters of string literal
Store_String_Char (Code);
if not In_Character_Range (Code) then
- Wide_Character_Found := True;
+ if In_Wide_Character_Range (Code) then
+ Wide_Character_Found := True;
+ else
+ Wide_Wide_Character_Found := True;
+ end if;
end if;
end loop;
-- Has_Wide_Character (Flag11-Sem)
-- Present in string literals, set if any wide character (i.e. character
- -- code outside the Character range) appears in the string.
+ -- code outside the Character range but within Wide_Character range)
+ -- appears in the string. Used to implement pragma preference rules.
+
+ -- Has_Wide_Wide_Character (Flag13-Sem)
+ -- Present in string literals, set if any wide character (i.e. character
+ -- code outside the Wide_Character range) appears in the string. Used to
+ -- implement pragma preference rules.
-- Hidden_By_Use_Clause (Elist4-Sem)
-- An entity list present in use clauses that appear within
-- to the node for the spec of the instance, inserted as part of the
-- semantic processing for instantiations in Sem_Ch12.
- -- Is_Accessibility_Actual (Flag13-Sem)
+ -- Is_Accessibility_Actual (Flag12-Sem)
-- Present in N_Parameter_Association nodes. True if the parameter is
-- an extra actual that carries the accessibility level of the actual
-- for an access parameter, in a function that dispatches on result and
-- Sloc points to literal
-- Strval (Str3) contains Id of string value
-- Has_Wide_Character (Flag11-Sem)
+ -- Has_Wide_Wide_Character (Flag13-Sem)
-- Is_Folded_In_Parser (Flag4)
-- plus fields for expression
function Has_Wide_Character
(N : Node_Id) return Boolean; -- Flag11
+ function Has_Wide_Wide_Character
+ (N : Node_Id) return Boolean; -- Flag13
+
function Hidden_By_Use_Clause
(N : Node_Id) return Elist_Id; -- Elist4
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True); -- Flag11
+ procedure Set_Has_Wide_Wide_Character
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
procedure Set_Hidden_By_Use_Clause
(N : Node_Id; Val : Elist_Id); -- Elist4
pragma Inline (Has_Task_Info_Pragma);
pragma Inline (Has_Task_Name_Pragma);
pragma Inline (Has_Wide_Character);
+ pragma Inline (Has_Wide_Wide_Character);
pragma Inline (Hidden_By_Use_Clause);
pragma Inline (High_Bound);
pragma Inline (Identifier);
pragma Inline (Set_Has_Task_Info_Pragma);
pragma Inline (Set_Has_Task_Name_Pragma);
pragma Inline (Set_Has_Wide_Character);
+ pragma Inline (Set_Has_Wide_Wide_Character);
pragma Inline (Set_Hidden_By_Use_Clause);
pragma Inline (Set_High_Bound);
pragma Inline (Set_Identifier);
OSDN Git Service
