2011-08-04 Bob Duff <duff@adacore.com>

	* sem_type.adb (Covers): If T2 is a subtype of a class-wide type, we
	need to compare with Class_Wide_Type (T2), in order to get at the
	original class-wide type node.
	* sem_type.ads (Covers): Improve the comment.
	* einfo.ads (Class_Wide_Type): Improve the comment.
	* exp_intr.adb (Expand_Unc_Deallocation): Remove unnecessary setting of
	the type of the Deref.

2011-08-04  Yannick Moy  <moy@adacore.com>

	* gnat_rm.texi: Document that Test_Case pragma can only appear on
	separate declarations.
	* sem_prag.adb (procedure Check_Identifier_Is_One_Of): new procedure to
	check identifier of pragma argument.
	(Chain_TC): check that no other test case associated to the same entity
	share the same name.
	(Check_Test_Case): disallow test case inside subprogram body
	(Analyze_Pragma): correct call to check identifier and not argument
	* sem_util.adb, sem_util.ads (Get_Name_From_Test_Case_Pragma): new
	function gets name from test case pragma.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177385 138bc75d-0d04-0410-961f-82ee72b054a4

9 files changed, 119 insertions, 47 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8484bcfac18..d2e9f0d85b3 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,26 @@
+2011-08-04  Bob Duff  <duff@adacore.com>
+
+	* sem_type.adb (Covers): If T2 is a subtype of a class-wide type, we
+	need to compare with Class_Wide_Type (T2), in order to get at the
+	original class-wide type node.
+	* sem_type.ads (Covers): Improve the comment.
+	* einfo.ads (Class_Wide_Type): Improve the comment.
+	* exp_intr.adb (Expand_Unc_Deallocation): Remove unnecessary setting of
+	the type of the Deref.
+
+2011-08-04  Yannick Moy  <moy@adacore.com>
+
+	* gnat_rm.texi: Document that Test_Case pragma can only appear on
+	separate declarations.
+	* sem_prag.adb (procedure Check_Identifier_Is_One_Of): new procedure to
+	check identifier of pragma argument.
+	(Chain_TC): check that no other test case associated to the same entity
+	share the same name.
+	(Check_Test_Case): disallow test case inside subprogram body
+	(Analyze_Pragma): correct call to check identifier and not argument
+	* sem_util.adb, sem_util.ads (Get_Name_From_Test_Case_Pragma): new
+	function gets name from test case pragma.
+
 2011-08-04  Yannick Moy  <moy@adacore.com>
 
 	* gnat_rm.texi: Document new pragma and aspect.
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 29baab0b43e..a4ca25d4890 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -567,8 +567,8 @@ package Einfo is
 
 --    Class_Wide_Type (Node9)
 --       Present in all type entities. For a tagged type or subtype, returns
---       the corresponding implicitly declared class-wide type. Set to Empty
---       for non-tagged types.
+--       the corresponding implicitly declared class-wide type. For a
+--       class-wide type, returns itself. Set to Empty for non-tagged types.
 
 --    Cloned_Subtype (Node16)
 --       Present in E_Record_Subtype and E_Class_Wide_Subtype entities.
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 39fe8512041..778996bc023 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -1155,7 +1155,6 @@ package body Exp_Intr is
                D_Type   : Entity_Id;
 
             begin
-               Set_Etype  (Deref, Typ);
                Set_Parent (Deref, Free_Node);
                D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T);
 
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 70a678a00c4..8c22975c42c 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -5025,13 +5025,15 @@ pragma Test_Case (
 @end smallexample
 
 @noindent
-The @code{Test_Case} pragma applies to the same entities as pragmas
-@code{Precondition} and @code{Postcondition}. In particular, the
-placement and visibility rules are identical to those described for pre-
-and postconditions. But the presence of pragma @code{Test_Case} does not
-lead to any modification of the code generated by the compiler. Rather,
-its purpose is to document finer-grain specifications for use by testing
-and verification tools.
+The @code{Test_Case} pragma allows defining fine-grain specifications
+for use by testing and verification tools. The compiler only checks its
+validity but the presence of pragma @code{Test_Case} does not lead to
+any modification of the code generated by the compiler.
+
+@code{Test_Case} pragmas may only appear immediately following the
+(separate) declaration of a subprogram. Only other pragmas may intervene
+(that is appear between the subprogram declaration and its
+postconditions).
 
 The compiler checks that boolean expression given in @code{Requires} and
 @code{Ensures} are valid, where the rules for @code{Requires} are the
@@ -5053,14 +5055,6 @@ package Math_Functions is
 end Math_Functions;
 @end smallexample
 
-@noindent
-@code{Test_Case} pragmas may appear either immediately following the
-(separate) declaration of a subprogram, or at the start of the
-declarations of a subprogram body. Only other pragmas may intervene
-(that is appear between the subprogram declaration and its test cases,
-or appear before the test case in the declaration sequence in a
-subprogram body).
-
 @node Pragma Thread_Local_Storage
 @unnumberedsec Pragma Thread_Local_Storage
 @findex Thread_Local_Storage
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 2a218612a26..3eb0bdb70f0 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -423,7 +423,13 @@ package body Sem_Prag is
       --  Checks that the given argument has an identifier, and if so, requires
       --  it to match the given identifier name. If there is no identifier, or
       --  a non-matching identifier, then an error message is given and
-      --  Error_Pragmas raised.
+      --  Pragma_Exit is raised.
+
+      procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
+      --  Checks that the given argument has an identifier, and if so, requires
+      --  it to match one of the given identifier names. If there is no
+      --  identifier, or a non-matching identifier, then an error message is
+      --  given and Pragma_Exit is raised.
 
       procedure Check_In_Main_Program;
       --  Common checks for pragmas that appear within a main program
@@ -454,12 +460,12 @@ package body Sem_Prag is
       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
       --  Checks if the given argument has an identifier, and if so, requires
       --  it to match the given identifier name. If there is a non-matching
-      --  identifier, then an error message is given and Error_Pragmas raised.
+      --  identifier, then an error message is given and Pragma_Exit is raised.
 
       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
       --  Checks if the given argument has an identifier, and if so, requires
       --  it to match the given identifier name. If there is a non-matching
-      --  identifier, then an error message is given and Error_Pragmas raised.
+      --  identifier, then an error message is given and Pragma_Exit is raised.
       --  In this version of the procedure, the identifier name is given as
       --  a string with lower case letters.
 
@@ -1432,6 +1438,30 @@ package body Sem_Prag is
          end if;
       end Check_Identifier;
 
+      --------------------------------
+      -- Check_Identifier_Is_One_Of --
+      --------------------------------
+
+      procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
+      begin
+         if Present (Arg)
+           and then Nkind (Arg) = N_Pragma_Argument_Association
+         then
+            if Chars (Arg) = No_Name then
+               Error_Msg_Name_1 := Pname;
+               Error_Msg_N ("pragma% argument expects an identifier", Arg);
+               raise Pragma_Exit;
+
+            elsif Chars (Arg) /= N1
+              and then Chars (Arg) /= N2
+            then
+               Error_Msg_Name_1 := Pname;
+               Error_Msg_N ("invalid identifier for pragma% argument", Arg);
+               raise Pragma_Exit;
+            end if;
+         end if;
+      end Check_Identifier_Is_One_Of;
+
       ---------------------------
       -- Check_In_Main_Program --
       ---------------------------
@@ -1989,6 +2019,33 @@ package body Sem_Prag is
             --  in this analysis, allowing forward references. The analysis
             --  happens at the end of Analyze_Declarations.
 
+            --  There should not be another test case with the same name
+            --  associated to this subprogram.
+
+            declare
+               Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N);
+               TC   : Node_Id;
+
+            begin
+               TC := Spec_TC_List (Contract (S));
+               while Present (TC) loop
+
+                  if String_Equal
+                    (Name, Get_Name_From_Test_Case_Pragma (TC))
+                  then
+                     Error_Msg_Sloc := Sloc (TC);
+
+                     if From_Aspect_Specification (N) then
+                        Error_Pragma ("name for aspect% is already used#");
+                     else
+                        Error_Pragma ("name for pragma% is already used#");
+                     end if;
+                  end if;
+
+                  TC := Next_Pragma (TC);
+               end loop;
+            end;
+
             --  Chain spec TC pragma to list for subprogram
 
             Set_Next_Pragma (N, Spec_TC_List (Contract (S)));
@@ -2039,25 +2096,9 @@ package body Sem_Prag is
          end loop;
 
          --  If we fall through loop, pragma is at start of list, so see if it
-         --  is at the start of declarations of a subprogram body.
+         --  is in the pragmas after a library level subprogram.
 
-         if Nkind (Parent (N)) = N_Subprogram_Body
-           and then List_Containing (N) = Declarations (Parent (N))
-         then
-            if Operating_Mode /= Generate_Code
-              or else Inside_A_Generic
-            then
-               --  Analyze pragma expressions for correctness and for ASIS use
-
-               Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N),
-                                   Get_Ensures_From_Test_Case_Pragma (N));
-            end if;
-
-            return;
-
-         --  See if it is in the pragmas after a library level subprogram
-
-         elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
+         if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
             Chain_TC (Unit (Parent (Parent (N))));
             return;
          end if;
@@ -13246,7 +13287,7 @@ package body Sem_Prag is
                Check_Identifier (Arg3, Name_Requires);
                Check_Identifier (Arg4, Name_Ensures);
             else
-               Check_Arg_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
+               Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
             end if;
 
             Check_Test_Case;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index cf48392c817..12f39138743 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -884,12 +884,13 @@ package body Sem_Type is
             return False;
          end;
 
-         --  In a dispatching call the actual may be class-wide, the formal
-         --  may be its specific type, or that of a descendent of it.
+      --  In a dispatching call, the formal is of some specific type, and the
+      --  actual is of the corresponding class-wide type, including a subtype
+      --  of the class-wide type.
 
       elsif Is_Class_Wide_Type (T2)
         and then
-          (Class_Wide_Type (T1) = T2
+          (Class_Wide_Type (T1) = Class_Wide_Type (T2)
              or else Base_Type (Root_Type (T2)) = BT1)
       then
          return True;
diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
index 40e4c606df3..4d46a8e1fd1 100644
--- a/gcc/ada/sem_type.ads
+++ b/gcc/ada/sem_type.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -164,7 +164,8 @@ package Sem_Type is
    function Covers (T1, T2 : Entity_Id) return Boolean;
    --  This is the basic type compatibility routine. T1 is the expected type,
    --  imposed by context, and T2 is the actual type. The processing reflects
-   --  both the definition of type coverage and the rules for operand matching.
+   --  both the definition of type coverage and the rules for operand matching;
+   --  that is, this does not exactly match the RM definition of "covers".
 
    function Disambiguate
      (N      : Node_Id;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5974f9cd57d..b7e3f21ff76 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -4331,6 +4331,16 @@ package body Sem_Util is
       return Entity_Id (Get_Name_Table_Info (Id));
    end Get_Name_Entity_Id;
 
+   ------------------------------------
+   -- Get_Name_From_Test_Case_Pragma --
+   ------------------------------------
+
+   function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id is
+   begin
+      return
+        Strval (Get_Pragma_Arg (First (Pragma_Argument_Associations (N))));
+   end Get_Name_From_Test_Case_Pragma;
+
    -------------------
    -- Get_Pragma_Id --
    -------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index e880601bdf8..5078b3a23c7 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -485,7 +485,7 @@ package Sem_Util is
    --  Otherwise return Empty. Expression N should have been resolved already.
 
    function Get_Ensures_From_Test_Case_Pragma (N : Node_Id) return Node_Id;
-   --  Return the Ensures components of Test_Case pragma N, or Empty otherwise
+   --  Return the Ensures component of Test_Case pragma N, or Empty otherwise
 
    function Get_Generic_Entity (N : Node_Id) return Entity_Id;
    --  Returns the true generic entity in an instantiation. If the name in the
@@ -518,6 +518,9 @@ package Sem_Util is
    --  is the innermost visible entity with the given name. See the body of
    --  Sem_Ch8 for further details on handling of entity visibility.
 
+   function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id;
+   --  Return the Name component of Test_Case pragma N
+
    function Get_Pragma_Id (N : Node_Id) return Pragma_Id;
    pragma Inline (Get_Pragma_Id);
    --  Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N)
@@ -534,7 +537,7 @@ package Sem_Util is
    --  with any other kind of entity.
 
    function Get_Requires_From_Test_Case_Pragma (N : Node_Id) return Node_Id;
-   --  Return the Requires components of Test_Case pragma N, or Empty otherwise
+   --  Return the Requires component of Test_Case pragma N, or Empty otherwise
 
    function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id;
    --  Nod is either a procedure call statement, or a function call, or an