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 <de...@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).
Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 220857) +++ sem_prag.adb (working copy) @@ -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)); Index: errout.ads =================================================================== --- errout.ads (revision 220868) +++ errout.ads (working copy) @@ -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 Index: erroutc.adb =================================================================== --- erroutc.adb (revision 220835) +++ erroutc.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- 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; ------------------------------ Index: erroutc.ads =================================================================== --- erroutc.ads (revision 220835) +++ erroutc.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- 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