+2014-10-10 Robert Dewar <dewar@adacore.com>
+
+ * 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 <dewar@adacore.com>
+
+ * butil.ads: Minor reformatting.
+ * sem_ch5.adb: Code clean up.
+
+2014-10-10 Robert Dewar <dewar@adacore.com>
+
+ * 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 <dismukes@adacore.com>
* sinfo.ads, gnat_ugn.texi, a-except.adb, a-except-2005.adb,
-- --
-- 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- --
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
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;
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
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;
-- 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 --
---------------------------------
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
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;
-- 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
* Pragma Precondition::
* Pragma Predicate::
* Pragma Preelaborable_Initialization::
+* Pragma Prefix_Exception_Messages::
* Pragma Pre_Class::
* Pragma Priority_Specific_Dispatching::
* Pragma Profile::
* Pragma Precondition::
* Pragma Predicate::
* Pragma Preelaborable_Initialization::
+* Pragma Prefix_Exception_Messages::
* Pragma Pre_Class::
* Pragma Priority_Specific_Dispatching::
* Pragma Profile::
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
@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*");
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
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;
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;
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;
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;
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;
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;
-- 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.
-- 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
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;
Pragma_Passive |
Pragma_Preelaborable_Initialization |
Pragma_Polling |
+ Pragma_Prefix_Exception_Messages |
Pragma_Persistent_BSS |
Pragma_Post |
Pragma_Postcondition |
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
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 --
--------------
-- 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
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,
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
Pragma_Partition_Elaboration_Policy,
Pragma_Persistent_BSS,
Pragma_Polling,
+ Pragma_Prefix_Exception_Messages,
Pragma_Priority_Specific_Dispatching,
Pragma_Profile,
Pragma_Profile_Warnings,
projects / gcc.git / commitdiff