@@ -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.
---------------------------------------------------------
@@ -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
- Orig_Lhs : constant Node_Id := Name (N);
- Orig_Ref : constant Node_Id := Ultimate_Prefix (Orig_Lhs);
-
- Id : Entity_Id;
- Ref : Node_Id;
+ -- 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);
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.
-
- 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);
+ -- Ghost assignments are irrelevant when the expander is inactive, and
+ -- processing them in that mode can lead to spurious errors.
+
+ 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;
- -- A potential reference to a Ghost entity is already properly resolved
- -- when the left-hand side is analyzed.
+ -- 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.
- else
- Ref := Orig_Ref;
- end if;
+ 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;
- -- An assignment statement becomes Ghost when its target denotes a Ghost
- -- object. Install the Ghost mode of the target.
+ declare
+ Whole : constant Node_Id := Whole_Object_Ref (Lhs);
+ Id : Entity_Id;
+ begin
+ if Is_Entity_Name (Whole) then
+ Id := Entity (Whole);
- Id := Ghost_Entity (Ref);
+ if Present (Id) then
+ -- Left-hand side denotes a Checked ghost entity, so
+ -- install the region.
- if Present (Id) then
- if Is_Checked_Ghost_Entity (Id) then
- Install_Ghost_Region (Check, N);
+ if Is_Checked_Ghost_Entity (Id) then
+ Install_Ghost_Region (Check, N);
- elsif Is_Ignored_Ghost_Entity (Id) then
- Install_Ghost_Region (Ignore, 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.
- Set_Is_Ignored_Ghost_Node (N);
- Record_Ignored_Ghost_Node (N);
- end if;
+ 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;
@@ -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
@@ -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.
@@ -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;
@@ -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.
-
- 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;
+ -- 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.
- 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;
+ 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;
- Urefs.Table (J).Err := No_Error_Msg;
+ 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;
- -- 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;
+ Urefs.Table (J).Err := No_Error_Msg;
end if;
- end loop;
- -- If entry not found, this is first undefined occurrence
+ -- 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.
- if Nvis then
- Error_Msg_N ("& is not visible!", N);
- Emsg := Get_Msg_Id;
+ Msg := False;
+ Set_Error_Posted (N);
+ return;
+ end if;
+ end loop;
- else
- Error_Msg_N ("& is undefined!", N);
- Emsg := Get_Msg_Id;
+ -- If entry not found, this is first undefined occurrence
- -- 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 Nvis then
+ Error_Msg_N ("& is not visible!", N);
+ Emsg := Get_Msg_Id;
- 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);
+ else
+ Error_Msg_N ("& is undefined!", N);
+ Emsg := Get_Msg_Id;
- -- 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.
+ -- 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).
- 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;
+ 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);
- -- Now check for possible misspellings
+ -- 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.
- declare
- E : Entity_Id;
- Ematch : Entity_Id := Empty;
+ 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;
- Last_Name_Id : constant Name_Id :=
- Name_Id (Nat (First_Name_Id) +
- Name_Entries_Count - 1);
+ -- Now check for possible misspellings
- begin
- for Nam in First_Name_Id .. Last_Name_Id loop
- E := Get_Name_Entity_Id (Nam);
+ declare
+ E : Entity_Id;
+ Ematch : Entity_Id := Empty;
- 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 if;
- end loop;
+ Last_Name_Id : constant Name_Id :=
+ Name_Id (Nat (First_Name_Id) +
+ Name_Entries_Count - 1);
- if Present (Ematch) then
- Error_Msg_NE -- CODEFIX
- ("\possible misspelling of&", N, Ematch);
+ 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 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;
+ 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.
- Msg := True;
+ 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;
@@ -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,
@@ -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
@@ -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 --
-----------------------
@@ -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