sem_aggr.adb (Resolve_Array_Aggregate): Identify duplicated cases.

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* sem_aggr.adb (Resolve_Array_Aggregate): Identify duplicated
	cases.

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* sem_ch9.adb (Analyze_Task_Body): Aspects are illegal
	(Analyze_Protected_Body): Aspects are illegal.

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* sem_ch6.adb, sem_ch13.adb: Minor reformatting.
	* sem_case.adb (Check_Choices): Fix bad listing of missing
	values from predicated subtype case (Check_Choices): List
	duplicated values.
	* errout.adb (Set_Msg_Text): Process warning tags in VMS mode
	* erroutc.adb (Output_Msg_Text): Handle VMS warning tags
	* gnat_ugn.texi: Document /WARNINGS=TAG_WARNINGS for VMS
	* ug_words: Add entries for -gnatw.d and -gnatw.D
	* vms_data.ads: Add [NO]TAG_WARNINGS for -gnatw.D/-gnatw.d
	* lib-writ.ads: Documentation fixes

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* a-wichha.adb, a-wichha.ads, a-zchhan.adb, a-zchhan.ads
	(Is_Other_Format): New name for Is_Other.
	(Is_Punctuation_Connector): New name for Is_Punctuation

From-SVN: r203366

1 files changed, 61 insertions, 11 deletions

diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index 919ac8d..68ac66a 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -126,6 +126,10 @@ package body Sem_Case is
       --  choice that covered a predicate set. Error denotes whether the check
       --  found an illegal intersection.
 
+      procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
+      --  Post message "duplication of choice value(s) bla bla at xx". Message
+      --  is posted at location C. Caller sets Error_Msg_Sloc for xx.
+
       procedure Explain_Non_Static_Bound;
       --  Called when we find a non-static bound, requiring the base type to
       --  be covered. Provides where possible a helpful explanation of why the
@@ -237,6 +241,7 @@ package body Sem_Case is
          Choice_Hi : constant Uint := Expr_Value (Choice.Hi);
          Choice_Lo : constant Uint := Expr_Value (Choice.Lo);
          Loc       : Source_Ptr;
+         LocN      : Node_Id;
          Next_Hi   : Uint;
          Next_Lo   : Uint;
          Pred_Hi   : Uint;
@@ -248,11 +253,13 @@ package body Sem_Case is
          --  Find the proper error message location
 
          if Present (Choice.Node) then
-            Loc := Sloc (Choice.Node);
+            LocN := Choice.Node;
          else
-            Loc := Sloc (Case_Node);
+            LocN := Case_Node;
          end if;
 
+         Loc := Sloc (LocN);
+
          if Present (Pred) then
             Pred_Lo := Expr_Value (Low_Bound  (Pred));
             Pred_Hi := Expr_Value (High_Bound (Pred));
@@ -267,10 +274,12 @@ package body Sem_Case is
 
          --  Step 1: Detect duplicate choices
 
-         if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
-           or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
-         then
-            Error_Msg ("duplication of choice value", Loc);
+         if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then
+            Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN);
+            Error := True;
+
+         elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then
+            Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN);
             Error := True;
 
          --  Step 2: Detect full coverage
@@ -420,6 +429,45 @@ package body Sem_Case is
          end if;
       end Check_Against_Predicate;
 
+      ----------------
+      -- Dup_Choice --
+      ----------------
+
+      procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is
+      begin
+         --  In some situations, we call this with a null range, and obviously
+         --  we don't want to complain in this case.
+
+         if Lo > Hi then
+            return;
+         end if;
+
+         --  Case of only one value that is missing
+
+         if Lo = Hi then
+            if Is_Integer_Type (Bounds_Type) then
+               Error_Msg_Uint_1 := Lo;
+               Error_Msg_N ("duplication of choice value: ^#!", C);
+            else
+               Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
+               Error_Msg_N ("duplication of choice value: %#!", C);
+            end if;
+
+         --  More than one choice value, so print range of values
+
+         else
+            if Is_Integer_Type (Bounds_Type) then
+               Error_Msg_Uint_1 := Lo;
+               Error_Msg_Uint_2 := Hi;
+               Error_Msg_N ("duplication of choice values: ^ .. ^#!", C);
+            else
+               Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
+               Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type);
+               Error_Msg_N ("duplication of choice values: % .. %#!", C);
+            end if;
+         end if;
+      end Dup_Choice;
+
       ------------------------------
       -- Explain_Non_Static_Bound --
       ------------------------------
@@ -691,10 +739,12 @@ package body Sem_Case is
 
                if Sloc (Prev_Choice) <= Sloc (Choice) then
                   Error_Msg_Sloc := Sloc (Prev_Choice);
-                  Error_Msg_N ("duplication of choice value#", Choice);
+                  Dup_Choice
+                    (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
                else
                   Error_Msg_Sloc := Sloc (Choice);
-                  Error_Msg_N ("duplication of choice value#", Prev_Choice);
+                  Dup_Choice
+                    (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
                end if;
 
             elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
@@ -706,10 +756,10 @@ package body Sem_Case is
             end if;
          end loop;
 
-         if not Others_Present and then Expr_Value (Bounds_Hi) > Choice_Hi then
-            Missing_Choice (Choice_Hi + 1, Bounds_Hi);
+         if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then
+            Missing_Choice (Prev_Hi + 1, Bounds_Hi);
 
-            if Expr_Value (Bounds_Hi) > Choice_Hi + 1 then
+            if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then
                Explain_Non_Static_Bound;
             end if;
          end if;