diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 11 | ||||
| -rw-r--r-- | gcc/ada/a-ngelfu.adb | 128 | ||||
| -rw-r--r-- | gcc/ada/scans.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/scn.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/scng.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/usage.adb | 2 |
8 files changed, 115 insertions, 97 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cdf787f6a54..e5cd72b4de9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,16 @@ 2009-11-30 Robert Dewar <dewar@adacore.com> + * scans.ads (Wide_Wide_Character_Found): New flag + * scn.adb (Post_Scan): Set new flag Has_Wide_Wide_Character + * scng.adb (Set_String): Set new flag Wide_Wide_Character_Found + (Set_String): Fix failure to reset Wide_Character_Found + * sinfo.adb (Has_Wide_Wide_Character): New flag in N_String_Literal + * sinfo.ads (Has_Wide_Wide_Character): New flag in N_String_Literal + * a-ngelfu.adb: Minor reformatting & code reorganization. + * usage.adb: Fix typo in -gnatw.W line + +2009-11-30 Robert Dewar <dewar@adacore.com> + * osint.adb, prj-nmsc.adb, sem_prag.adb, sem_util.adb: Minor reformatting. * csinfo.adb: Terminate run if improper use of reserved flag diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb index aa06c983605..fcc08d479c0 100644 --- a/gcc/ada/a-ngelfu.adb +++ b/gcc/ada/a-ngelfu.adb @@ -35,8 +35,8 @@ -- 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; @@ -46,6 +46,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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; @@ -63,9 +64,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is ----------------------- 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; @@ -120,9 +120,9 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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) @@ -240,8 +240,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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; @@ -304,8 +304,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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; @@ -393,9 +393,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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 @@ -406,11 +404,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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); @@ -429,9 +423,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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 @@ -442,11 +434,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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; @@ -459,6 +447,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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 @@ -490,9 +479,9 @@ package body Ada.Numerics.Generic_Elementary_Functions is -- 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 @@ -504,16 +493,13 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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; @@ -540,8 +526,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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; @@ -704,8 +690,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is -- 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; @@ -727,46 +713,21 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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; @@ -835,27 +796,27 @@ package body Ada.Numerics.Generic_Elementary_Functions is 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; @@ -938,7 +899,6 @@ package body Ada.Numerics.Generic_Elementary_Functions is elsif X = 0.0 then return X; - end if; return Float_Type'Base (Aux.Sqrt (Double (X))); diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 4fe0700a4e4..770d53bb59b 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -428,7 +428,13 @@ package Scans is -- Valid only when Token = Tok_String_Literal or Tok_Operator_Symbol. Wide_Character_Found : Boolean := False; - -- Set True if wide character found. + -- Set True if wide character found (i.e. a character that does not fit + -- in Character, but fits in Wide_Wide_Character). + -- Valid only when Token = Tok_String_Literal. + + Wide_Wide_Character_Found : Boolean := False; + -- Set True if wide wide character found (i.e. a character that does + -- not fit in Character or Wide_Character). -- Valid only when Token = Tok_String_Literal. Special_Character : Character; diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index 81dc49bb5b5..98485506cba 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -383,7 +383,10 @@ package body Scn is when Tok_String_Literal => Token_Node := New_Node (N_String_Literal, Token_Ptr); - Set_Has_Wide_Character (Token_Node, Wide_Character_Found); + Set_Has_Wide_Character + (Token_Node, Wide_Character_Found); + Set_Has_Wide_Wide_Character + (Token_Node, Wide_Wide_Character_Found); Set_Strval (Token_Node, String_Literal_Id); when Tok_Operator_Symbol => diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 30da224d905..af1f3bbc3a0 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -785,12 +785,12 @@ package body Scng is 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 -- @@ -1016,7 +1016,10 @@ package body Scng is 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 @@ -1096,7 +1099,11 @@ package body Scng is 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; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index c075af5ab7a..f4c171cebf7 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1481,6 +1481,14 @@ package body Sinfo is return Flag11 (N); end Has_Wide_Character; + function Has_Wide_Wide_Character + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + return Flag13 (N); + end Has_Wide_Wide_Character; + function Hidden_By_Use_Clause (N : Node_Id) return Elist_Id is begin @@ -4351,6 +4359,14 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Has_Wide_Character; + procedure Set_Has_Wide_Wide_Character + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + Set_Flag13 (N, Val); + end Set_Has_Wide_Wide_Character; + procedure Set_Hidden_By_Use_Clause (N : Node_Id; Val : Elist_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c37a2596fda..cbafd19dd94 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1149,7 +1149,13 @@ package Sinfo is -- 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 @@ -1179,7 +1185,7 @@ package Sinfo is -- 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 @@ -1937,6 +1943,7 @@ package Sinfo is -- 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 @@ -8059,6 +8066,9 @@ package Sinfo is 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 @@ -8974,6 +8984,9 @@ package Sinfo is 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 @@ -11274,6 +11287,7 @@ package Sinfo is 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); @@ -11575,6 +11589,7 @@ package Sinfo is 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); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index c5caa463992..9df7c47f1ac 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -476,7 +476,7 @@ begin Write_Line (" W turn off warnings for wrong low bound " & "assumption"); Write_Line (" .w turn on warnings on pragma Warnings Off"); - Write_Line (" .w* turn off warnings on pragma Warnings Off"); + Write_Line (" .W* turn off warnings on pragma Warnings Off"); Write_Line (" x* turn on warnings for export/import"); Write_Line (" X turn off warnings for export/import"); Write_Line (" .x turn on warnings for non-local exception"); |