Duplicated index values are now displayed for case statement and
error flags for both duplicated and missing case values are placed
more precisely as shown by the compilation of the following test
compiled with -gnatj60.
1. package dupaggr is
2. type enum is (a, b, c, d, e, f);
3. type ar is array (enum) of integer;
4. av1 : ar := (a => 3,
5. c .. d => 4,
|
>>> missing index value in array aggregate
"b"
6. f => 23);
|
>>> missing index value in array aggregate
"e"
7.
8. av2 : ar := (a .. c => 4,
9. b .. e => 10,
|
>>> index values in array aggregate duplicate those
given at line 8
"b" .. "c"
10. e .. f => 23);
|
>>> index value in array aggregate duplicates the
one given at line 9
"e"
11.
12. av3 : ar := (a .. c => 4,
13. e => 19,
|
>>> missing index value in array aggregate
"d"
14. e .. f => 23);
|
>>> index value in array aggregate duplicates the
one given at line 13
"e"
15.
16. av4 : ar := (a => 3, c.. d => 4, f => 23);
1 2
>>> missing index value in array aggregate
"b"
>>> missing index value in array aggregate
"e"
17.
18. av5 : ar := (a .. c => 4, b .. e => 10, e .. f => 23);
1 2
>>> index values in array aggregate duplicate those
given at line 18
"b" .. "c"
>>> index value in array aggregate duplicates the
one given at line 18
"e"
19.
20. av6 : ar := (a .. b => 4, e => 19, e .. f => 23);
1 2
>>> missing index values in array aggregate
"c" .. "d"
>>> index value in array aggregate duplicates the
one given at line 20
"e"
21. end dupaggr;
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-10 Robert Dewar <de...@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): Identify duplicated
cases.
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 203358)
+++ sem_aggr.adb (working copy)
@@ -1723,9 +1723,9 @@
-- Variables local to Resolve_Array_Aggregate
- Assoc : Node_Id;
- Choice : Node_Id;
- Expr : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Expr : Node_Id;
Discard : Node_Id;
pragma Warnings (Off, Discard);
@@ -1900,14 +1900,6 @@
High : Node_Id;
-- Denote the lowest and highest values in an aggregate choice
- Hi_Val : Uint;
- Lo_Val : Uint;
- -- High end of one range and Low end of the next. Should be
- -- contiguous if there is no hole in the list of values.
-
- Missing_Values : Boolean;
- -- Set True if missing index values
-
S_Low : Node_Id := Empty;
S_High : Node_Id := Empty;
-- if a choice in an aggregate is a subtype indication these
@@ -2064,14 +2056,14 @@
-- Resolve_Aggr_Expr to check the rules about
-- dimensionality.
- if not Resolve_Aggr_Expr (Assoc,
- Single_Elmt => Single_Choice)
+ if not Resolve_Aggr_Expr
+ (Assoc, Single_Elmt => Single_Choice)
then
return Failure;
end if;
- elsif not Resolve_Aggr_Expr (Expression (Assoc),
- Single_Elmt => Single_Choice)
+ elsif not Resolve_Aggr_Expr
+ (Expression (Assoc), Single_Elmt => Single_Choice)
then
return Failure;
@@ -2134,80 +2126,129 @@
end loop;
-- If aggregate contains more than one choice then these must be
- -- static. Sort them and check that they are contiguous.
+ -- static. Check for duplicate and missing values.
+ -- Note: there is duplicated code here wrt Check_Choice_Set in
+ -- the body of Sem_Case, and it is possible we could just reuse
+ -- that procedure. To be checked ???
+
if Nb_Discrete_Choices > 1 then
- Sort_Case_Table (Table);
- Missing_Values := False;
+ Check_Choices : declare
+ Choice : Node_Id;
+ -- Location of choice for messages
- Outer : for J in 1 .. Nb_Discrete_Choices - 1 loop
- if Expr_Value (Table (J).Choice_Hi) >=
- Expr_Value (Table (J + 1).Choice_Lo)
- then
- Error_Msg_N
- ("duplicate choice values in array aggregate",
- Table (J).Choice_Node);
- return Failure;
+ Hi_Val : Uint;
+ Lo_Val : Uint;
+ -- High end of one range and Low end of the next. Should be
+ -- contiguous if there is no hole in the list of values.
- elsif not Others_Present then
- Hi_Val := Expr_Value (Table (J).Choice_Hi);
- Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
+ Missing_Or_Duplicates : Boolean := False;
+ -- Set True if missing or duplicate choices found
- -- If missing values, output error messages
+ procedure Output_Bad_Choices (Lo, Hi : Uint; C : Node_Id);
+ -- Output continuation message with a representation of the
+ -- bounds (just Lo if Lo = Hi, else Lo .. Hi). C is the
+ -- choice node where the message is to be posted.
- if Lo_Val - Hi_Val > 1 then
+ ------------------------
+ -- Output_Bad_Choices --
+ ------------------------
- -- Header message if not first missing value
+ procedure Output_Bad_Choices (Lo, Hi : Uint; C : Node_Id) is
+ begin
+ -- Enumeration type case
- if not Missing_Values then
- Error_Msg_N
- ("missing index value(s) in array aggregate", N);
- Missing_Values := True;
+ if Is_Enumeration_Type (Index_Typ) then
+ Error_Msg_Name_1 :=
+ Chars (Get_Enum_Lit_From_Pos (Index_Typ, Lo, Loc));
+ Error_Msg_Name_2 :=
+ Chars (Get_Enum_Lit_From_Pos (Index_Typ, Hi, Loc));
+
+ if Lo = Hi then
+ Error_Msg_N ("\\ %!", C);
+ else
+ Error_Msg_N ("\\ % .. %!", C);
end if;
- -- Output values of missing indexes
+ -- Integer types case
- Lo_Val := Lo_Val - 1;
- Hi_Val := Hi_Val + 1;
+ else
+ Error_Msg_Uint_1 := Lo;
+ Error_Msg_Uint_2 := Hi;
- -- Enumeration type case
+ if Lo = Hi then
+ Error_Msg_N ("\\ ^!", C);
+ else
+ Error_Msg_N ("\\ ^ .. ^!", C);
+ end if;
+ end if;
+ end Output_Bad_Choices;
- if Is_Enumeration_Type (Index_Typ) then
- Error_Msg_Name_1 :=
- Chars
- (Get_Enum_Lit_From_Pos
- (Index_Typ, Hi_Val, Loc));
+ -- Start of processing for Check_Choices
- if Lo_Val = Hi_Val then
- Error_Msg_N ("\ %", N);
- else
- Error_Msg_Name_2 :=
- Chars
- (Get_Enum_Lit_From_Pos
- (Index_Typ, Lo_Val, Loc));
- Error_Msg_N ("\ % .. %", N);
- end if;
+ begin
+ Sort_Case_Table (Table);
- -- Integer types case
+ -- Loop through entries in table to find duplicate indexes
+ for J in 1 .. Nb_Discrete_Choices - 1 loop
+ Hi_Val := Expr_Value (Table (J).Choice_Hi);
+ Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
+
+ if Hi_Val >= Lo_Val then
+ Choice := Table (J + 1).Choice_Lo;
+ Error_Msg_Sloc := Sloc (Table (J).Choice_Hi);
+
+ if Hi_Val = Lo_Val then
+ Error_Msg_N
+ ("index value in array aggregate duplicates "
+ & "the one given#",
+ Choice);
else
- Error_Msg_Uint_1 := Hi_Val;
+ Error_Msg_N
+ ("index values in array aggregate duplicate "
+ & "those given#", Choice);
+ end if;
- if Lo_Val = Hi_Val then
- Error_Msg_N ("\ ^", N);
+ Missing_Or_Duplicates := True;
+ Output_Bad_Choices (Lo_Val, Hi_Val, Choice);
+ end if;
+ end loop;
+
+ -- Loop through entries in table to find missing indexes.
+ -- Not needed if others present, since missing impossible.
+
+ if not Others_Present then
+ for J in 1 .. Nb_Discrete_Choices - 1 loop
+ Hi_Val := Expr_Value (Table (J).Choice_Hi);
+ Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
+
+ if Hi_Val < Lo_Val - 1 then
+ Choice := Table (J + 1).Choice_Lo;
+
+ if Hi_Val + 1 = Lo_Val - 1 then
+ Error_Msg_N
+ ("missing index value in array aggregate!",
+ Choice);
else
- Error_Msg_Uint_2 := Lo_Val;
- Error_Msg_N ("\ ^ .. ^", N);
+ Error_Msg_N
+ ("missing index values in array aggregate!",
+ Choice);
end if;
+
+ Missing_Or_Duplicates := True;
+ Output_Bad_Choices (Hi_Val + 1, Lo_Val - 1, Choice);
end if;
- end if;
+ end loop;
end if;
- end loop Outer;
- if Missing_Values then
- Set_Etype (N, Any_Composite);
- return Failure;
- end if;
+ -- If either missing or duplicate values, return failure
+
+ if Missing_Or_Duplicates then
+ Set_Etype (N, Any_Composite);
+ return Failure;
+ end if;
+ end Check_Choices;
end if;
-- STEP 2 (B): Compute aggregate bounds and min/max choices values
