From: Robert Dewar Date: Fri, 10 Oct 2014 14:36:07 +0000 (+0000) Subject: exp_intr.adb (Write_Entity_Name): Moved to outer level X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8f8194710d4d0badd94046d26cbe61cee1a01163;p=gcc.git exp_intr.adb (Write_Entity_Name): Moved to outer level 2014-10-10 Robert Dewar * exp_intr.adb (Write_Entity_Name): Moved to outer level (Write_Entity_Name): Properly handle operator names (Expand_Source_Info): New procedure. * exp_intr.ads (Add_Source_Info): New procedure. 2014-10-10 Robert Dewar * butil.ads: Minor reformatting. * sem_ch5.adb: Code clean up. 2014-10-10 Robert Dewar * exp_ch11.adb (Expand_N_Raise_Statement): Handle Prefix_Exception_Messages. * opt.adb: Handle new flags Prefix_Exception_Message[_Config]. * opt.ads: New flags Prefix_Exception_Message[_Config]. * par-prag.adb: New dummy entry for pragma Prefix_Exception_Messages. * snames.ads-tmpl: Add entries for new pragma Prefix_Exception_Messages. * sem_prag.adb: Implement new pragma Prefix_Exception_Messages * gnat_rm.texi: Document pragma Prefix_Exception_Messages. From-SVN: r216088 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d410c97902d..a621e397896 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2014-10-10 Robert Dewar + + * exp_intr.adb (Write_Entity_Name): Moved to outer level + (Write_Entity_Name): Properly handle operator names + (Expand_Source_Info): New procedure. + * exp_intr.ads (Add_Source_Info): New procedure. + +2014-10-10 Robert Dewar + + * butil.ads: Minor reformatting. + * sem_ch5.adb: Code clean up. + +2014-10-10 Robert Dewar + + * exp_ch11.adb (Expand_N_Raise_Statement): Handle + Prefix_Exception_Messages. + * opt.adb: Handle new flags Prefix_Exception_Message[_Config]. + * opt.ads: New flags Prefix_Exception_Message[_Config]. + * par-prag.adb: New dummy entry for pragma Prefix_Exception_Messages. + * snames.ads-tmpl: Add entries for new pragma Prefix_Exception_Messages. + * sem_prag.adb: Implement new pragma Prefix_Exception_Messages + * gnat_rm.texi: Document pragma Prefix_Exception_Messages. + 2014-10-10 Gary Dismukes * sinfo.ads, gnat_ugn.texi, a-except.adb, a-except-2005.adb, diff --git a/gcc/ada/butil.ads b/gcc/ada/butil.ads index 72fffc059f8..ddfa25194dd 100644 --- a/gcc/ada/butil.ads +++ b/gcc/ada/butil.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -38,7 +38,7 @@ package Butil is function Is_Internal_Unit return Boolean; -- Given a unit name stored in Name_Buffer with length in Name_Len, -- returns True if this is the name of an internal unit or a child of - -- an internal. Similar in usage to Is_Predefined_Unit. + -- an internal unit. Similar in usage to Is_Predefined_Unit. -- Note: the following functions duplicate functionality in Uname, but -- we want to avoid bringing Uname into the binder since it generates diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index aafa2b4fdb6..1d437af8413 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -29,6 +29,7 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; +with Exp_Intr; use Exp_Intr; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; @@ -1565,6 +1566,22 @@ package body Exp_Ch11 is if Present (Expression (N)) then + -- Adjust message to deal with Prefix_Exception_Messages. We only + -- add the prefix to string literals, if the message is being + -- constructed, we assume it already deals with uniqueness. + + if Prefix_Exception_Messages + and then Nkind (Expression (N)) = N_String_Literal + then + Name_Len := 0; + Add_Source_Info (Loc, Name_Enclosing_Entity); + Add_Str_To_Name_Buffer (": "); + Add_String_To_Name_Buffer (Strval (Expression (N))); + Rewrite (Expression (N), + Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len))); + Analyze_And_Resolve (Expression (N), Standard_String); + end if; + -- Avoid passing exception-name'identity in runtimes in which this -- argument is not used. This avoids generating undefined references -- to these exceptions when compiling with no optimization diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 465c8b2f91d..aa73839d887 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -36,7 +36,6 @@ with Exp_Code; use Exp_Code; with Exp_Fixd; use Exp_Fixd; with Exp_Util; use Exp_Util; with Freeze; use Freeze; -with Namet; use Namet; with Nmake; use Nmake; with Nlists; use Nlists; with Opt; use Opt; @@ -116,6 +115,96 @@ package body Exp_Intr is -- Name_Compilation_Date - expand string with compilation date -- Name_Compilation_Time - expand string with compilation time + procedure Write_Entity_Name (E : Entity_Id); + -- Recursive procedure to construct string for qualified name of enclosing + -- program unit. The qualification stops at an enclosing scope has no + -- source name (block or loop). If entity is a subprogram instance, skip + -- enclosing wrapper package. The name is appended to the current contents + -- of Name_Buffer, incrementing Name_Len. + + --------------------- + -- Add_Source_Info -- + --------------------- + + procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id) is + Ent : Entity_Id; + + Save_NB : constant String := Name_Buffer (1 .. Name_Len); + Save_NL : constant Natural := Name_Len; + -- Save current Name_Buffer contents + + begin + Name_Len := 0; + + -- Line + + case Nam is + + when Name_Line => + Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Loc))); + + when Name_File => + Get_Decoded_Name_String + (Reference_Name (Get_Source_File_Index (Loc))); + + when Name_Source_Location => + Build_Location_String (Loc); + + when Name_Enclosing_Entity => + + -- Skip enclosing blocks to reach enclosing unit + + Ent := Current_Scope; + while Present (Ent) loop + exit when Ekind (Ent) /= E_Block + and then Ekind (Ent) /= E_Loop; + Ent := Scope (Ent); + end loop; + + -- Ent now points to the relevant defining entity + + Write_Entity_Name (Ent); + + when Name_Compilation_Date => + declare + subtype S13 is String (1 .. 3); + Months : constant array (1 .. 12) of S13 := + ("Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"); + + M1 : constant Character := Opt.Compilation_Time (6); + M2 : constant Character := Opt.Compilation_Time (7); + + MM : constant Natural range 1 .. 12 := + (Character'Pos (M1) - Character'Pos ('0')) * 10 + + (Character'Pos (M2) - Character'Pos ('0')); + + begin + -- Reformat ISO date into MMM DD YYYY (__DATE__) format + + Name_Buffer (1 .. 3) := Months (MM); + Name_Buffer (4) := ' '; + Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10); + Name_Buffer (7) := ' '; + Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4); + Name_Len := 11; + end; + + when Name_Compilation_Time => + Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19); + Name_Len := 8; + + when others => + raise Program_Error; + end case; + + -- Prepend original Name_Buffer contents + + Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) := + Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. Save_NL) := Save_NB; + end Add_Source_Info; + --------------------------------- -- Expand_Binary_Operator_Call -- --------------------------------- @@ -718,61 +807,6 @@ package body Exp_Intr is Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; - procedure Write_Entity_Name (E : Entity_Id); - -- Recursive procedure to construct string for qualified name of - -- enclosing program unit. The qualification stops at an enclosing - -- scope has no source name (block or loop). If entity is a subprogram - -- instance, skip enclosing wrapper package. - - ----------------------- - -- Write_Entity_Name -- - ----------------------- - - procedure Write_Entity_Name (E : Entity_Id) is - SDef : Source_Ptr; - TDef : constant Source_Buffer_Ptr := - Source_Text (Get_Source_File_Index (Sloc (E))); - - begin - -- Nothing to do if at outer level - - if Scope (E) = Standard_Standard then - null; - - -- If scope comes from source, write its name - - elsif Comes_From_Source (Scope (E)) then - Write_Entity_Name (Scope (E)); - Add_Char_To_Name_Buffer ('.'); - - -- If in wrapper package skip past it - - elsif Is_Wrapper_Package (Scope (E)) then - Write_Entity_Name (Scope (Scope (E))); - Add_Char_To_Name_Buffer ('.'); - - -- Otherwise nothing to output (happens in unnamed block statements) - - else - null; - end if; - - -- Loop to output the name - - -- This is not right wrt wide char encodings ??? () - - SDef := Sloc (E); - while TDef (SDef) in '0' .. '9' - or else TDef (SDef) >= 'A' - or else TDef (SDef) = ASCII.ESC - loop - Add_Char_To_Name_Buffer (TDef (SDef)); - SDef := SDef + 1; - end loop; - end Write_Entity_Name; - - -- Start of processing for Expand_Source_Info - begin -- Integer cases @@ -1362,4 +1396,70 @@ package body Exp_Intr is Analyze (N); end Expand_To_Pointer; + ----------------------- + -- Write_Entity_Name -- + ----------------------- + + procedure Write_Entity_Name (E : Entity_Id) is + SDef : Source_Ptr; + TDef : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Sloc (E))); + + begin + -- Nothing to do if at outer level + + if Scope (E) = Standard_Standard then + null; + + -- If scope comes from source, write its name + + elsif Comes_From_Source (Scope (E)) then + Write_Entity_Name (Scope (E)); + Add_Char_To_Name_Buffer ('.'); + + -- If in wrapper package skip past it + + elsif Is_Wrapper_Package (Scope (E)) then + Write_Entity_Name (Scope (Scope (E))); + Add_Char_To_Name_Buffer ('.'); + + -- Otherwise nothing to output (happens in unnamed block statements) + + else + null; + end if; + + -- Output the name + + SDef := Sloc (E); + + -- Check for operator name in quotes + + if TDef (SDef) = '"' then + Add_Char_To_Name_Buffer ('"'); + + -- Loop to output characters of operator name and terminating quote + + loop + SDef := SDef + 1; + Add_Char_To_Name_Buffer (TDef (SDef)); + exit when TDef (SDef) = '"'; + end loop; + + -- Normal case of identifier + + else + -- Loop to output the name + + -- This is not right wrt wide char encodings ??? () + + while TDef (SDef) in '0' .. '9' + or else TDef (SDef) >= 'A' + or else TDef (SDef) = ASCII.ESC + loop + Add_Char_To_Name_Buffer (TDef (SDef)); + SDef := SDef + 1; + end loop; + end if; + end Write_Entity_Name; end Exp_Intr; diff --git a/gcc/ada/exp_intr.ads b/gcc/ada/exp_intr.ads index 1285f4ffc07..f9be797d85d 100644 --- a/gcc/ada/exp_intr.ads +++ b/gcc/ada/exp_intr.ads @@ -25,10 +25,22 @@ -- Processing for expanding intrinsic subprogram calls +with Namet; use Namet; with Types; use Types; package Exp_Intr is + procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id); + -- Append a string to Name_Buffer depending on Nam + -- Name_File - append name of source file + -- Name_Line - append line number + -- Name_Source_Location - append source location (file:line) + -- Name_Enclosing_Entity - append name of enclosing entity + -- Name_Compilation_Date - append compilation date + -- Name_Compilation_Time - append compilation time + -- The caller must set Name_Buffer and Name_Len before the call. Loc is + -- passed to provide location information where it is needed. + procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id); -- N is either a function call node, a procedure call statement node, or -- an operator where the corresponding subprogram is intrinsic (i.e. was diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 5554f68db4d..b0bed4b15cb 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -227,6 +227,7 @@ Implementation Defined Pragmas * Pragma Precondition:: * Pragma Predicate:: * Pragma Preelaborable_Initialization:: +* Pragma Prefix_Exception_Messages:: * Pragma Pre_Class:: * Pragma Priority_Specific_Dispatching:: * Pragma Profile:: @@ -1096,6 +1097,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Precondition:: * Pragma Predicate:: * Pragma Preelaborable_Initialization:: +* Pragma Prefix_Exception_Messages:: * Pragma Pre_Class:: * Pragma Priority_Specific_Dispatching:: * Pragma Profile:: @@ -5692,6 +5694,34 @@ This pragma is standard in Ada 2005, but is available in all earlier versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. +@node Pragma Prefix_Exception_Messages +@unnumberedsec Pragma Prefix_Exception_Messages +@cindex Prefix_Exception_Messages +@cindex exception +@cindex Exception_Message +@findex Exceptions +@noindent +Syntax: + +@smallexample @c ada +pragma Prefix_Exception_Messages; +@end smallexample + +@noindent +This is an implementation-defined configuration pragma that affects the +behavior of raise statements with a message given as a static string +constant (typically a string literal). In such cases, the string will +be automatically prefixed by the name of the enclosing entity (giving +the package and subprogram containing the raise statement). This helps +to identify where messages are coming from, and this mode is automatic +for the run-time library. + +The pragma has no effect if the message is computed with an expression other +than a static string constant, since the assumption in this case is that +the program computes exactly the string it wants. If you still want the +prefixing in this case, you can always call +@code{GNAT.Source_Info.Enclosing_Entity} and prepend the string manually. + @node Pragma Pre_Class @unnumberedsec Pragma Pre_Class @cindex Pre_Class @@ -6199,7 +6229,7 @@ any other use of implementation pragmas: @smallexample @c ada pragma Restriction_Warnings (No_Implementation_Pragmas); -pragma Warnings (Off, "violation of*No_Implementation_Pragmas*"); +7 (Off, "violation of*No_Implementation_Pragmas*"); pragma Ada_95; pragma Style_Checks ("2bfhkM160"); pragma Warnings (On, "violation of*No_Implementation_Pragmas*"); @@ -7825,7 +7855,9 @@ it occurs till the end of the extended scope of the variable (similar to the scope of @code{Suppress}). This form cannot be used as a configuration pragma. -The form with a single static_string_EXPRESSION argument (and possible +In the case where the first argument is other than @code{ON} or +@code{OFF}, +the third form with a single static_string_EXPRESSION argument (and possible reason) provides more precise control over which warnings are active. The string is a list of letters specifying which warnings are to be activated and which deactivated. The diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 4144340c47a..9631ff48a3c 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -63,6 +63,7 @@ package body Opt is Optimize_Alignment_Config := Optimize_Alignment; Persistent_BSS_Mode_Config := Persistent_BSS_Mode; Polling_Required_Config := Polling_Required; + Prefix_Exception_Messages_Config := Prefix_Exception_Messages; SPARK_Mode_Config := SPARK_Mode; SPARK_Mode_Pragma_Config := SPARK_Mode_Pragma; Uneval_Old_Config := Uneval_Old; @@ -102,6 +103,7 @@ package body Opt is Optimize_Alignment_Local := Save.Optimize_Alignment_Local; Persistent_BSS_Mode := Save.Persistent_BSS_Mode; Polling_Required := Save.Polling_Required; + Prefix_Exception_Messages := Save.Prefix_Exception_Messages; SPARK_Mode := Save.SPARK_Mode; SPARK_Mode_Pragma := Save.SPARK_Mode_Pragma; Uneval_Old := Save.Uneval_Old; @@ -142,6 +144,7 @@ package body Opt is Save.Optimize_Alignment_Local := Optimize_Alignment_Local; Save.Persistent_BSS_Mode := Persistent_BSS_Mode; Save.Polling_Required := Polling_Required; + Save.Prefix_Exception_Messages := Prefix_Exception_Messages; Save.SPARK_Mode := SPARK_Mode; Save.SPARK_Mode_Pragma := SPARK_Mode_Pragma; Save.Uneval_Old := Uneval_Old; @@ -174,6 +177,7 @@ package body Opt is External_Name_Imp_Casing := Lowercase; Optimize_Alignment := 'O'; Persistent_BSS_Mode := False; + Prefix_Exception_Messages := True; Uneval_Old := 'E'; Use_VADS_Size := False; Optimize_Alignment_Local := True; @@ -221,6 +225,7 @@ package body Opt is Optimize_Alignment := Optimize_Alignment_Config; Optimize_Alignment_Local := False; Persistent_BSS_Mode := Persistent_BSS_Mode_Config; + Prefix_Exception_Messages := Prefix_Exception_Messages_Config; SPARK_Mode := SPARK_Mode_Config; SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config; Uneval_Old := Uneval_Old_Config; @@ -236,6 +241,8 @@ package body Opt is Init_Or_Norm_Scalars := Initialize_Scalars or Normalize_Scalars; end if; + -- Values set for all units + Default_Pool := Default_Pool_Config; Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; Fast_Math := Fast_Math_Config; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 2e00d4aa995..ebf37b6da16 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1188,6 +1188,10 @@ package Opt is -- Set to True if polling for asynchronous abort is enabled by using -- the -gnatP option for GNAT. + Prefix_Exception_Messages : Boolean := False; + -- GNAT + -- Set True to prefix exception messages with entity-name: + Preprocessing_Data_File : String_Ptr := null; -- GNAT -- Set by switch -gnatep=. The file name of the preprocessing data file. @@ -1950,6 +1954,9 @@ package Opt is -- flag is used to set the initial value for Polling_Required at the start -- of analyzing each unit. + Prefix_Exception_Messages_Config : Boolean; + -- The setting of Prefix_Exception_Messages from configuration pragmas + SPARK_Mode_Config : SPARK_Mode_Type := None; -- GNAT -- The setting of SPARK_Mode from configuration pragmas @@ -2197,6 +2204,7 @@ private Optimize_Alignment_Local : Boolean; Persistent_BSS_Mode : Boolean; Polling_Required : Boolean; + Prefix_Exception_Messages : Boolean; SPARK_Mode : SPARK_Mode_Type; SPARK_Mode_Pragma : Node_Id; Uneval_Old : Character; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index b440122dc62..128ff227837 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1275,6 +1275,7 @@ begin Pragma_Passive | Pragma_Preelaborable_Initialization | Pragma_Polling | + Pragma_Prefix_Exception_Messages | Pragma_Persistent_BSS | Pragma_Post | Pragma_Postcondition | diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 1e731f887a7..22d11b01e65 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2926,7 +2926,12 @@ package body Sem_Ch5 is Stat : Node_Id; begin - if Ekind (Current_Scope) /= E_Block then + + -- Check if current scope is a block that is not a transient block. + + if Ekind (Current_Scope) /= E_Block + or else No (Block_Node (Current_Scope)) + then return False; else diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ec0441961df..bde78e41776 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17753,6 +17753,18 @@ package body Sem_Prag is end if; end Preelaborate; + ------------------------------- + -- Prefix_Exception_Messages -- + ------------------------------- + + -- pragma Prefix_Exception_Messages; + + when Pragma_Prefix_Exception_Messages => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (0); + Prefix_Exception_Messages := True; + -------------- -- Priority -- -------------- @@ -24739,7 +24751,7 @@ package body Sem_Prag is -- whether appearance of some name in a given pragma is to be considered -- as a reference for the purposes of warnings about unreferenced objects. - -- -1 indicates that references in any argument position are significant + -- -1 indicates that appearence in any argument is significant -- 0 indicates that appearance in any argument is not significant -- +n indicates that appearance as argument n is significant, but all -- other arguments are not significant @@ -24881,14 +24893,15 @@ package body Sem_Prag is Pragma_Optimize_Alignment => -1, Pragma_Overflow_Mode => 0, Pragma_Overriding_Renamings => 0, - Pragma_Ordered => 0, + Pragma_Ordered => -1, Pragma_Pack => 0, Pragma_Page => -1, Pragma_Part_Of => -1, Pragma_Partition_Elaboration_Policy => -1, Pragma_Passive => -1, Pragma_Persistent_BSS => 0, - Pragma_Polling => -1, + Pragma_Polling => 0, + Pragma_Prefix_Exception_Messages => 0, Pragma_Post => -1, Pragma_Postcondition => -1, Pragma_Post_Class => -1, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index c1b62b29e3a..cdc82531c43 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -415,6 +415,7 @@ package Snames is Name_Partition_Elaboration_Policy : constant Name_Id := N + $; -- Ada 05 Name_Persistent_BSS : constant Name_Id := N + $; -- GNAT Name_Polling : constant Name_Id := N + $; -- GNAT + Name_Prefix_Exception_Messages : constant Name_Id := N + $; -- GNAT Name_Priority_Specific_Dispatching : constant Name_Id := N + $; -- Ada 05 Name_Profile : constant Name_Id := N + $; -- Ada 05 Name_Profile_Warnings : constant Name_Id := N + $; -- GNAT @@ -1755,6 +1756,7 @@ package Snames is Pragma_Partition_Elaboration_Policy, Pragma_Persistent_BSS, Pragma_Polling, + Pragma_Prefix_Exception_Messages, Pragma_Priority_Specific_Dispatching, Pragma_Profile, Pragma_Profile_Warnings,