===================================================================
@@ -1171,11 +1171,8 @@
-- end if;
procedure Expand_N_Exception_Declaration (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
- Loc : constant Source_Ptr := Sloc (N);
- Ex_Id : Entity_Id;
- Flag_Id : Entity_Id;
- L : List_Id;
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
procedure Force_Static_Allocation_Of_Referenced_Objects
(Aggregate : Node_Id);
@@ -1205,6 +1202,9 @@
-- references to other local (non-hoisted) objects (e.g., in the initial
-- value expression).
+ function Null_String return String_Id;
+ -- Build a null-terminated empty string
+
---------------------------------------------------
-- Force_Static_Allocation_Of_Referenced_Objects --
---------------------------------------------------
@@ -1248,6 +1248,24 @@
Fixup_Tree (Aggregate);
end Force_Static_Allocation_Of_Referenced_Objects;
+ -----------------
+ -- Null_String --
+ -----------------
+
+ function Null_String return String_Id is
+ begin
+ Start_String;
+ Store_String_Char (Get_Char_Code (ASCII.NUL));
+ return End_String;
+ end Null_String;
+
+ -- Local variables
+
+ Ex_Id : Entity_Id;
+ Ex_Val : String_Id;
+ Flag_Id : Entity_Id;
+ L : List_Id;
+
-- Start of processing for Expand_N_Exception_Declaration
begin
@@ -1262,14 +1280,25 @@
Ex_Id :=
Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E'));
+ -- Do not generate an external name if the exception declaration is
+ -- subject to pragma Discard_Names. Use a null-terminated empty name
+ -- to ensure that Ada.Exceptions.Exception_Name functions properly.
+
+ if Global_Discard_Names or else Discard_Names (Ex_Id) then
+ Ex_Val := Null_String;
+
+ -- Otherwise generate the fully qualified name of the exception
+
+ else
+ Ex_Val := Fully_Qualified_Name_String (Id);
+ end if;
+
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Ex_Id,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc,
- Strval => Fully_Qualified_Name_String (Id))));
+ Expression => Make_String_Literal (Loc, Ex_Val)));
Set_Is_Statically_Allocated (Ex_Id);
This patch extends the functionality of pragma Discard_Names to suppress the generation of the String names of exception declarations. As a result, these names do not appear in the final binary. A side effect of this functionality is that routine Ada.Exceptions.Exception_Name will return an empty String. ------------ -- Source -- ------------ -- gnat.adc pragma Discard_Names; -- pack.ads package Pack is External_Exception : exception; procedure Raise_EE (Do_It : Boolean); end Pack; -- pack.adb with Ada.Text_IO; use Ada.Text_IO; package body Pack is procedure Raise_EE (Do_It : Boolean) is begin if Do_It then Put_Line ("about to raise External_Exception"); raise External_Exception; end if; end Raise_EE; end Pack; -- main.adb with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with Pack; use Pack; procedure Main is Local_Exception : exception; procedure Iterate_Over (High : Natural) is begin for Iter in 0 .. High loop begin Raise_EE (Iter mod 13 = 0); exception when External_Exception => Put_Line ("caught External_Exception"); end; end loop; raise Local_Exception; end Iterate_Over; begin Put_Line (Exception_Name (External_Exception'Identity)); Put_Line (Exception_Name (Local_Exception'Identity)); Iterate_Over (15); exception when Local_Exception => Put_Line ("caught Local_Exception"); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ main $ grep -c "EXTERNAL_EXCEPTION" main $ grep -c "LOCAL_EXCEPTION" main about to raise External_Exception caught External_Exception about to raise External_Exception caught External_Exception caught Local_Exception 0 0 Tested on x86_64-pc-linux-gnu, committed on trunk 2017-01-23 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch11.adb (Expand_N_Exception_Declaration): Generate an empty name when the exception declaration is subject to pragma Discard_Names. (Null_String): New routine.