procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2017-09-08  Arnaud Charlet  <charlet@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.

2017-09-08  Ed Schonberg  <schonberg@adacore.com>

	* par-ch4.adb (P_Iterated_Component_Association): Place construct
	under -gnat2020 flag, given that it is a future feature of
	the language.
	* sem_aggr.adb (Resolve_Iterated_Component_Association): Mark
	defining identifier as referenced to prevent spurious warnings:
	corresponding loop is expanded into one or more loops whose
	variable has the same name, and the expression uses those names
	and not the original one.

From-SVN: r251883
This commit is contained in:
Arnaud Charlet 2017-09-08 12:11:07 +02:00
parent db174c9845
commit 72a266372b
16 changed files with 372 additions and 243 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
gcc/ada/ChangeLog
View file

@ -1,3 +1,30 @@
2017-09-08 Arnaud Charlet <charlet@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.
2017-09-08 Ed Schonberg <schonberg@adacore.com>
* par-ch4.adb (P_Iterated_Component_Association): Place construct
under -gnat2020 flag, given that it is a future feature of
the language.
* sem_aggr.adb (Resolve_Iterated_Component_Association): Mark
defining identifier as referenced to prevent spurious warnings:
corresponding loop is expanded into one or more loops whose
variable has the same name, and the expression uses those names
and not the original one.
2017-09-08 Hristian Kirtchev <kirtchev@adacore.com>
* sem_elab.adb (Check_A_Call): Do not consider

118
gcc/ada/errout.adb
View file

@ -100,7 +100,8 @@ package body Errout is
(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 @@ package body Errout is
-- 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 @@ package body Errout is
-- 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 @@ package body Errout is
-- 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 @@ package body Errout is
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 @@ package body Errout is
-- 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 @@ package body Errout is
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 @@ package body Errout is
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 @@ package body Errout is
-- 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 @@ package body Errout is
(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 @@ package body Errout is
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 @@ package body Errout is
then
Debug_Output (N);
Error_Msg_Node_1 := E;
Error_Msg (Msg, Flag_Location);
Error_Msg (Msg, Flag_Location, N);
else
Last_Killed := True;

13
gcc/ada/errout.ads
View file

@ -68,11 +68,6 @@ package Errout is
-- 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 @@ package Errout is
-- 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

18
gcc/ada/erroutc.adb
View file

@ -299,6 +299,7 @@ package body Erroutc is
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 @@ package body Erroutc is
-- 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;

10
gcc/ada/erroutc.ads
View file

@ -132,6 +132,11 @@ package Erroutc is
-- 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 @@ package Erroutc is
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 (

3
gcc/ada/errutil.adb
View file

@ -220,7 +220,8 @@ package body Errutil is
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;

2
gcc/ada/exp_disp.adb
View file

@ -1204,7 +1204,7 @@ package body Exp_Disp is
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 --

101
gcc/ada/exp_intr.adb
View file

@ -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 Atree; use Atree;
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 @@ package body Exp_Intr is
-- 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 @@ package body Exp_Intr is
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 --
---------------------------------

33
gcc/ada/exp_prag.adb
View file

@ -338,17 +338,22 @@ package body Exp_Prag is
------------------------------------------
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 @@ package body Exp_Prag is
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

6
gcc/ada/par-ch4.adb
View file

@ -3317,6 +3317,12 @@ package body Ch4 is
Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
TF_Arrow;
Set_Expression (Assoc_Node, P_Expression);
if Ada_Version < Ada_2020 then
Error_Msg_SC ("Iterated component is an Ada 2020 extension");
Error_Msg_SC ("\compile with -gnatX");
end if;
return Assoc_Node;
end P_Iterated_Component_Association;

5
gcc/ada/sem_aggr.adb
View file

@ -1694,13 +1694,16 @@ package body Sem_Aggr is
-- may have several choices, each one leading to a loop, so we create
-- this variable only once to prevent homonyms in this scope.
-- The expression has to be analyzed once the index variable is
-- directly visible.
-- directly visible. Mark the variable as referenced to prevent
-- spurious warnings, given that subsequent uses of its name in the
-- expression will reference the internal (synonym) loop variable.
if No (Scope (Id)) then
Enter_Name (Id);
Set_Etype (Id, Index_Typ);
Set_Ekind (Id, E_Variable);
Set_Scope (Id, Ent);
Set_Referenced (Id);
end if;
Push_Scope (Ent);

3
gcc/ada/sem_ch5.adb
View file

@ -3745,7 +3745,8 @@ package body Sem_Ch5 is
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;

4
gcc/ada/sem_ch6.adb
View file

@ -343,7 +343,6 @@ package body Sem_Ch6 is
----------------------
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 @@ package body Sem_Ch6 is
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

119
gcc/ada/sem_prag.adb
View file

@ -29,65 +29,66 @@
-- 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 @@ package body Sem_Prag is
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

145
gcc/ada/sem_util.adb
View file

@ -32,6 +32,7 @@ with Checks; use Checks;
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 @@ package body Sem_Util is
-- 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 @@ package body Sem_Util is
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 @@ package body Sem_Util is
-- 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 @@ package body Sem_Util is
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 @@ package body Sem_Util is
end Yields_Universal_Type;
begin
Errout.Current_Subprogram_Ptr := Current_Subprogram'Access;
Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access;
end Sem_Util;

8
gcc/ada/sem_util.ads
View file

@ -105,6 +105,12 @@ package Sem_Util is
-- 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 @@ package Sem_Util is
-- (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