Skip to content

R
riscv-gcc-1
Commit 9a0ddeee by Arnaud Charlet
Options

[multiple changes] 

2010-06-23  Thomas Quinot  <quinot@adacore.com>

	* sem_util.adb: Minor code cleanup: test for proper entity instead of
	testing just Chars attribute when checking whether a given scope is
	System.
	* exp_ch4.adb, einfo.adb: Minor reformatting.

2010-06-23  Vincent Celier  <celier@adacore.com>

	PR ada/44633
	* switch-m.adb (Normalize_Compiler_Switches): Take into account
	switches -gnatB, -gnatD=nn, -gnatG (incuding -gnatG=nn), -gnatI,
	-gnatl=file, -gnatS, -gnatjnn, -gnateI=nn and -gnatWx.

2010-06-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Membership_Op): If left operand is a mixed mode
	operation with a universal real operand, and the right operand is a
	range with universal bounds, find unique fixed point that may be
	candidate, and warn appropriately.

From-SVN: r161264
parent bb481772
Showing with 178 additions and 91 deletions
gcc/ada/ChangeLog
2010-06-23 Thomas Quinot <quinot@adacore.com>
* sem_util.adb: Minor code cleanup: test for proper entity instead of
testing just Chars attribute when checking whether a given scope is
System.
* exp_ch4.adb, einfo.adb: Minor reformatting.
2010-06-23 Vincent Celier <celier@adacore.com>
PR ada/44633
* switch-m.adb (Normalize_Compiler_Switches): Take into account
switches -gnatB, -gnatD=nn, -gnatG (incuding -gnatG=nn), -gnatI,
-gnatl=file, -gnatS, -gnatjnn, -gnateI=nn and -gnatWx.
2010-06-23 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Membership_Op): If left operand is a mixed mode
operation with a universal real operand, and the right operand is a
range with universal bounds, find unique fixed point that may be
candidate, and warn appropriately.
2010-06-23 Ed Schonberg <schonberg@adacore.com> 2010-06-23 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Intrinsic_Operator): Add guards to handle * sem_res.adb (Resolve_Intrinsic_Operator): Add guards to handle
......
gcc/ada/einfo.adb
...@@ -5856,7 +5856,7 @@ package body Einfo is ...@@ -5856,7 +5856,7 @@ package body Einfo is
return Convention (Id) in Foreign_Convention return Convention (Id) in Foreign_Convention
or else (Convention (Id) = Convention_Intrinsic or else (Convention (Id) = Convention_Intrinsic
and then Present (Interface_Name (Id))); and then Present (Interface_Name (Id)));
end Has_Foreign_Convention; end Has_Foreign_Convention;
--------------------------- ---------------------------
......
gcc/ada/exp_ch4.adb
...@@ -4378,9 +4378,9 @@ package body Exp_Ch4 is ...@@ -4378,9 +4378,9 @@ package body Exp_Ch4 is
-- Check case of explicit test for an expression in range of its -- Check case of explicit test for an expression in range of its
-- subtype. This is suspicious usage and we replace it with a 'Valid -- subtype. This is suspicious usage and we replace it with a 'Valid
-- test and give a warning. For floating point types however, this -- test and give a warning. For floating point types however, this is a
-- is a standard way to check for finite numbers, and using 'Valid -- standard way to check for finite numbers, and using 'Valid vould
-- would typically be a pessimization -- typically be a pessimization.
if Is_Scalar_Type (Etype (Lop)) if Is_Scalar_Type (Etype (Lop))
and then not Is_Floating_Point_Type (Etype (Lop)) and then not Is_Floating_Point_Type (Etype (Lop))
...@@ -4420,9 +4420,9 @@ package body Exp_Ch4 is ...@@ -4420,9 +4420,9 @@ package body Exp_Ch4 is
and then Comes_From_Source (N) and then Comes_From_Source (N)
and then not In_Instance; and then not In_Instance;
-- This must be true for any of the optimization warnings, we -- This must be true for any of the optimization warnings, we
-- clearly want to give them only for source with the flag on. -- clearly want to give them only for source with the flag on. We
-- We also skip these warnings in an instance since it may be -- also skip these warnings in an instance since it may be the
-- the case that different instantiations have different ranges. -- case that different instantiations have different ranges.
Warn2 : constant Boolean := Warn2 : constant Boolean :=
Warn1 Warn1
...@@ -4431,8 +4431,8 @@ package body Exp_Ch4 is ...@@ -4431,8 +4431,8 @@ package body Exp_Ch4 is
-- For the case where only one bound warning is elided, we also -- For the case where only one bound warning is elided, we also
-- insist on an explicit range and an integer type. The reason is -- insist on an explicit range and an integer type. The reason is
-- that the use of enumeration ranges including an end point is -- that the use of enumeration ranges including an end point is
-- common, as is the use of a subtype name, one of whose bounds -- common, as is the use of a subtype name, one of whose bounds is
-- is the same as the type of the expression. -- the same as the type of the expression.
begin begin
-- If test is explicit x'first .. x'last, replace by valid check -- If test is explicit x'first .. x'last, replace by valid check
...@@ -4477,8 +4477,8 @@ package body Exp_Ch4 is ...@@ -4477,8 +4477,8 @@ package body Exp_Ch4 is
return; return;
end if; end if;
-- If we have an explicit range, do a bit of optimization based -- If we have an explicit range, do a bit of optimization based on
-- on range analysis (we may be able to kill one or both checks). -- range analysis (we may be able to kill one or both checks).
Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False); Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False); Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
...@@ -4493,8 +4493,7 @@ package body Exp_Ch4 is ...@@ -4493,8 +4493,7 @@ package body Exp_Ch4 is
Error_Msg_N ("\?value is known to be out of range", N); Error_Msg_N ("\?value is known to be out of range", N);
end if; end if;
Rewrite (N, Rewrite (N, New_Reference_To (Standard_False, Loc));
New_Reference_To (Standard_False, Loc));
Analyze_And_Resolve (N, Rtyp); Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static); Set_Is_Static_Expression (N, Static);
...@@ -4509,8 +4508,7 @@ package body Exp_Ch4 is ...@@ -4509,8 +4508,7 @@ package body Exp_Ch4 is
Error_Msg_N ("\?value is known to be in range", N); Error_Msg_N ("\?value is known to be in range", N);
end if; end if;
Rewrite (N, Rewrite (N, New_Reference_To (Standard_True, Loc));
New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp); Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static); Set_Is_Static_Expression (N, Static);
...@@ -4624,9 +4622,7 @@ package body Exp_Ch4 is ...@@ -4624,9 +4622,7 @@ package body Exp_Ch4 is
-- Update decoration of relocated node referenced by the -- Update decoration of relocated node referenced by the
-- SCIL node. -- SCIL node.
if Generate_SCIL if Generate_SCIL and then Present (SCIL_Node) then
and then Present (SCIL_Node)
then
Set_SCIL_Node (N, SCIL_Node); Set_SCIL_Node (N, SCIL_Node);
end if; end if;
end if; end if;
...@@ -4666,12 +4662,10 @@ package body Exp_Ch4 is ...@@ -4666,12 +4662,10 @@ package body Exp_Ch4 is
Make_Raise_Program_Error (Loc, Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction)); Reason => PE_Unchecked_Union_Restriction));
-- Prevent Gigi from generating incorrect code by rewriting -- Prevent Gigi from generating incorrect code by rewriting the
-- the test as a standard False. -- test as False.
Rewrite (N,
New_Occurrence_Of (Standard_False, Loc));
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
return; return;
end if; end if;
...@@ -4682,8 +4676,7 @@ package body Exp_Ch4 is ...@@ -4682,8 +4676,7 @@ package body Exp_Ch4 is
end if; end if;
if not Is_Constrained (Typ) then if not Is_Constrained (Typ) then
Rewrite (N, Rewrite (N, New_Reference_To (Standard_True, Loc));
New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp); Analyze_And_Resolve (N, Rtyp);
-- For the constrained array case, we have to check the subscripts -- For the constrained array case, we have to check the subscripts
...@@ -4691,19 +4684,18 @@ package body Exp_Ch4 is ...@@ -4691,19 +4684,18 @@ package body Exp_Ch4 is
-- must match in any case). -- must match in any case).
elsif Is_Array_Type (Typ) then elsif Is_Array_Type (Typ) then
Check_Subscripts : declare Check_Subscripts : declare
function Construct_Attribute_Reference function Build_Attribute_Reference
(E : Node_Id; (E : Node_Id;
Nam : Name_Id; Nam : Name_Id;
Dim : Nat) return Node_Id; Dim : Nat) return Node_Id;
-- Build attribute reference E'Nam(Dim) -- Build attribute reference E'Nam (Dim)
----------------------------------- -------------------------------
-- Construct_Attribute_Reference -- -- Build_Attribute_Reference --
----------------------------------- -------------------------------
function Construct_Attribute_Reference function Build_Attribute_Reference
(E : Node_Id; (E : Node_Id;
Nam : Name_Id; Nam : Name_Id;
Dim : Nat) return Node_Id Dim : Nat) return Node_Id
...@@ -4711,11 +4703,11 @@ package body Exp_Ch4 is ...@@ -4711,11 +4703,11 @@ package body Exp_Ch4 is
begin begin
return return
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => E, Prefix => E,
Attribute_Name => Nam, Attribute_Name => Nam,
Expressions => New_List ( Expressions => New_List (
Make_Integer_Literal (Loc, Dim))); Make_Integer_Literal (Loc, Dim)));
end Construct_Attribute_Reference; end Build_Attribute_Reference;
-- Start of processing for Check_Subscripts -- Start of processing for Check_Subscripts
...@@ -4724,21 +4716,21 @@ package body Exp_Ch4 is ...@@ -4724,21 +4716,21 @@ package body Exp_Ch4 is
Evolve_And_Then (Cond, Evolve_And_Then (Cond,
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd =>
Construct_Attribute_Reference Build_Attribute_Reference
(Duplicate_Subexpr_No_Checks (Obj), (Duplicate_Subexpr_No_Checks (Obj),
Name_First, J), Name_First, J),
Right_Opnd => Right_Opnd =>
Construct_Attribute_Reference Build_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_First, J))); (New_Occurrence_Of (Typ, Loc), Name_First, J)));
Evolve_And_Then (Cond, Evolve_And_Then (Cond,
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd =>
Construct_Attribute_Reference Build_Attribute_Reference
(Duplicate_Subexpr_No_Checks (Obj), (Duplicate_Subexpr_No_Checks (Obj),
Name_Last, J), Name_Last, J),
Right_Opnd => Right_Opnd =>
Construct_Attribute_Reference Build_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_Last, J))); (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
end loop; end loop;
......
gcc/ada/sem_res.adb
...@@ -7036,6 +7036,18 @@ package body Sem_Res is ...@@ -7036,6 +7036,18 @@ package body Sem_Res is
T := Intersect_Types (L, R); T := Intersect_Types (L, R);
end if; end if;
-- If mixed-mode operations are present and operands are all literal,
-- the only interpretation involves Duration, which is probably not
-- the intention of the programmer.
if T = Any_Fixed then
T := Unique_Fixed_Point_Type (N);
if T = Any_Type then
return;
end if;
end if;
Resolve (L, T); Resolve (L, T);
Check_Unset_Reference (L); Check_Unset_Reference (L);
......
gcc/ada/sem_util.adb
...@@ -1770,8 +1770,7 @@ package body Sem_Util is ...@@ -1770,8 +1770,7 @@ package body Sem_Util is
-- appear in the target-specific extension to System. -- appear in the target-specific extension to System.
if No (Id) if No (Id)
and then Chars (B_Scope) = Name_System and then B_Scope = RTU_Entity (System)
and then Scope (B_Scope) = Standard_Standard
and then Present_System_Aux and then Present_System_Aux
then then
B_Scope := System_Aux_Id; B_Scope := System_Aux_Id;
...@@ -7225,7 +7224,7 @@ package body Sem_Util is ...@@ -7225,7 +7224,7 @@ package body Sem_Util is
and then Scope (Op) = System_Aux_Id) and then Scope (Op) = System_Aux_Id)
or else or else
(True_VMS_Target (True_VMS_Target
and then Chars (Scope (Scope (Op))) = Name_System)); and then Scope (Scope (Op)) = RTU_Entity (System)));
end Is_VMS_Operator; end Is_VMS_Operator;
----------------- -----------------
......
gcc/ada/switch-m.adb
...@@ -215,9 +215,9 @@ package body Switch.M is ...@@ -215,9 +215,9 @@ package body Switch.M is
-- One-letter switches -- One-letter switches
when 'a' | 'A' | 'b' | 'c' | 'C' | 'D' | 'E' | 'f' | when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' |
'F' | 'g' | 'h' | 'H' | 'l' | 'L' | 'n' | 'N' | 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'n' | 'N' |
'o' | 'O' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'o' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'S' |
't' | 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => 't' | 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' =>
Storing (First_Stored) := C; Storing (First_Stored) := C;
Add_Switch_Component Add_Switch_Component
...@@ -226,10 +226,14 @@ package body Switch.M is ...@@ -226,10 +226,14 @@ package body Switch.M is
-- One-letter switches followed by a positive number -- One-letter switches followed by a positive number
when 'k' | 'm' | 'T' => when 'D' | 'G' | 'j' | 'k' | 'm' | 'T' =>
Storing (First_Stored) := C; Storing (First_Stored) := C;
Last_Stored := First_Stored; Last_Stored := First_Stored;
if Ptr <= Max and then Switch_Chars (Ptr) = '=' then
Ptr := Ptr + 1;
end if;
loop loop
Ptr := Ptr + 1; Ptr := Ptr + 1;
exit when Ptr > Max exit when Ptr > Max
...@@ -268,68 +272,93 @@ package body Switch.M is ...@@ -268,68 +272,93 @@ package body Switch.M is
when 'e' => when 'e' =>
-- Store -gnateD, -gnatep=, -gnateG and -gnateS in the -- Some of the gnate... switches are not stored
-- ALI file. The other -gnate switches do not need to be
-- stored.
Storing (First_Stored) := 'e'; Storing (First_Stored) := 'e';
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Ptr > Max if Ptr > Max then
or else (Switch_Chars (Ptr) /= 'D'
and then Switch_Chars (Ptr) /= 'G'
and then Switch_Chars (Ptr) /= 'p'
and then Switch_Chars (Ptr) /= 'S')
then
Last := 0; Last := 0;
return; return;
end if;
-- Processing for -gnateD else
case Switch_Chars (Ptr) is
if Switch_Chars (Ptr) = 'D' then when 'D' =>
Storing (First_Stored + 1 .. Storing (First_Stored + 1 ..
First_Stored + Max - Ptr + 1) := First_Stored + Max - Ptr + 1) :=
Switch_Chars (Ptr .. Max); Switch_Chars (Ptr .. Max);
Add_Switch_Component Add_Switch_Component
(Storing (Storing'First .. (Storing (Storing'First ..
First_Stored + Max - Ptr + 1)); First_Stored + Max - Ptr + 1));
Ptr := Max + 1;
-- Processing for -gnatep= when 'G' =>
Ptr := Ptr + 1;
Add_Switch_Component ("-gnateG");
elsif Switch_Chars (Ptr) = 'p' then when 'I' =>
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Ptr = Max then declare
Last := 0; First : constant Positive := Ptr - 1;
return; begin
end if; if Ptr <= Max and then
Switch_Chars (Ptr) = '='
then
Ptr := Ptr + 1;
end if;
while Ptr <= Max and then
Switch_Chars (Ptr) in '0' .. '9'
loop
Ptr := Ptr + 1;
end loop;
Storing (First_Stored + 1 ..
First_Stored + Ptr - First) :=
Switch_Chars (First .. Ptr - 1);
Add_Switch_Component
(Storing (Storing'First ..
First_Stored + Ptr - First));
end;
when 'p' =>
Ptr := Ptr + 1;
if Switch_Chars (Ptr) = '=' then if Ptr = Max then
Ptr := Ptr + 1; Last := 0;
end if; return;
end if;
-- To normalize, always put a '=' after -gnatep. if Switch_Chars (Ptr) = '=' then
-- Because that could lengthen the switch string, Ptr := Ptr + 1;
-- declare a local variable. end if;
declare -- To normalize, always put a '=' after
To_Store : String (1 .. Max - Ptr + 9); -- -gnatep. Because that could lengthen the
begin -- switch string, declare a local variable.
To_Store (1 .. 8) := "-gnatep=";
To_Store (9 .. Max - Ptr + 9) :=
Switch_Chars (Ptr .. Max);
Add_Switch_Component (To_Store);
end;
elsif Switch_Chars (Ptr) = 'G' then declare
Add_Switch_Component ("-gnateG"); To_Store : String (1 .. Max - Ptr + 9);
begin
To_Store (1 .. 8) := "-gnatep=";
To_Store (9 .. Max - Ptr + 9) :=
Switch_Chars (Ptr .. Max);
Add_Switch_Component (To_Store);
end;
elsif Switch_Chars (Ptr) = 'S' then return;
Add_Switch_Component ("-gnateS");
end if;
return; when 'S' =>
Ptr := Ptr + 1;
Add_Switch_Component ("-gnateS");
when others =>
Last := 0;
return;
end case;
end if;
when 'i' => when 'i' =>
Storing (First_Stored) := 'i'; Storing (First_Stored) := 'i';
...@@ -360,6 +389,20 @@ package body Switch.M is ...@@ -360,6 +389,20 @@ package body Switch.M is
return; return;
end if; end if;
-- -gnatl may be -gnatl=<file name>
when 'l' =>
Ptr := Ptr + 1;
if Ptr > Max or else Switch_Chars (Ptr) /= '=' then
Add_Switch_Component ("-gnatl");
else
Add_Switch_Component
("-gnatl" & Switch_Chars (Ptr .. Max));
return;
end if;
-- -gnatR may be followed by '0', '1', '2' or '3', -- -gnatR may be followed by '0', '1', '2' or '3',
-- then by 's' -- then by 's'
...@@ -395,6 +438,26 @@ package body Switch.M is ...@@ -395,6 +438,26 @@ package body Switch.M is
Add_Switch_Component Add_Switch_Component
(Storing (Storing'First .. Last_Stored)); (Storing (Storing'First .. Last_Stored));
-- -gnatWx, x = 'h'. 'u', 's', 'e', '8' or 'b'
when 'W' =>
Storing (First_Stored) := 'W';
Ptr := Ptr + 1;
if Ptr <= Max then
case Switch_Chars (Ptr) is
when 'h' | 'u' | 's' | 'e' | '8' | 'b' =>
Storing (First_Stored + 1) := Switch_Chars (Ptr);
Add_Switch_Component
(Storing (Storing'First .. First_Stored + 1));
Ptr := Ptr + 1;
when others =>
Last := 0;
return;
end case;
end if;
-- Multiple switches -- Multiple switches
when 'V' | 'w' | 'y' => when 'V' | 'w' | 'y' =>
......
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