Introduce a new debug switch -gnatdJ to prepend the name of the enclosing
entity (subprogram, task, ...) relevant for a given warning or style message.
This can be useful in the context of integrating these messages in other tools,
e.g. CodePeer or gnatcheck.
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-08 Arnaud Charlet <char...@adacore.com>
* exp_intr.adb (Append_Entity_Name): Move to ...
* sem_util.ads, sem_util.adb: ... here to share it.
(Subprogram_Name): New subprogram, to compute the name of the enclosing
subprogram/entity.
* errutil.adb (Error_Msg): Fill new field Node.
* erroutc.ads (Subprogram_Name_Ptr): New.
(Error_Msg_Object): New field Node.
* erroutc.adb (dmsg, Output_Msg_Text): Take new field Node into account.
* errout.adb (Error_Msg): New variant with node id parameter.
Fill new parameter Node when emitting messages. Revert previous
changes for Include_Subprogram_In_Messages.
* sem_ch5.adb (Check_Unreachable_Code): Supply Node parameter when
generating warning message.
Index: errout.adb
===================================================================
--- errout.adb (revision 251880)
+++ errout.adb (working copy)
@@ -100,7 +100,8 @@
(Msg : String;
Sptr : Source_Ptr;
Optr : Source_Ptr;
- Msg_Cont : Boolean);
+ Msg_Cont : Boolean;
+ Node : Node_Id);
-- This is the low level routine used to post messages after dealing with
-- the issue of messages placed on instantiations (which get broken up
-- into separate calls in Error_Msg). Sptr is the location on which the
@@ -111,7 +112,9 @@
-- copy. So typically we can see Optr pointing to the template location
-- in an instantiation copy when Sptr points to the source location of
-- the actual instantiation (i.e the line with the new). Msg_Cont is
- -- set true if this is a continuation message.
+ -- set true if this is a continuation message. Node is the relevant
+ -- Node_Id for this message, to be used to compute the enclosing entity if
+ -- Opt.Include_Subprogram_In_Messages is set.
function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
-- Determines if warnings should be suppressed for the given node
@@ -303,6 +306,15 @@
-- referencing the generic declaration.
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
+ begin
+ Error_Msg (Msg, Flag_Location, Empty);
+ end Error_Msg;
+
+ procedure Error_Msg
+ (Msg : String;
+ Flag_Location : Source_Ptr;
+ N : Node_Id)
+ is
Sindex : Source_File_Index;
-- Source index for flag location
@@ -310,8 +322,6 @@
-- Original location of Flag_Location (i.e. location in original
-- template in instantiation case, otherwise unchanged).
- Entity : Bounded_String;
-
begin
-- Return if all errors are to be ignored
@@ -338,18 +348,6 @@
Prescan_Message (Msg);
Orig_Loc := Original_Location (Flag_Location);
- if Include_Subprogram_In_Messages then
- declare
- Ent : constant Entity_Id := Current_Subprogram_Ptr.all;
- begin
- if Present (Ent) then
- Append_Unqualified_Decoded (Entity, Chars (Ent));
- else
- Append (Entity, "unknown subprogram");
- end if;
- end;
- end if;
-
-- If the current location is in an instantiation, the issue arises of
-- whether to post the message on the template or the instantiation.
@@ -419,14 +417,7 @@
-- Error_Msg_Internal to place the message in the requested location.
if Instantiation (Sindex) = No_Location then
- if Include_Subprogram_In_Messages then
- Append (Entity, ": ");
- Append (Entity, Msg);
- Error_Msg_Internal (+Entity, Flag_Location, Flag_Location, False);
- else
- Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
- end if;
-
+ Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N);
return;
end if;
@@ -521,23 +512,35 @@
if Inlined_Body (X) then
if Is_Info_Msg then
Error_Msg_Internal
- ("info: in inlined body #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "info: in inlined body #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
elsif Is_Warning_Msg then
Error_Msg_Internal
- (Warn_Insertion & "in inlined body #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => Warn_Insertion & "in inlined body #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
elsif Is_Style_Msg then
Error_Msg_Internal
- ("style: in inlined body #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "style: in inlined body #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
else
Error_Msg_Internal
- ("error in inlined body #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "error in inlined body #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
end if;
-- Case of generic instantiation
@@ -545,23 +548,35 @@
else
if Is_Info_Msg then
Error_Msg_Internal
- ("info: in instantiation #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "info: in instantiation #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
elsif Is_Warning_Msg then
Error_Msg_Internal
- (Warn_Insertion & "in instantiation #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => Warn_Insertion & "in instantiation #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
elsif Is_Style_Msg then
Error_Msg_Internal
- ("style: in instantiation #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "style: in instantiation #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
else
Error_Msg_Internal
- ("instantiation error #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "instantiation error #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
end if;
end if;
end if;
@@ -576,15 +591,12 @@
-- Here we output the original message on the outer instantiation
- if Include_Subprogram_In_Messages then
- Append (Entity, ": ");
- Append (Entity, Msg);
- Error_Msg_Internal
- (+Entity, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
- else
- Error_Msg_Internal
- (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
- end if;
+ Error_Msg_Internal
+ (Msg => Msg,
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
end;
end Error_Msg;
@@ -798,7 +810,8 @@
(Msg : String;
Sptr : Source_Ptr;
Optr : Source_Ptr;
- Msg_Cont : Boolean)
+ Msg_Cont : Boolean;
+ Node : Node_Id)
is
Next_Msg : Error_Msg_Id;
-- Pointer to next message at insertion point
@@ -1080,7 +1093,8 @@
Serious => Is_Serious_Error,
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
- Deleted => False));
+ Deleted => False,
+ Node => Node));
Cur_Msg := Errors.Last;
-- Test if warning to be treated as error
@@ -1369,7 +1383,7 @@
then
Debug_Output (N);
Error_Msg_Node_1 := E;
- Error_Msg (Msg, Flag_Location);
+ Error_Msg (Msg, Flag_Location, N);
else
Last_Killed := True;
Index: errout.ads
===================================================================
--- errout.ads (revision 251880)
+++ errout.ads (working copy)
@@ -68,11 +68,6 @@
-- error message tag. The -gnatw.d switch sets this flag True, -gnatw.D
-- sets this flag False.
- type Current_Subprogram_Type is access function return Entity_Id;
- Current_Subprogram_Ptr : Current_Subprogram_Type := null;
- -- Indirect call to Sem_Util.Current_Subprogram to break circular
- -- dependency with the static elaboration model.
-
-----------------------------------
-- Suppression of Error Messages --
-----------------------------------
@@ -691,9 +686,13 @@
-- Output list of messages, including messages giving number of detected
-- errors and warnings.
- procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
+ procedure Error_Msg
+ (Msg : String; Flag_Location : Source_Ptr);
+ procedure Error_Msg
+ (Msg : String; Flag_Location : Source_Ptr; N : Node_Id);
-- Output a message at specified location. Can be called from the parser
- -- or the semantic analyzer.
+ -- or the semantic analyzer. If N is set, points to the relevant node for
+ -- this message.
procedure Error_Msg_S (Msg : String);
-- Output a message at current scan pointer location. This routine can be
Index: erroutc.adb
===================================================================
--- erroutc.adb (revision 251863)
+++ erroutc.adb (working copy)
@@ -299,6 +299,7 @@
w (" Uncond = ", E.Uncond);
w (" Msg_Cont = ", E.Msg_Cont);
w (" Deleted = ", E.Deleted);
+ w (" Node = ", Int (E.Node));
Write_Eol;
end dmsg;
@@ -632,7 +633,22 @@
-- Postfix warning tag to message if needed
if Tag /= "" and then Warning_Doc_Switch then
- Txt := new String'(Text.all & ' ' & Tag);
+ if Include_Subprogram_In_Messages then
+ Txt :=
+ new String'
+ (Subprogram_Name_Ptr (Errors.Table (E).Node) &
+ ": " & Text.all & ' ' & Tag);
+ else
+ Txt := new String'(Text.all & ' ' & Tag);
+ end if;
+
+ elsif Include_Subprogram_In_Messages
+ and then (Errors.Table (E).Warn or else Errors.Table (E).Style)
+ then
+ Txt :=
+ new String'
+ (Subprogram_Name_Ptr (Errors.Table (E).Node) &
+ ": " & Text.all);
else
Txt := Text;
end if;
Index: erroutc.ads
===================================================================
--- erroutc.ads (revision 251872)
+++ erroutc.ads (working copy)
@@ -132,6 +132,11 @@
-- output. This is used for internal processing for the case of an
-- illegal instantiation. See Error_Msg routine for further details.
+ type Subprogram_Name_Type is access function (N : Node_Id) return String;
+ Subprogram_Name_Ptr : Subprogram_Name_Type;
+ -- Indirect call to Sem_Util.Subprogram_Name to break circular
+ -- dependency with the static elaboration model.
+
----------------------------
-- Message ID Definitions --
----------------------------
@@ -251,6 +256,11 @@
Deleted : Boolean;
-- If this flag is set, the message is not printed. This is used
-- in the circuit for deleting duplicate/redundant error messages.
+
+ Node : Node_Id;
+ -- If set, points to the node relevant for this message which will be
+ -- used to compute the enclosing subprogram name if
+ -- Opt.Include_Subprogram_In_Messages is set.
end record;
package Errors is new Table.Table (
Index: errutil.adb
===================================================================
--- errutil.adb (revision 251863)
+++ errutil.adb (working copy)
@@ -220,7 +220,8 @@
Serious => Is_Serious_Error,
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
- Deleted => False));
+ Deleted => False,
+ Node => Empty));
Cur_Msg := Errors.Last;
Prev_Msg := No_Error_Msg;
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 251879)
+++ exp_disp.adb (working copy)
@@ -1204,7 +1204,7 @@
procedure Expand_Interface_Conversion (N : Node_Id) is
function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id;
- -- Return the underlying record type of Typ.
+ -- Return the underlying record type of Typ
----------------------------
-- Underlying_Record_Type --
Index: exp_intr.adb
===================================================================
--- exp_intr.adb (revision 251863)
+++ exp_intr.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
@@ -27,7 +27,6 @@
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
-with Errout; use Errout;
with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
with Exp_Ch4; use Exp_Ch4;
@@ -111,12 +110,6 @@
-- GNAT.Source_Info; see g-souinf.ads for documentation of these
-- intrinsics.
- procedure Append_Entity_Name (Buf : in out Bounded_String; 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 Buf.
-
---------------------
-- Add_Source_Info --
---------------------
@@ -189,98 +182,6 @@
end case;
end Add_Source_Info;
- -----------------------
- -- Append_Entity_Name --
- -----------------------
-
- procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
- Temp : Bounded_String;
-
- procedure Inner (E : Entity_Id);
- -- Inner recursive routine, keep outer routine nonrecursive to ease
- -- debugging when we get strange results from this routine.
-
- -----------
- -- Inner --
- -----------
-
- procedure Inner (E : Entity_Id) is
- begin
- -- If entity has an internal name, skip by it, and print its scope.
- -- Note that we strip a final R from the name before the test; this
- -- is needed for some cases of instantiations.
-
- declare
- E_Name : Bounded_String;
-
- begin
- Append (E_Name, Chars (E));
-
- if E_Name.Chars (E_Name.Length) = 'R' then
- E_Name.Length := E_Name.Length - 1;
- end if;
-
- if Is_Internal_Name (E_Name) then
- Inner (Scope (E));
- return;
- end if;
- end;
-
- -- Just print entity name if its scope is at the outer level
-
- if Scope (E) = Standard_Standard then
- null;
-
- -- If scope comes from source, write scope and entity
-
- elsif Comes_From_Source (Scope (E)) then
- Append_Entity_Name (Temp, Scope (E));
- Append (Temp, '.');
-
- -- If in wrapper package skip past it
-
- elsif Is_Wrapper_Package (Scope (E)) then
- Append_Entity_Name (Temp, Scope (Scope (E)));
- Append (Temp, '.');
-
- -- Otherwise nothing to output (happens in unnamed block statements)
-
- else
- null;
- end if;
-
- -- Output the name
-
- declare
- E_Name : Bounded_String;
-
- begin
- Append_Unqualified_Decoded (E_Name, Chars (E));
-
- -- Remove trailing upper-case letters from the name (useful for
- -- dealing with some cases of internal names generated in the case
- -- of references from within a generic).
-
- while E_Name.Length > 1
- and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
- loop
- E_Name.Length := E_Name.Length - 1;
- end loop;
-
- -- Adjust casing appropriately (gets name from source if possible)
-
- Adjust_Name_Case (E_Name, Sloc (E));
- Append (Temp, E_Name);
- end;
- end Inner;
-
- -- Start of processing for Append_Entity_Name
-
- begin
- Inner (E);
- Append (Buf, Temp);
- end Append_Entity_Name;
-
---------------------------------
-- Expand_Binary_Operator_Call --
---------------------------------
Index: exp_prag.adb
===================================================================
--- exp_prag.adb (revision 251880)
+++ exp_prag.adb (working copy)
@@ -338,17 +338,22 @@
------------------------------------------
procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id) is
- function Find_Corresponding_Discriminal (E : Entity_Id)
- return Entity_Id;
- -- Find the local entity that renames a discriminant of the
- -- enclosing protected type, and has a matching name.
+ function Find_Corresponding_Discriminal
+ (E : Entity_Id) return Entity_Id;
+ -- Find the local entity that renames a discriminant of the enclosing
+ -- protected type, and has a matching name.
+ function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
+ -- Replace a reference to a discriminant of the original protected
+ -- type by the local renaming declaration of the discriminant of
+ -- the target object.
+
------------------------------------
- -- find_Corresponding_Discriminal --
+ -- Find_Corresponding_Discriminal --
------------------------------------
- function Find_Corresponding_Discriminal (E : Entity_Id)
- return Entity_Id
+ function Find_Corresponding_Discriminal
+ (E : Entity_Id) return Entity_Id
is
R : Entity_Id;
@@ -369,35 +374,35 @@
return Empty;
end Find_Corresponding_Discriminal;
- function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
- -- Replace a reference to a discriminant of the original protected
- -- type by the local renaming declaration of the discriminant of
- -- the target object.
-
-----------------------
-- Replace_Discr_Ref --
-----------------------
- function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
+ function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
R : Entity_Id;
begin
if Is_Entity_Name (N)
- and then Present (Discriminal_Link (Entity (N)))
+ and then Present (Discriminal_Link (Entity (N)))
then
R := Find_Corresponding_Discriminal (Entity (N));
Rewrite (N, New_Occurrence_Of (R, Sloc (N)));
end if;
+
return OK;
end Replace_Discr_Ref;
procedure Replace_Discriminant_References is
new Traverse_Proc (Replace_Discr_Ref);
+ -- Start of processing for Replace_Discriminals_Of_Protected_Op
+
begin
Replace_Discriminant_References (Expr);
end Replace_Discriminals_Of_Protected_Op;
+ -- Start of processing for Expand_Pragma_Check
+
begin
-- Nothing to do if pragma is ignored
Index: sem_ch5.adb
===================================================================
--- sem_ch5.adb (revision 251863)
+++ sem_ch5.adb (working copy)
@@ -3745,7 +3745,8 @@
Check_SPARK_05_Restriction
("unreachable code is not allowed", Error_Node);
else
- Error_Msg ("??unreachable code!", Sloc (Error_Node));
+ Error_Msg
+ ("??unreachable code!", Sloc (Error_Node), Error_Node);
end if;
end if;
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 251880)
+++ sem_ch6.adb (working copy)
@@ -343,7 +343,6 @@
----------------------
function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is
-
procedure Check_And_Freeze_Type (Typ : Entity_Id);
-- Check that Typ is fully declared and freeze it if so
@@ -371,8 +370,7 @@
if Has_Private_Component (Typ)
and then not Is_Private_Type (Typ)
then
- Error_Msg_NE
- ("\type& has private component", Node, Typ);
+ Error_Msg_NE ("\type& has private component", Node, Typ);
end if;
else
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 251880)
+++ sem_prag.adb (working copy)
@@ -29,66 +29,67 @@
-- to complete the syntax checks. Certain pragmas are handled partially or
-- completely by the parser (see Par.Prag for further details).
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Casing; use Casing;
-with Checks; use Checks;
-with Contracts; use Contracts;
-with Csets; use Csets;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Dist; use Exp_Dist;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Gnatvsn; use Gnatvsn;
-with Lib; use Lib;
-with Lib.Writ; use Lib.Writ;
-with Lib.Xref; use Lib.Xref;
-with Namet.Sp; use Namet.Sp;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Output; use Output;
-with Par_SCO; use Par_SCO;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Intr; use Sem_Intr;
-with Sem_Mech; use Sem_Mech;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Sinput; use Sinput;
-with Stringt; use Stringt;
-with Stylesw; use Stylesw;
-with System.Case_Util;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Casing; use Casing;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Dist; use Exp_Dist;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Gnatvsn; use Gnatvsn;
+with Lib; use Lib;
+with Lib.Writ; use Lib.Writ;
+with Lib.Xref; use Lib.Xref;
+with Namet.Sp; use Namet.Sp;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Output; use Output;
+with Par_SCO; use Par_SCO;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Intr; use Sem_Intr;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput; use Sinput;
+with Stringt; use Stringt;
+with Stylesw; use Stylesw;
with Table;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
with Ttypes;
-with Uintp; use Uintp;
-with Uname; use Uname;
-with Urealp; use Urealp;
-with Validsw; use Validsw;
-with Warnsw; use Warnsw;
+with Uintp; use Uintp;
+with Uname; use Uname;
+with Urealp; use Urealp;
+with Validsw; use Validsw;
+with Warnsw; use Warnsw;
+with System.Case_Util;
+
package body Sem_Prag is
----------------------------------------------
@@ -17924,8 +17925,8 @@
Name_Increases)
then
declare
- Name : String :=
- Get_Name_String (Chars (Variant));
+ Name : String := Get_Name_String (Chars (Variant));
+
begin
-- It is a common mistake to write "Increasing" for
-- "Increases" or "Decreasing" for "Decreases". Recognize
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 251882)
+++ sem_util.adb (working copy)
@@ -32,6 +32,7 @@
with Debug; use Debug;
with Elists; use Elists;
with Errout; use Errout;
+with Erroutc; use Erroutc;
with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
with Exp_Util; use Exp_Util;
@@ -137,6 +138,10 @@
-- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
-- eliminated.
+ function Subprogram_Name (N : Node_Id) return String;
+ -- Return the fully qualified name of the enclosing subprogram for the
+ -- given node N.
+
------------------------------
-- Abstract_Interface_List --
------------------------------
@@ -572,6 +577,98 @@
end case;
end All_Composite_Constraints_Static;
+ ------------------------
+ -- Append_Entity_Name --
+ ------------------------
+
+ procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
+ Temp : Bounded_String;
+
+ procedure Inner (E : Entity_Id);
+ -- Inner recursive routine, keep outer routine nonrecursive to ease
+ -- debugging when we get strange results from this routine.
+
+ -----------
+ -- Inner --
+ -----------
+
+ procedure Inner (E : Entity_Id) is
+ begin
+ -- If entity has an internal name, skip by it, and print its scope.
+ -- Note that we strip a final R from the name before the test; this
+ -- is needed for some cases of instantiations.
+
+ declare
+ E_Name : Bounded_String;
+
+ begin
+ Append (E_Name, Chars (E));
+
+ if E_Name.Chars (E_Name.Length) = 'R' then
+ E_Name.Length := E_Name.Length - 1;
+ end if;
+
+ if Is_Internal_Name (E_Name) then
+ Inner (Scope (E));
+ return;
+ end if;
+ end;
+
+ -- Just print entity name if its scope is at the outer level
+
+ if Scope (E) = Standard_Standard then
+ null;
+
+ -- If scope comes from source, write scope and entity
+
+ elsif Comes_From_Source (Scope (E)) then
+ Append_Entity_Name (Temp, Scope (E));
+ Append (Temp, '.');
+
+ -- If in wrapper package skip past it
+
+ elsif Is_Wrapper_Package (Scope (E)) then
+ Append_Entity_Name (Temp, Scope (Scope (E)));
+ Append (Temp, '.');
+
+ -- Otherwise nothing to output (happens in unnamed block statements)
+
+ else
+ null;
+ end if;
+
+ -- Output the name
+
+ declare
+ E_Name : Bounded_String;
+
+ begin
+ Append_Unqualified_Decoded (E_Name, Chars (E));
+
+ -- Remove trailing upper-case letters from the name (useful for
+ -- dealing with some cases of internal names generated in the case
+ -- of references from within a generic).
+
+ while E_Name.Length > 1
+ and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
+ loop
+ E_Name.Length := E_Name.Length - 1;
+ end loop;
+
+ -- Adjust casing appropriately (gets name from source if possible)
+
+ Adjust_Name_Case (E_Name, Sloc (E));
+ Append (Temp, E_Name);
+ end;
+ end Inner;
+
+ -- Start of processing for Append_Entity_Name
+
+ begin
+ Inner (E);
+ Append (Buf, Temp);
+ end Append_Entity_Name;
+
---------------------------------
-- Append_Inherited_Subprogram --
---------------------------------
@@ -21663,11 +21760,12 @@
-- Set_Rep_Info --
------------------
- procedure Set_Rep_Info (T1, T2 : Entity_Id) is
+ procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is
begin
Set_Is_Atomic (T1, Is_Atomic (T2));
Set_Is_Independent (T1, Is_Independent (T2));
Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2));
+
if Is_Base_Type (T1) then
Set_Is_Volatile (T1, Is_Volatile (T2));
end if;
@@ -21855,6 +21953,49 @@
end if;
end Subprogram_Access_Level;
+ ---------------------
+ -- Subprogram_Name --
+ ---------------------
+
+ function Subprogram_Name (N : Node_Id) return String is
+ Buf : Bounded_String;
+ Ent : Node_Id := N;
+
+ begin
+ while Present (Ent) loop
+ case Nkind (Ent) is
+ when N_Subprogram_Body =>
+ Ent := Defining_Unit_Name (Specification (Ent));
+ exit;
+
+ when N_Package_Body
+ | N_Package_Specification
+ | N_Subprogram_Specification
+ =>
+ Ent := Defining_Unit_Name (Ent);
+ exit;
+
+ when N_Protected_Body
+ | N_Protected_Type_Declaration
+ | N_Task_Body
+ =>
+ exit;
+
+ when others =>
+ null;
+ end case;
+
+ Ent := Parent (Ent);
+ end loop;
+
+ if No (Ent) then
+ return "unknown subprogram";
+ end if;
+
+ Append_Entity_Name (Buf, Ent);
+ return +Buf;
+ end Subprogram_Name;
+
-------------------------------
-- Support_Atomic_Primitives --
-------------------------------
@@ -23188,5 +23329,5 @@
end Yields_Universal_Type;
begin
- Errout.Current_Subprogram_Ptr := Current_Subprogram'Access;
+ Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access;
end Sem_Util;
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 251882)
+++ sem_util.ads (working copy)
@@ -105,6 +105,12 @@
-- irrelevant. Also called for array aggregates, but only named notation,
-- because those are the only dynamic cases.
+ procedure Append_Entity_Name (Buf : in out Bounded_String; 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 Buf.
+
procedure Append_Inherited_Subprogram (S : Entity_Id);
-- If the parent of the operation is declared in the visible part of
-- the current scope, the inherited operation is visible even though the
@@ -2473,7 +2479,7 @@
-- (Referenced_As_LHS if Out_Param is False, Referenced_As_Out_Parameter
-- if Out_Param is True) is set True, and the other flag set False.
- procedure Set_Rep_Info (T1, T2 : Entity_Id);
+ procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id);
pragma Inline (Set_Rep_Info);
-- Copies the Is_Atomic, Is_Independent and Is_Volatile_Full_Access flags
-- from sub(type) entity T2 to (sub)type entity T1, as well as Is_Volatile
