MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Expanded names in ghost assignments

Browse Source 
gcc/ada/

	* ghost.adb (Whole_Object_Ref): New function to compute the name
	of the whole object.
	(Mark_And_Set_Ghost_Assignment): Rewrite to use
	Whole_Object_Ref.  We need to partly analyze the left-hand side
	in order to distinguish expanded names and record components.
	* lib-xref.ads, lib-xref.adb (Deferred_References): Move table
	to body, and add Defer_Reference to update the table, avoiding
	duplicates.
	(Generate_Reference): Avoid duplicates.
	* sem_ch8.ads, sem_ch8.adb (Find_Direct_Name): Remove _OK
	parameters, which are no longer needed. Ignore errors in
	Ignore_Errors mode.
	* sem_util.ads, sem_util.adb (Preanalyze_Without_Errors): Make
	this public, so we can call it from Ghost.
	* errout.ads, scng.adb, sem_prag.adb: Minor.
This commit is contained in:
Bob Duff 2020-07-07 17:29:44 -04:00 committed by Pierre-Marie de Rodat
parent 08b0a5e200
commit 2bb7741fbe
10 changed files with 261 additions and 217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/errout.ads
View File

@ -112,8 +112,8 @@ package Errout is
-- already placed an error (not warning) message at that location,
-- then we assume this is cascaded junk and delete the message.
-- This normal suppression action may be overridden in cases 2-5 (but not
-- in case 1 or 7 by setting All_Errors mode, or by setting the special
-- This normal suppression action may be overridden in cases 2-5 (but
-- not in case 1 or 7) by setting All_Errors mode, or by setting the
-- unconditional message insertion character (!) as described below.
---------------------------------------------------------

145
gcc/ada/ghost.adb
View File

@ -34,7 +34,6 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
@ -65,6 +64,12 @@ package body Ghost is
-- Local subprograms --
-----------------------
function Whole_Object_Ref (Ref : Node_Id) return Node_Id;
-- For a name that denotes an object, returns a name that denotes the whole
-- object, declared by an object declaration, formal parameter declaration,
-- etc. For example, for P.X.Comp (J), if P is a package X is a record
-- object, this returns P.X.
function Ghost_Entity (Ref : Node_Id) return Entity_Id;
pragma Inline (Ghost_Entity);
-- Obtain the entity of a Ghost entity from reference Ref. Return Empty if
@ -1009,10 +1014,8 @@ package body Ghost is
----------------------------
function Ultimate_Original_Node (Nod : Node_Id) return Node_Id is
Res : Node_Id;
Res : Node_Id := Nod;
begin
Res := Nod;
while Original_Node (Res) /= Res loop
Res := Original_Node (Res);
end loop;
@ -1176,61 +1179,73 @@ package body Ghost is
-----------------------------------
procedure Mark_And_Set_Ghost_Assignment (N : Node_Id) is
-- A ghost assignment is an assignment whose left-hand side denotes a
-- ghost object. Subcomponents are not marked "ghost", so we need to
-- find the containing "whole" object. So, for "P.X.Comp (J) := ...",
-- where P is a package, X is a record, and Comp is an array, we need
-- to check the ghost flags of X.
Orig_Lhs : constant Node_Id := Name (N);
Orig_Ref : constant Node_Id := Ultimate_Prefix (Orig_Lhs);
Id : Entity_Id;
Ref : Node_Id;
begin
-- A reference to a whole Ghost object (SPARK RM 6.9(1)) appears as an
-- identifier. If the reference has not been analyzed yet, preanalyze a
-- copy of the reference to discover the nature of its entity.
-- Ghost assignments are irrelevant when the expander is inactive, and
-- processing them in that mode can lead to spurious errors.
if Nkind (Orig_Ref) = N_Identifier and then not Analyzed (Orig_Ref) then
Ref := New_Copy_Tree (Orig_Ref);
-- Alter the assignment statement by setting its left-hand side to
-- the copy.
Set_Name (N, Ref);
Set_Parent (Ref, N);
-- Preanalysis is carried out by looking for a Ghost entity while
-- suppressing all possible side effects.
Find_Direct_Name
(N => Ref,
Errors_OK => False,
Marker_OK => False,
Reference_OK => False);
-- Restore the original state of the assignment statement
Set_Name (N, Orig_Lhs);
-- A potential reference to a Ghost entity is already properly resolved
-- when the left-hand side is analyzed.
else
Ref := Orig_Ref;
end if;
-- An assignment statement becomes Ghost when its target denotes a Ghost
-- object. Install the Ghost mode of the target.
Id := Ghost_Entity (Ref);
if Present (Id) then
if Is_Checked_Ghost_Entity (Id) then
Install_Ghost_Region (Check, N);
elsif Is_Ignored_Ghost_Entity (Id) then
Install_Ghost_Region (Ignore, N);
Set_Is_Ignored_Ghost_Node (N);
Record_Ignored_Ghost_Node (N);
if Expander_Active then
if not Analyzed (Orig_Lhs)
and then Nkind (Orig_Lhs) = N_Indexed_Component
and then Nkind (Prefix (Orig_Lhs)) = N_Selected_Component
and then Nkind (Prefix (Prefix (Orig_Lhs))) =
N_Indexed_Component
then
Analyze (Orig_Lhs);
end if;
-- Make sure Lhs is at least preanalyzed, so we can tell whether
-- it denotes a ghost variable. In some cases we need to do a full
-- analysis, or else the back end gets confused. Note that in the
-- preanalysis case, we are preanalyzing a copy of the left-hand
-- side name, temporarily attached to the tree.
declare
Lhs : constant Node_Id :=
(if Analyzed (Orig_Lhs) then Orig_Lhs
else New_Copy_Tree (Orig_Lhs));
begin
if not Analyzed (Lhs) then
Set_Name (N, Lhs);
Set_Parent (Lhs, N);
Preanalyze_Without_Errors (Lhs);
Set_Name (N, Orig_Lhs);
end if;
declare
Whole : constant Node_Id := Whole_Object_Ref (Lhs);
Id : Entity_Id;
begin
if Is_Entity_Name (Whole) then
Id := Entity (Whole);
if Present (Id) then
-- Left-hand side denotes a Checked ghost entity, so
-- install the region.
if Is_Checked_Ghost_Entity (Id) then
Install_Ghost_Region (Check, N);
-- Left-hand side denotes an Ignored ghost entity, so
-- install the region, and mark the assignment statement
-- as an ignored ghost assignment, so it will be removed
-- later.
elsif Is_Ignored_Ghost_Entity (Id) then
Install_Ghost_Region (Ignore, N);
Set_Is_Ignored_Ghost_Node (N);
Record_Ignored_Ghost_Node (N);
end if;
end if;
end if;
end;
end;
end if;
end Mark_And_Set_Ghost_Assignment;
@ -1855,4 +1870,24 @@ package body Ghost is
end if;
end Set_Is_Ghost_Entity;
----------------------
-- Whole_Object_Ref --
----------------------
function Whole_Object_Ref (Ref : Node_Id) return Node_Id is
begin
if Nkind (Ref) in N_Indexed_Component | N_Slice
or else (Nkind (Ref) = N_Selected_Component
and then Is_Object_Reference (Prefix (Ref)))
then
if Is_Access_Type (Etype (Prefix (Ref))) then
return Ref;
else
return Whole_Object_Ref (Prefix (Ref));
end if;
else
return Ref;
end if;
end Whole_Object_Ref;
end Ghost;

31
gcc/ada/lib-xref.adb
View File

@ -53,6 +53,14 @@ package body Lib.Xref is
-- Declarations --
------------------
package Deferred_References is new Table.Table (
Table_Component_Type => Deferred_Reference_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 512,
Table_Increment => 200,
Table_Name => "Name_Deferred_References");
-- The Xref table is used to record references. The Loc field is set
-- to No_Location for a definition entry.
@ -199,6 +207,21 @@ package body Lib.Xref is
end if;
end Add_Entry;
---------------------
-- Defer_Reference --
---------------------
procedure Defer_Reference (Deferred_Reference : Deferred_Reference_Entry) is
begin
-- If Get_Ignore_Errors, then we are in Preanalyze_Without_Errors, and
-- we should not record cross references, because that will cause
-- duplicates when we call Analyze.
if not Get_Ignore_Errors then
Deferred_References.Append (Deferred_Reference);
end if;
end Defer_Reference;
-----------
-- Equal --
-----------
@ -595,6 +618,14 @@ package body Lib.Xref is
-- Start of processing for Generate_Reference
begin
-- If Get_Ignore_Errors, then we are in Preanalyze_Without_Errors, and
-- we should not record cross references, because that will cause
-- duplicates when we call Analyze.
if Get_Ignore_Errors then
return;
end if;
-- May happen in case of severe errors
if Nkind (E) not in N_Entity then

13
gcc/ada/lib-xref.ads
View File

@ -591,8 +591,8 @@ package Lib.Xref is
-- What we do in such cases is to gather nodes, where we would have liked
-- to call Generate_Reference but we couldn't because we didn't know enough
-- into this table, then we deal with generating references later on when
-- we have sufficient information to do it right.
-- into a table, then we deal with generating references later on when we
-- have sufficient information to do it right.
type Deferred_Reference_Entry is record
E : Entity_Id;
@ -600,13 +600,8 @@ package Lib.Xref is
end record;
-- One entry, E, N are as required for Generate_Reference call
package Deferred_References is new Table.Table (
Table_Component_Type => Deferred_Reference_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 512,
Table_Increment => 200,
Table_Name => "Name_Deferred_References");
procedure Defer_Reference (Deferred_Reference : Deferred_Reference_Entry);
-- Add one entry to the deferred reference table
procedure Process_Deferred_References;
-- This procedure is called from Frontend to process these table entries.

2
gcc/ada/scng.adb
View File

@ -2574,7 +2574,7 @@ package body Scng is
Token := Tok_Identifier;
-- Here is where we check if it was a keyword
-- Check if it is a keyword
if Is_Keyword_Name (Token_Name) then
Accumulate_Token_Checksum;

244
gcc/ada/sem_ch8.adb
View File

@ -5013,12 +5013,7 @@ package body Sem_Ch8 is
-- Find_Direct_Name --
----------------------
procedure Find_Direct_Name
(N : Node_Id;
Errors_OK : Boolean := True;
Marker_OK : Boolean := True;
Reference_OK : Boolean := True)
is
procedure Find_Direct_Name (N : Node_Id) is
E : Entity_Id;
E2 : Entity_Id;
Msg : Boolean;
@ -5285,10 +5280,6 @@ package body Sem_Ch8 is
Item : Node_Id;
begin
if not Errors_OK then
return;
end if;
-- Ada 2005 (AI-262): Generate a precise error concerning the
-- Beaujolais effect that was previously detected
@ -5456,8 +5447,7 @@ package body Sem_Ch8 is
-- Named aggregate should also be handled similarly ???
if Errors_OK
and then Nkind (N) = N_Identifier
if Nkind (N) = N_Identifier
and then Nkind (Parent (N)) = N_Case_Statement_Alternative
then
declare
@ -5493,122 +5483,119 @@ package body Sem_Ch8 is
Set_Entity (N, Any_Id);
Set_Etype (N, Any_Type);
if Errors_OK then
-- We use the table Urefs to keep track of entities for which we
-- have issued errors for undefined references. Multiple errors
-- for a single name are normally suppressed, however we modify
-- the error message to alert the programmer to this effect.
-- We use the table Urefs to keep track of entities for which we
-- have issued errors for undefined references. Multiple errors
-- for a single name are normally suppressed, however we modify
-- the error message to alert the programmer to this effect.
for J in Urefs.First .. Urefs.Last loop
if Chars (N) = Chars (Urefs.Table (J).Node) then
if Urefs.Table (J).Err /= No_Error_Msg
and then Sloc (N) /= Urefs.Table (J).Loc
then
Error_Msg_Node_1 := Urefs.Table (J).Node;
if Urefs.Table (J).Nvis then
Change_Error_Text (Urefs.Table (J).Err,
"& is not visible (more references follow)");
else
Change_Error_Text (Urefs.Table (J).Err,
"& is undefined (more references follow)");
end if;
Urefs.Table (J).Err := No_Error_Msg;
end if;
-- Although we will set Msg False, and thus suppress the
-- message, we also set Error_Posted True, to avoid any
-- cascaded messages resulting from the undefined reference.
Msg := False;
Set_Error_Posted (N);
return;
end if;
end loop;
-- If entry not found, this is first undefined occurrence
if Nvis then
Error_Msg_N ("& is not visible!", N);
Emsg := Get_Msg_Id;
else
Error_Msg_N ("& is undefined!", N);
Emsg := Get_Msg_Id;
-- A very bizarre special check, if the undefined identifier
-- is Put or Put_Line, then add a special error message (since
-- this is a very common error for beginners to make).
if Chars (N) in Name_Put | Name_Put_Line then
Error_Msg_N -- CODEFIX
("\\possible missing `WITH Ada.Text_'I'O; " &
"USE Ada.Text_'I'O`!", N);
-- Another special check if N is the prefix of a selected
-- component which is a known unit: add message complaining
-- about missing with for this unit.
elsif Nkind (Parent (N)) = N_Selected_Component
and then N = Prefix (Parent (N))
and then Is_Known_Unit (Parent (N))
for J in Urefs.First .. Urefs.Last loop
if Chars (N) = Chars (Urefs.Table (J).Node) then
if Urefs.Table (J).Err /= No_Error_Msg
and then Sloc (N) /= Urefs.Table (J).Loc
then
Error_Msg_Node_2 := Selector_Name (Parent (N));
Error_Msg_N -- CODEFIX
("\\missing `WITH &.&;`", Prefix (Parent (N)));
Error_Msg_Node_1 := Urefs.Table (J).Node;
if Urefs.Table (J).Nvis then
Change_Error_Text (Urefs.Table (J).Err,
"& is not visible (more references follow)");
else
Change_Error_Text (Urefs.Table (J).Err,
"& is undefined (more references follow)");
end if;
Urefs.Table (J).Err := No_Error_Msg;
end if;
-- Now check for possible misspellings
-- Although we will set Msg False, and thus suppress the
-- message, we also set Error_Posted True, to avoid any
-- cascaded messages resulting from the undefined reference.
declare
E : Entity_Id;
Ematch : Entity_Id := Empty;
Msg := False;
Set_Error_Posted (N);
return;
end if;
end loop;
Last_Name_Id : constant Name_Id :=
Name_Id (Nat (First_Name_Id) +
Name_Entries_Count - 1);
-- If entry not found, this is first undefined occurrence
begin
for Nam in First_Name_Id .. Last_Name_Id loop
E := Get_Name_Entity_Id (Nam);
if Nvis then
Error_Msg_N ("& is not visible!", N);
Emsg := Get_Msg_Id;
if Present (E)
and then (Is_Immediately_Visible (E)
or else
Is_Potentially_Use_Visible (E))
then
if Is_Bad_Spelling_Of (Chars (N), Nam) then
Ematch := E;
exit;
end if;
else
Error_Msg_N ("& is undefined!", N);
Emsg := Get_Msg_Id;
-- A very bizarre special check, if the undefined identifier
-- is Put or Put_Line, then add a special error message (since
-- this is a very common error for beginners to make).
if Chars (N) in Name_Put | Name_Put_Line then
Error_Msg_N -- CODEFIX
("\\possible missing `WITH Ada.Text_'I'O; " &
"USE Ada.Text_'I'O`!", N);
-- Another special check if N is the prefix of a selected
-- component which is a known unit: add message complaining
-- about missing with for this unit.
elsif Nkind (Parent (N)) = N_Selected_Component
and then N = Prefix (Parent (N))
and then Is_Known_Unit (Parent (N))
then
Error_Msg_Node_2 := Selector_Name (Parent (N));
Error_Msg_N -- CODEFIX
("\\missing `WITH &.&;`", Prefix (Parent (N)));
end if;
-- Now check for possible misspellings
declare
E : Entity_Id;
Ematch : Entity_Id := Empty;
Last_Name_Id : constant Name_Id :=
Name_Id (Nat (First_Name_Id) +
Name_Entries_Count - 1);
begin
for Nam in First_Name_Id .. Last_Name_Id loop
E := Get_Name_Entity_Id (Nam);
if Present (E)
and then (Is_Immediately_Visible (E)
or else
Is_Potentially_Use_Visible (E))
then
if Is_Bad_Spelling_Of (Chars (N), Nam) then
Ematch := E;
exit;
end if;
end loop;
if Present (Ematch) then
Error_Msg_NE -- CODEFIX
("\possible misspelling of&", N, Ematch);
end if;
end;
end if;
end loop;
-- Make entry in undefined references table unless the full errors
-- switch is set, in which case by refraining from generating the
-- table entry we guarantee that we get an error message for every
-- undefined reference. The entry is not added if we are ignoring
-- errors.
if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then
Urefs.Append (
(Node => N,
Err => Emsg,
Nvis => Nvis,
Loc => Sloc (N)));
end if;
Msg := True;
if Present (Ematch) then
Error_Msg_NE -- CODEFIX
("\possible misspelling of&", N, Ematch);
end if;
end;
end if;
-- Make entry in undefined references table unless the full errors
-- switch is set, in which case by refraining from generating the
-- table entry we guarantee that we get an error message for every
-- undefined reference. The entry is not added if we are ignoring
-- errors.
if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then
Urefs.Append (
(Node => N,
Err => Emsg,
Nvis => Nvis,
Loc => Sloc (N)));
end if;
Msg := True;
end Undefined;
-- Local variables
@ -5731,6 +5718,12 @@ package body Sem_Ch8 is
E := Homonym (E);
end loop;
-- If we are ignoring errors, skip the error processing
if Get_Ignore_Errors then
return;
end if;
-- If no entries on homonym chain that were potentially visible,
-- and no entities reasonably considered as non-visible, then
-- we have a plain undefined reference, with no additional
@ -6050,7 +6043,7 @@ package body Sem_Ch8 is
-- If no homonyms were visible, the entity is unambiguous
if not Is_Overloaded (N) then
if Reference_OK and then not Is_Actual_Parameter then
if not Is_Actual_Parameter then
Generate_Reference (E, N);
end if;
end if;
@ -6069,8 +6062,7 @@ package body Sem_Ch8 is
-- in SPARK mode where renamings are traversed for generating
-- local effects of subprograms.
if Reference_OK
and then Is_Object (E)
if Is_Object (E)
and then Present (Renamed_Object (E))
and then not GNATprove_Mode
then
@ -6100,7 +6092,7 @@ package body Sem_Ch8 is
-- Generate reference unless this is an actual parameter
-- (see comment below).
if Reference_OK and then not Is_Actual_Parameter then
if not Is_Actual_Parameter then
Generate_Reference (E, N);
Set_Referenced (E, R);
end if;
@ -6109,7 +6101,7 @@ package body Sem_Ch8 is
-- Normal case, not a label: generate reference
else
if Reference_OK and then not Is_Actual_Parameter then
if not Is_Actual_Parameter then
-- Package or generic package is always a simple reference
@ -6129,7 +6121,7 @@ package body Sem_Ch8 is
-- If we don't know now, generate reference later
when Unknown =>
Deferred_References.Append ((E, N));
Defer_Reference ((E, N));
end case;
end if;
end if;
@ -6178,11 +6170,7 @@ package body Sem_Ch8 is
-- reference is a write when it appears on the left hand side of an
-- assignment.
if Marker_OK
and then Needs_Variable_Reference_Marker
(N => N,
Calls_OK => False)
then
if Needs_Variable_Reference_Marker (N => N, Calls_OK => False) then
declare
Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes;
@ -6746,7 +6734,7 @@ package body Sem_Ch8 is
Generate_Reference (Id, N, 'r');
when Unknown =>
Deferred_References.Append ((Id, N));
Defer_Reference ((Id, N));
end case;
end if;

6
gcc/ada/sem_ch8.ads
View File

@ -82,11 +82,7 @@ package Sem_Ch8 is
-- Subsidiaries of End_Use_Clauses. Also called directly for use clauses
-- appearing in context clauses.
procedure Find_Direct_Name
(N : Node_Id;
Errors_OK : Boolean := True;
Marker_OK : Boolean := True;
Reference_OK : Boolean := True);
procedure Find_Direct_Name (N : Node_Id);
-- Given a direct name (Identifier or Operator_Symbol), this routine scans
-- the homonym chain for the name, searching for corresponding visible
-- entities to find the referenced entity (or in the case of overloading,

2
gcc/ada/sem_prag.adb
View File

@ -17021,7 +17021,7 @@ package body Sem_Prag is
return;
end if;
-- Otherwie the expression is not static
-- Otherwise the expression is not static
else
Error_Pragma_Arg

28
gcc/ada/sem_util.adb
View File

@ -2544,10 +2544,6 @@ package body Sem_Util is
-- second occurrence, the error is reported, and the tree traversal
-- is abandoned.
procedure Preanalyze_Without_Errors (N : Node_Id);
-- Preanalyze N without reporting errors. Very dubious, you can't just
-- go analyzing things more than once???
-------------------------
-- Collect_Identifiers --
-------------------------
@ -2774,18 +2770,6 @@ package body Sem_Util is
Do_Traversal (N);
end Collect_Identifiers;
-------------------------------
-- Preanalyze_Without_Errors --
-------------------------------
procedure Preanalyze_Without_Errors (N : Node_Id) is
Status : constant Boolean := Get_Ignore_Errors;
begin
Set_Ignore_Errors (True);
Preanalyze (N);
Set_Ignore_Errors (Status);
end Preanalyze_Without_Errors;
-- Start of processing for Check_Function_Writable_Actuals
begin
@ -25057,6 +25041,18 @@ package body Sem_Util is
return Kind;
end Policy_In_Effect;
-------------------------------
-- Preanalyze_Without_Errors --
-------------------------------
procedure Preanalyze_Without_Errors (N : Node_Id) is
Status : constant Boolean := Get_Ignore_Errors;
begin
Set_Ignore_Errors (True);
Preanalyze (N);
Set_Ignore_Errors (Status);
end Preanalyze_Without_Errors;
-----------------------
-- Predicate_Enabled --
-----------------------

3
gcc/ada/sem_util.ads
View File

@ -3156,6 +3156,9 @@ package Sem_Util is
function Yields_Universal_Type (N : Node_Id) return Boolean;
-- Determine whether unanalyzed node N yields a universal type
procedure Preanalyze_Without_Errors (N : Node_Id);
-- Preanalyze N without reporting errors
package Interval_Lists is
type Discrete_Interval is
record