===================================================================
@@ -5918,17 +5918,6 @@
-- Get name from corresponding aspect
Error_Msg_Name_1 := Original_Aspect_Name (N);
-
- if Class_Present (N) then
-
- -- Replace the name with a leading underscore used
- -- internally, with a name that is more user-friendly.
-
- if Error_Msg_Name_1 = Name_uType_Invariant then
- Error_Msg_Name_1 := Name_Type_Invariant_Class;
- end if;
- end if;
-
end if;
-- Return possibly modified message
@@ -21897,16 +21886,9 @@
-- Pre'Class/Post'Class aspect cases
if From_Aspect_Specification (Prag) then
- if Nam = Name_uPre then
- Error_Msg_Name_1 := Name_Pre;
- else
- Error_Msg_Name_1 := Name_Post;
- end if;
-
- Error_Msg_Name_2 := Name_Class;
-
+ Error_Msg_Name_1 := Nam;
Error_Msg_N
- ("aspect `%''%` can only be specified for a primitive "
+ ("aspect% can only be specified for a primitive "
& "operation of a tagged type",
Corresponding_Aspect (Prag));
===================================================================
@@ -139,12 +139,18 @@
-- casing mode. Note: if a unit name ending with %b or %s is passed
-- for this kind of insertion, this suffix is simply stripped. Use a
-- unit name insertion ($) to process the suffix.
+ --
+ -- Note: the special names _xxx (xxx = Pre/Post/Invariant) are changed
+ -- to insert the string xxx'Class into the message.
-- Insertion character %% (Double percent: insert literal name)
-- The character sequence %% acts as described above for %, except
-- that the name is simply obtained with Get_Name_String and is not
-- decoded or cased, it is inserted literally from the names table.
-- A trailing %b or %s is not treated specially.
+ --
+ -- Note: the special names _xxx (xxx = Pre/Post/Invariant) are changed
+ -- to insert the string xxx'Class into the message.
-- Insertion character $ (Dollar: insert unit name from Names table)
-- The character $ is treated similarly to %, except that the name is
@@ -181,6 +187,9 @@
-- Error_Msg_Qual_Level is non-zero, then the reference will include
-- up to the given number of levels of qualification, using the scope
-- chain.
+ --
+ -- Note: the special names _xxx (xxx = Pre/Post/Invariant) are changed
+ -- to insert the string xxx'Class into the message.
-- Insertion character # (Pound: insert line number reference)
-- The character # is replaced by the string indicating the source
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2015, 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- --
@@ -1344,9 +1344,7 @@
procedure Set_Msg_Name_Buffer is
begin
- for J in 1 .. Name_Len loop
- Set_Msg_Char (Name_Buffer (J));
- end loop;
+ Set_Msg_Str (Name_Buffer (1 .. Name_Len));
end Set_Msg_Name_Buffer;
-------------------
@@ -1366,9 +1364,42 @@
procedure Set_Msg_Str (Text : String) is
begin
- for J in Text'Range loop
- Set_Msg_Char (Text (J));
- end loop;
+ -- Do replacement for special x'Class aspect names
+
+ if Text = "_Pre" then
+ Set_Msg_Str ("Pre'Class");
+
+ elsif Text = "_Post" then
+ Set_Msg_Str ("Post'Class");
+
+ elsif Text = "_Type_Invariant" then
+ Set_Msg_Str ("Type_Invariant'Class");
+
+ elsif Text = "_pre" then
+ Set_Msg_Str ("pre'class");
+
+ elsif Text = "_post" then
+ Set_Msg_Str ("post'class");
+
+ elsif Text = "_type_invariant" then
+ Set_Msg_Str ("type_invariant'class");
+
+ elsif Text = "_PRE" then
+ Set_Msg_Str ("PRE'CLASS");
+
+ elsif Text = "_POST" then
+ Set_Msg_Str ("POST'CLASS");
+
+ elsif Text = "_TYPE_INVARIANT" then
+ Set_Msg_Str ("TYPE_INVARIANT'CLASS");
+
+ -- Normal case with no replacement
+
+ else
+ for J in Text'Range loop
+ Set_Msg_Char (Text (J));
+ end loop;
+ end if;
end Set_Msg_Str;
------------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2015, 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- --
@@ -527,7 +527,8 @@
procedure Set_Msg_Str (Text : String);
-- Add a sequence of characters to the current message. This routine does
-- not check for special insertion characters (they are just treated as
- -- text characters if they occur).
+ -- text characters if they occur). It does perform the transformation of
+ -- the special strings _xxx (xxx = Pre/Post/Type_Invariant) to xxx'Class.
procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id);
-- Given a message id, move to next message id, but skip any deleted
In some error messages, the aspect name Type_Invariant'Class appeared as Type_Invariant_Class, this is now fixed. The following is compiled with -gnatl -gnatj60: 1. package Class_Aspect is 2. type A_T is tagged private; 3. procedure P (Arg : Integer) with 4. Pre'Class => True, | >>> aspect "Pre'Class" can only be specified for a primitive operation of a tagged type 5. Post'Class => True; | >>> aspect "Post'Class" can only be specified for a primitive operation of a tagged type 6. private 7. type A_T is tagged null record 8. with Type_Invariant'Class => True; | >>> aspect "Type_Invariant'Class" only allowed for private type declared in visible part 9. end Class_Aspect; Tested on x86_64-pc-linux-gnu, committed on trunk 2015-02-20 Robert Dewar <dewar@adacore.com> * errout.ads: Document replacement of Name_uPre/Post/Type_Invariant. * erroutc.adb (Set_Msg_Str): Replace _xxx. (Pre/Post/Type_Invariant) by xxx'Class. * erroutc.ads (Set_Msg_Str): Replace _xxx. (Pre/Post/Type_Invariant) by xxx'Class. * sem_prag.adb (Fix_Error): Remove special casing of Name_uType_Invariant. (Analyze_Pre_Post_Condition_In_Decl_Part): Remove special casing of Name_uPre and Name_uPost in aspect case (done in Errout now).