OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

scans.ads (Wide_Wide_Character_Found): New flag 

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

From-SVN: r154804
This commit is contained in:
Robert Dewar 2009-11-30 14:09:30 +00:00 committed by Arnaud Charlet
parent d0995fa280
commit fd22cd216b
8 changed files with 115 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/ada/ChangeLog
View File

@ -1,3 +1,14 @@
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

128
gcc/ada/a-ngelfu.adb
View File

@ -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));
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???)
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)));

8
gcc/ada/scans.ads
View File

@ -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;

7
gcc/ada/scn.adb
View File

@ -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 =>

21
gcc/ada/scng.adb
View File

@ -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;

16
gcc/ada/sinfo.adb
View File

@ -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

19
gcc/ada/sinfo.ads
View File

@ -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);

2
gcc/ada/usage.adb
View File

@ -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");