sem_prag.adb (Analyze_PPC_In_Decl_Part): Pre'Class and Post'Class aspects can only...

2012-02-17  Steve Baird  <baird@adacore.com>

	* sem_prag.adb (Analyze_PPC_In_Decl_Part): Pre'Class and
	Post'Class aspects can only be specified for a primitive operation
	of a tagged type.

From-SVN: r184342

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a7e3dee..4aba46d 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2012-02-17  Steve Baird  <baird@adacore.com>
+
+       * sem_prag.adb (Analyze_PPC_In_Decl_Part): Pre'Class and
+       Post'Class aspects can only be specified for a primitive operation
+       of a tagged type.
+
 2012-02-17  Yannick Moy  <moy@adacore.com>
 
        * gnat_rm.texi: Minor shuffling.

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 9098d53..f1ea658 100644 (file)
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -278,13 +278,19 @@ package body Sem_Prag is
       --  overriding operation (see ARM12 6.6.1 (7)).
 
       if Class_Present (N) then
-         declare
+         Class_Wide_Condition : declare
             T   : constant Entity_Id := Find_Dispatching_Type (S);
 
             ACW : Entity_Id := Empty;
             --  Access to T'class, created if there is a controlling formal
             --  that is an access parameter.
 
+            function Aspect_Name return String;
+            --  Return the name of the aspect being specified ("Pre" or "Post")
+            --  properly capitalized for use in an error message. Precondition
+            --  is Present (Corresponding_Aspect (N)), which will be satisfied
+            --  if Class_Present (N).
+
             function Get_ACW return Entity_Id;
             --  If the expression has a reference to an controlling access
             --  parameter, create an access to T'class for the necessary
@@ -299,6 +305,19 @@ package body Sem_Prag is
             --  type access-to-T'Class. This ensures the expression is well-
             --  defined for a primitive subprogram of a type descended from T.
 
+            -----------------
+            -- Aspect_Name --
+            -----------------
+
+            function Aspect_Name return String is
+            begin
+               if Chars (Identifier (Corresponding_Aspect (N))) = Name_Pre then
+                  return "Pre";
+               else
+                  return "Post";
+               end if;
+            end Aspect_Name;
+
             -------------
             -- Get_ACW --
             -------------
@@ -365,9 +384,29 @@ package body Sem_Prag is
 
             procedure Replace_Type is new Traverse_Proc (Process);
 
+         --  Start of processing for Class_Wide_Condition
+
          begin
+            if not Present (T) then
+
+               --  This is weird code, why not just set Err_Msg_Name_1 to
+               --  Identifier (Corresponding_Aspect (N)), and Err_Msg_Name_2
+               --  to Name_Class and then use
+
+               --    "aspect `%''%` can only be specified ...
+
+               --  That would be the more normal way of doing things ???
+               --  Then you get proper identifier casing mode as well,
+               --  instead of presuming mixed case ???
+
+               Error_Msg_N
+                 ("aspect " & Aspect_Name & "''Class can only be specified " &
+                  "for a primitive operation of a tagged type",
+                  Corresponding_Aspect (N));
+            end if;
+
             Replace_Type (Get_Pragma_Arg (Arg1));
-         end;
+         end Class_Wide_Condition;
       end if;
 
       --  Remove the subprogram from the scope stack now that the pre-analysis