Commit bc5f3720 by Robert Dewar Committed by Arnaud Charlet

sem_res.adb (Resolve_Real_Literal): Generate warning if static fixed-point…

sem_res.adb (Resolve_Real_Literal): Generate warning if static fixed-point expression has value that is not a...

2005-03-29  Robert Dewar  <dewar@adacore.com>

	* sem_res.adb (Resolve_Real_Literal): Generate warning if static
	fixed-point expression has value that is not a multiple of the Small
	value.

	* opt.ads (Warn_On_Bad_Fixed_Value): New flag

	* s-taprop-tru64.adb (RT_Resolution): Return an integer number of
	nanoseconds.

	* ug_words: Add entry for [NO_]BAD_FIXED_VALUES for -gnatwb/-gnatwB

From-SVN: r97165
parent 8bb46326
...@@ -1025,6 +1025,11 @@ package Opt is ...@@ -1025,6 +1025,11 @@ package Opt is
-- Set to True to get verbose mode (full error message text and location -- Set to True to get verbose mode (full error message text and location
-- information sent to standard output, also header, copyright and summary) -- information sent to standard output, also header, copyright and summary)
Warn_On_Bad_Fixed_Value : Boolean := False;
-- GNAT
-- Set to True to generate warnings for static fixed-point expression
-- values that are not an exact multiple of the small value of the type.
Warn_On_Constant : Boolean := False; Warn_On_Constant : Boolean := False;
-- GNAT -- GNAT
-- Set to True to generate warnings for variables that could be declared -- Set to True to generate warnings for variables that could be declared
......
...@@ -612,7 +612,11 @@ package body System.Task_Primitives.Operations is ...@@ -612,7 +612,11 @@ package body System.Task_Primitives.Operations is
function RT_Resolution return Duration is function RT_Resolution return Duration is
begin begin
return 1.0 / 1024.0; -- Clock on DEC Alpha ticks at 1024 Hz -- Returned value must be an integral multiple of Duration'Small (1 ns)
-- The following is the best approximation of 1/1024. The clock on the
-- DEC Alpha ticks at 1024 Hz.
return 0.000_976_563;
end RT_Resolution; end RT_Resolution;
------------ ------------
......
...@@ -168,7 +168,9 @@ package body Sem_Res is ...@@ -168,7 +168,9 @@ package body Sem_Res is
-- by other node rewriting procedures. -- by other node rewriting procedures.
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
-- Resolve actuals of call, and add default expressions for missing ones -- Resolve actuals of call, and add default expressions for missing ones.
-- N is the Node_Id for the subprogram call, and Nam is the entity of the
-- called subprogram.
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
-- Called from Resolve_Call, when the prefix denotes an entry or element -- Called from Resolve_Call, when the prefix denotes an entry or element
...@@ -626,7 +628,6 @@ package body Sem_Res is ...@@ -626,7 +628,6 @@ package body Sem_Res is
F := First_Formal (Subp); F := First_Formal (Subp);
A := First_Actual (N); A := First_Actual (N);
while Present (F) and then Present (A) loop while Present (F) and then Present (A) loop
if not Is_Entity_Name (A) if not Is_Entity_Name (A)
or else Entity (A) /= F or else Entity (A) /= F
...@@ -787,6 +788,42 @@ package body Sem_Res is ...@@ -787,6 +788,42 @@ package body Sem_Res is
procedure Check_Parameterless_Call (N : Node_Id) is procedure Check_Parameterless_Call (N : Node_Id) is
Nam : Node_Id; Nam : Node_Id;
function Prefix_Is_Access_Subp return Boolean;
-- If the prefix is of an access_to_subprogram type, the node must be
-- rewritten as a call. Ditto if the prefix is overloaded and all its
-- interpretations are access to subprograms.
---------------------------
-- Prefix_Is_Access_Subp --
---------------------------
function Prefix_Is_Access_Subp return Boolean is
I : Interp_Index;
It : Interp;
begin
if not Is_Overloaded (N) then
return
Ekind (Etype (N)) = E_Subprogram_Type
and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type;
else
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if Ekind (It.Typ) /= E_Subprogram_Type
or else Base_Type (Etype (It.Typ)) = Standard_Void_Type
then
return False;
end if;
Get_Next_Interp (I, It);
end loop;
return True;
end if;
end Prefix_Is_Access_Subp;
-- Start of processing for Check_Parameterless_Call
begin begin
-- Defend against junk stuff if errors already detected -- Defend against junk stuff if errors already detected
...@@ -832,9 +869,7 @@ package body Sem_Res is ...@@ -832,9 +869,7 @@ package body Sem_Res is
-- procedure or entry. -- procedure or entry.
or else or else
(Nkind (N) = N_Explicit_Dereference (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp)
and then Ekind (Etype (N)) = E_Subprogram_Type
and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type)
-- Rewrite as call if it is a selected component which is a function, -- Rewrite as call if it is a selected component which is a function,
-- this is the case of a call to a protected function (which may be -- this is the case of a call to a protected function (which may be
...@@ -858,7 +893,7 @@ package body Sem_Res is ...@@ -858,7 +893,7 @@ package body Sem_Res is
then then
Nam := New_Copy (N); Nam := New_Copy (N);
-- If overloaded, overload set belongs to new copy. -- If overloaded, overload set belongs to new copy
Save_Interps (N, Nam); Save_Interps (N, Nam);
...@@ -2515,7 +2550,6 @@ package body Sem_Res is ...@@ -2515,7 +2550,6 @@ package body Sem_Res is
begin begin
A := First_Actual (N); A := First_Actual (N);
F := First_Formal (Nam); F := First_Formal (Nam);
while Present (F) loop while Present (F) loop
if No (A) and then Needs_No_Actuals (Nam) then if No (A) and then Needs_No_Actuals (Nam) then
null; null;
...@@ -4796,9 +4830,11 @@ package body Sem_Res is ...@@ -4796,9 +4830,11 @@ package body Sem_Res is
---------------------------------- ----------------------------------
procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
P : constant Node_Id := Prefix (N); Loc : constant Source_Ptr := Sloc (N);
I : Interp_Index; New_N : Node_Id;
It : Interp; P : constant Node_Id := Prefix (N);
I : Interp_Index;
It : Interp;
begin begin
-- Now that we know the type, check that this is not a -- Now that we know the type, check that this is not a
...@@ -4824,7 +4860,39 @@ package body Sem_Res is ...@@ -4824,7 +4860,39 @@ package body Sem_Res is
Get_Next_Interp (I, It); Get_Next_Interp (I, It);
end loop; end loop;
Resolve (P, It.Typ); if Present (It.Typ) then
Resolve (P, It.Typ);
else
-- If no interpretation covers the designated type of the
-- prefix, this is the pathological case where not all
-- implementations of the prefix allow the interpretation
-- of the node as a call. Now that the expected type is known,
-- Remove other interpretations from prefix, rewrite it as
-- a call, and resolve again, so that the proper call node
-- is generated.
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
if Ekind (It.Typ) /= E_Access_Subprogram_Type then
Remove_Interp (I);
end if;
Get_Next_Interp (I, It);
end loop;
New_N :=
Make_Function_Call (Loc,
Name =>
Make_Explicit_Dereference (Loc,
Prefix => P),
Parameter_Associations => New_List);
Save_Interps (N, New_N);
Rewrite (N, New_N);
Analyze_And_Resolve (N, Typ);
return;
end if;
Set_Etype (N, Designated_Type (It.Typ)); Set_Etype (N, Designated_Type (It.Typ));
else else
...@@ -5667,6 +5735,16 @@ package body Sem_Res is ...@@ -5667,6 +5735,16 @@ package body Sem_Res is
Error_Msg_N ("value has extraneous low order digits", N); Error_Msg_N ("value has extraneous low order digits", N);
end if; end if;
-- Generate a warning if literal from source
if Is_Static_Expression (N)
and then Warn_On_Bad_Fixed_Value
then
Error_Msg_N
("static fixed-point value is not a multiple of Small?",
N);
end if;
-- Replace literal by a value that is the exact representation -- Replace literal by a value that is the exact representation
-- of a value of the type, i.e. a multiple of the small value, -- of a value of the type, i.e. a multiple of the small value,
-- by truncation, since Machine_Rounds is false for all GNAT -- by truncation, since Machine_Rounds is false for all GNAT
...@@ -5678,6 +5756,8 @@ package body Sem_Res is ...@@ -5678,6 +5756,8 @@ package body Sem_Res is
Realval => Small_Value (Typ) * Cint)); Realval => Small_Value (Typ) * Cint));
Set_Is_Static_Expression (N, Stat); Set_Is_Static_Expression (N, Stat);
end if; end if;
-- In all cases, set the corresponding integer field -- In all cases, set the corresponding integer field
...@@ -6351,8 +6431,7 @@ package body Sem_Res is ...@@ -6351,8 +6431,7 @@ package body Sem_Res is
Set_Etype (Operand, Standard_Duration); Set_Etype (Operand, Standard_Duration);
end if; end if;
-- Resolve the real operand with largest available precision. -- Resolve the real operand with largest available precision
if Etype (Right_Opnd (Operand)) = Universal_Real then if Etype (Right_Opnd (Operand)) = Universal_Real then
Rop := New_Copy_Tree (Right_Opnd (Operand)); Rop := New_Copy_Tree (Right_Opnd (Operand));
else else
...@@ -6787,7 +6866,7 @@ package body Sem_Res is ...@@ -6787,7 +6866,7 @@ package body Sem_Res is
T1 := Standard_Duration; T1 := Standard_Duration;
-- Look for fixed-point types in enclosing scopes. -- Look for fixed-point types in enclosing scopes
Scop := Current_Scope; Scop := Current_Scope;
while Scop /= Standard_Standard loop while Scop /= Standard_Standard loop
...@@ -7219,19 +7298,16 @@ package body Sem_Res is ...@@ -7219,19 +7298,16 @@ package body Sem_Res is
elsif (Ekind (Target_Type) = E_Access_Subprogram_Type elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
or else or else
Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type) Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
and then No (Corresponding_Remote_Type (Opnd_Type))
and then Conversion_Check and then Conversion_Check
(Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type, (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
"illegal operand for access subprogram conversion") "illegal operand for access subprogram conversion")
then then
-- Check that the designated types are subtype conformant -- Check that the designated types are subtype conformant
if not Subtype_Conformant (Designated_Type (Opnd_Type), Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type),
Designated_Type (Target_Type)) Old_Id => Designated_Type (Opnd_Type),
then Err_Loc => N);
Error_Msg_N
("operand type is not subtype conformant with target type",
Operand);
end if;
-- Check the static accessibility rule of 4.6(20) -- Check the static accessibility rule of 4.6(20)
......
...@@ -105,6 +105,8 @@ gcc -c ^ GNAT COMPILE ...@@ -105,6 +105,8 @@ gcc -c ^ GNAT COMPILE
-gnatw ^ /WARNINGS -gnatw ^ /WARNINGS
-gnatwa ^ /WARNINGS=OPTIONAL -gnatwa ^ /WARNINGS=OPTIONAL
-gnatwA ^ /WARNINGS=NOOPTIONAL -gnatwA ^ /WARNINGS=NOOPTIONAL
-gnatwb ^ /WARNINGS=BAD_FIXED_VALUES
-gnatwB ^ /WARNINGS=NO_BAD_FIXED_VALUES
-gnatwc ^ /WARNINGS=CONDITIONALS -gnatwc ^ /WARNINGS=CONDITIONALS
-gnatwC ^ /WARNINGS=NOCONDITIONALS -gnatwC ^ /WARNINGS=NOCONDITIONALS
-gnatwd ^ /WARNINGS=IMPLICIT_DEREFERENCE -gnatwd ^ /WARNINGS=IMPLICIT_DEREFERENCE
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment