Commit 66150d01 by Arnaud Charlet

[multiple changes]

2010-10-25  Robert Dewar  <dewar@adacore.com>

	* sem_warn.adb, einfo.ads, exp_ch4.adb: Minor comment fix
	* sem_case.adb: Comment clarification for loops through false
	predicates.
	* sem_util.adb: Minor reformatting
	(Check_Order_Dependence): Fix bad double blank in error message

2010-10-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_Membership_Op): in Ada_2012 a membership
	operation can have a single alternative that is a value of the type.
	Rewrite operation as an equality test.

From-SVN: r165918
parent 1e194575
2010-10-25 Robert Dewar <dewar@adacore.com>
* sem_warn.adb, einfo.ads, exp_ch4.adb: Minor comment fix
* sem_case.adb: Comment clarification for loops through false
predicates.
* sem_util.adb: Minor reformatting
(Check_Order_Dependence): Fix bad double blank in error message
2010-10-25 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Analyze_Membership_Op): in Ada_2012 a membership
operation can have a single alternative that is a value of the type.
Rewrite operation as an equality test.
2010-10-25 Matthew Heaney <heaney@adacore.com> 2010-10-25 Matthew Heaney <heaney@adacore.com>
* Makefile.rtl, impunit.adb: Added a-cobove (bounded vector container) * Makefile.rtl, impunit.adb: Added a-cobove (bounded vector container)
......
...@@ -3616,7 +3616,8 @@ package Einfo is ...@@ -3616,7 +3616,8 @@ package Einfo is
-- entries sorted in ascending order, with all duplicates eliminated, -- entries sorted in ascending order, with all duplicates eliminated,
-- and adjacent ranges coalesced, so that there is always a gap in the -- and adjacent ranges coalesced, so that there is always a gap in the
-- values between successive entries. The entries in this list are -- values between successive entries. The entries in this list are
-- fully analyzed. -- fully analyzed and typed with the base type of the subtype. Note
-- that all entries are static and have values within the subtype range.
-- Storage_Size_Variable (Node15) [implementation base type only] -- Storage_Size_Variable (Node15) [implementation base type only]
-- Present in access types and task type entities. This flag is set -- Present in access types and task type entities. This flag is set
......
...@@ -4369,7 +4369,7 @@ package body Exp_Ch4 is ...@@ -4369,7 +4369,7 @@ package body Exp_Ch4 is
return Cond; return Cond;
end Make_Cond; end Make_Cond;
-- Start of processing for Expand_N_In -- Start of processing for Expand_Set_Membership
begin begin
Alt := Last (Alternatives (N)); Alt := Last (Alternatives (N));
......
...@@ -878,6 +878,11 @@ package body Sem_Case is ...@@ -878,6 +878,11 @@ package body Sem_Case is
C : Node_Id; C : Node_Id;
begin begin
-- Loop through entries in predicate list,
-- converting to choices. Note that if the
-- list is empty, corresponding to a False
-- predicate, then no choices are inserted.
P := First (Static_Predicate (E)); P := First (Static_Predicate (E));
while Present (P) loop while Present (P) loop
C := New_Copy (P); C := New_Copy (P);
......
...@@ -2276,8 +2276,9 @@ package body Sem_Ch4 is ...@@ -2276,8 +2276,9 @@ package body Sem_Ch4 is
--------------------------- ---------------------------
procedure Analyze_Membership_Op (N : Node_Id) is procedure Analyze_Membership_Op (N : Node_Id) is
L : constant Node_Id := Left_Opnd (N); Loc : constant Source_Ptr := Sloc (N);
R : constant Node_Id := Right_Opnd (N); L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
Index : Interp_Index; Index : Interp_Index;
It : Interp; It : Interp;
...@@ -2439,14 +2440,39 @@ package body Sem_Ch4 is ...@@ -2439,14 +2440,39 @@ package body Sem_Ch4 is
end loop; end loop;
end if; end if;
-- If not a range, it can only be a subtype mark, or else there -- If not a range, it can be a subtype mark, or else it is
-- is a more basic error, to be diagnosed in Find_Type. -- a degenerate membership test with a singleton value, i.e.
-- a test for equality.
else else
Find_Type (R); Analyze (R);
if Is_Entity_Name (R)
if Is_Entity_Name (R) then and then Is_Type (Entity (R))
then
Find_Type (R);
Check_Fully_Declared (Entity (R), R); Check_Fully_Declared (Entity (R), R);
elsif Ada_Version >= Ada_2012 then
if Nkind (N) = N_In then
Rewrite (N,
Make_Op_Eq (Loc,
Left_Opnd => L,
Right_Opnd => R));
else
Rewrite (N,
Make_Op_Ne (Loc,
Left_Opnd => L,
Right_Opnd => R));
end if;
Analyze (N);
return;
else
-- in previous version of the language this is an error
-- that will be diagnosed below.
Find_Type (R);
end if; end if;
end if; end if;
......
...@@ -1226,11 +1226,11 @@ package body Sem_Util is ...@@ -1226,11 +1226,11 @@ package body Sem_Util is
return; return;
end if; end if;
-- Ada2012 AI04-0144-2 : dangerous order dependence. -- Ada 2012 AI04-0144-2 : dangerous order dependence. Actuals in nested
-- Actuals in nested calls within a construct have been collected. -- calls within a construct have been collected. If one of them is
-- If one of them is writeable and overlaps with another one, evaluation -- writable and overlaps with another one, evaluation of the enclosing
-- of the enclosing construct is non-deterministic. -- construct is nondeterministic. This is illegal in Ada 2012, but is
-- This is illegal in Ada2012, but is treated as a warning for now. -- treated as a warning for now.
for J in 1 .. Actuals_In_Call.Last loop for J in 1 .. Actuals_In_Call.Last loop
if Actuals_In_Call.Table (J).Is_Writable then if Actuals_In_Call.Table (J).Is_Writable then
...@@ -1258,16 +1258,16 @@ package body Sem_Util is ...@@ -1258,16 +1258,16 @@ package body Sem_Util is
elsif Denotes_Same_Object (Act1, Act2) elsif Denotes_Same_Object (Act1, Act2)
and then Parent (Act1) /= Parent (Act2) and then Parent (Act1) /= Parent (Act2)
then then
Error_Msg_N ( Error_Msg_N
"result may differ if evaluated " ("result may differ if evaluated "
& " after other actual in expression?", Act1); & "after other actual in expression?", Act1);
end if; end if;
end if; end if;
end loop; end loop;
end if; end if;
end loop; end loop;
-- Remove checked actuals from table. -- Remove checked actuals from table
Actuals_In_Call.Set_Last (0); Actuals_In_Call.Set_Last (0);
end Check_Order_Dependence; end Check_Order_Dependence;
...@@ -2366,9 +2366,13 @@ package body Sem_Util is ...@@ -2366,9 +2366,13 @@ package body Sem_Util is
Obj2 : Node_Id := A2; Obj2 : Node_Id := A2;
procedure Check_Renaming (Obj : in out Node_Id); procedure Check_Renaming (Obj : in out Node_Id);
-- If an object is a renaming, examine renamed object. If is is a -- If an object is a renaming, examine renamed object. If it is a
-- dereference of a variable, or an indexed expression with non- -- dereference of a variable, or an indexed expression with non-constant
-- constant indices, no overlap check can be reported. -- indexes, no overlap check can be reported.
--------------------
-- Check_Renaming --
--------------------
procedure Check_Renaming (Obj : in out Node_Id) is procedure Check_Renaming (Obj : in out Node_Id) is
begin begin
...@@ -2400,6 +2404,8 @@ package body Sem_Util is ...@@ -2400,6 +2404,8 @@ package body Sem_Util is
end if; end if;
end Check_Renaming; end Check_Renaming;
-- Start of processing for Denotes_Same_Object
begin begin
Check_Renaming (Obj1); Check_Renaming (Obj1);
Check_Renaming (Obj2); Check_Renaming (Obj2);
...@@ -2449,8 +2455,7 @@ package body Sem_Util is ...@@ -2449,8 +2455,7 @@ package body Sem_Util is
Indx2 := First (Expressions (Obj2)); Indx2 := First (Expressions (Obj2));
while Present (Indx1) loop while Present (Indx1) loop
-- Indices must denote the same static value or the same -- Indexes must denote the same static value or same object
-- object.
if Is_OK_Static_Expression (Indx1) then if Is_OK_Static_Expression (Indx1) then
if not Is_OK_Static_Expression (Indx2) then if not Is_OK_Static_Expression (Indx2) then
...@@ -7989,7 +7994,7 @@ package body Sem_Util is ...@@ -7989,7 +7994,7 @@ package body Sem_Util is
-- Positional parameter for subprogram, entry, or accept call. -- Positional parameter for subprogram, entry, or accept call.
-- In older versions of Ada function call arguments are never -- In older versions of Ada function call arguments are never
-- lvalues. In Ada2012 functions can have in-out parameters. -- lvalues. In Ada 2012 functions can have in-out parameters.
when N_Function_Call | when N_Function_Call |
N_Procedure_Call_Statement | N_Procedure_Call_Statement |
......
...@@ -3739,8 +3739,8 @@ package body Sem_Warn is ...@@ -3739,8 +3739,8 @@ package body Sem_Warn is
elsif Nkind (Act2) = N_Function_Call then elsif Nkind (Act2) = N_Function_Call then
null; null;
-- If type is not by-copy we can assume that the aliasing -- If type is not by-copy we can assume that the aliasing is
-- is intended. -- intended.
elsif elsif
Is_By_Reference_Type (Underlying_Type (Etype (Form1))) Is_By_Reference_Type (Underlying_Type (Etype (Form1)))
......
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