===================================================================
@@ -4716,7 +4716,14 @@ package body Exp_Util is
-- some cases, and an assignment can modify the component
-- designated by N, so we need to create a temporary for it.
+ -- The guard testing for Entity being present is needed at least
+ -- in the case of rewritten predicate expressions, and may be
+ -- appropriate elsewhere. Obviously we can't go testing the entity
+ -- field if it does not exist, so it's reasonable to say that this
+ -- is not the renaming case if it does not exist.
+
elsif Is_Entity_Name (Original_Node (N))
+ and then Present (Entity (Original_Node (N)))
and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
and then Ekind (Entity (Original_Node (N))) /= E_Constant
then
===================================================================
@@ -513,10 +513,10 @@ package body Einfo is
-- Is_Underlying_Record_View Flag246
-- OK_To_Rename Flag247
-- Has_Inheritable_Invariants Flag248
- -- OK_To_Reference Flag249
-- Has_Predicates Flag250
-- (unused) Flag151
+ -- (unused) Flag249
-- (unused) Flag251
-- (unused) Flag252
-- (unused) Flag253
@@ -2314,11 +2314,6 @@ package body Einfo is
return Uint10 (Id);
end Normalized_Position_Max;
- function OK_To_Reference (Id : E) return B is
- begin
- return Flag249 (Id);
- end OK_To_Reference;
-
function OK_To_Rename (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Variable);
@@ -4808,11 +4803,6 @@ package body Einfo is
Set_Uint10 (Id, V);
end Set_Normalized_Position_Max;
- procedure Set_OK_To_Reference (Id : E; V : B := True) is
- begin
- Set_Flag249 (Id, V);
- end Set_OK_To_Reference;
-
procedure Set_OK_To_Rename (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Variable);
@@ -7517,7 +7507,6 @@ package body Einfo is
W ("No_Strict_Aliasing", Flag136 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Nonzero_Is_True", Flag162 (Id));
- W ("OK_To_Reference", Flag249 (Id));
W ("OK_To_Rename", Flag247 (Id));
W ("OK_To_Reorder_Components", Flag239 (Id));
W ("Optimize_Alignment_Space", Flag241 (Id));
===================================================================
@@ -3151,12 +3151,6 @@ package Einfo is
-- Applies to subprograms and subprogram types. Yields the number of
-- formals as a value of type Pos.
-
-- OK_To_Rename (Flag247)
-- Present only in entities for variables. If this flag is set, it
-- means that if the entity is used as the initial value of an object
@@ -4739,7 +4733,6 @@ package Einfo is
-- Needs_Debug_Info (Flag147)
-- Never_Set_In_Source (Flag115)
-- No_Return (Flag113)
- -- OK_To_Reference (Flag249)
-- Overlays_Constant (Flag243)
-- Referenced (Flag156)
-- Referenced_As_LHS (Flag36)
@@ -6191,7 +6184,6 @@ package Einfo is
function Normalized_First_Bit (Id : E) return U;
function Normalized_Position (Id : E) return U;
function Normalized_Position_Max (Id : E) return U;
- function OK_To_Reference (Id : E) return B;
function OK_To_Rename (Id : E) return B;
function OK_To_Reorder_Components (Id : E) return B;
function Optimize_Alignment_Space (Id : E) return B;
@@ -6779,7 +6771,6 @@ package Einfo is
procedure Set_Normalized_First_Bit (Id : E; V : U);
procedure Set_Normalized_Position (Id : E; V : U);
procedure Set_Normalized_Position_Max (Id : E; V : U);
- procedure Set_OK_To_Reference (Id : E; V : B := True);
procedure Set_OK_To_Rename (Id : E; V : B := True);
procedure Set_OK_To_Reorder_Components (Id : E; V : B := True);
procedure Set_Optimize_Alignment_Space (Id : E; V : B := True);
@@ -7512,7 +7503,6 @@ package Einfo is
pragma Inline (Normalized_First_Bit);
pragma Inline (Normalized_Position);
pragma Inline (Normalized_Position_Max);
- pragma Inline (OK_To_Reference);
pragma Inline (OK_To_Rename);
pragma Inline (OK_To_Reorder_Components);
pragma Inline (Optimize_Alignment_Space);
@@ -7909,7 +7899,6 @@ package Einfo is
pragma Inline (Set_Normalized_Position);
pragma Inline (Set_Normalized_Position_Max);
pragma Inline (Set_OK_To_Reorder_Components);
- pragma Inline (Set_OK_To_Reference);
pragma Inline (Set_OK_To_Rename);
pragma Inline (Set_Optimize_Alignment_Space);
pragma Inline (Set_Optimize_Alignment_Time);
===================================================================
@@ -5971,12 +5971,6 @@ package body Sem_Res is
then
null;
- -- Allow reference to type specifically marked as being OK in this
- -- context (this is used for example for type names in invariants).
-
- elsif OK_To_Reference (E) then
- null;
-
-- Any other use is an eror
else
===================================================================
@@ -5584,13 +5584,6 @@ package body Sem_Ch4 is
return False;
end if;
- -- If OK_To_Reference is set for the entity, then don't complain, it
- -- means we are doing a preanalysis in which such complaints are wrong.
-
- if OK_To_Reference (Entity (Enode)) then
- return False;
- end if;
-
-- Now test the entity we got to see if it is a bad case
case Ekind (Entity (Enode)) is
===================================================================
@@ -5481,9 +5481,6 @@ package body Sem_Ch8 is
-- Reference to type name in predicate/invariant expression
- elsif OK_To_Reference (Etype (P)) then
- Analyze_Selected_Component (N);
-
elsif Is_Appropriate_For_Entry_Prefix (P_Type)
and then not In_Open_Scopes (P_Name)
and then (not Is_Concurrent_Type (Etype (P_Name))
===================================================================
@@ -134,6 +134,17 @@ package body Sem_Ch13 is
-- renaming_as_body. For tagged types, the specification is one of the
-- primitive specs.
+ generic
+ with procedure Replace_Type_Reference (N : Node_Id);
+ procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id);
+ -- This is used to scan an expression for a predicate or invariant aspect
+ -- replacing occurrences of the name TName (the name of the subtype to
+ -- which the aspect applies) with appropriate references to the parameter
+ -- of the predicate function or invariant procedure. The procedure passed
+ -- as a generic parameter does the actual replacement of node N, which is
+ -- either a simple direct reference to TName, or a selected component that
+ -- represents an appropriately qualified occurrence of TName.
+
procedure Set_Biased
(E : Entity_Id;
N : Node_Id;
@@ -3552,56 +3563,46 @@ package body Sem_Ch13 is
Assoc : List_Id;
Str : String_Id;
- function Replace_Node (N : Node_Id) return Traverse_Result;
- -- Process single node for traversal to replace type references
-
- procedure Replace_Type is new Traverse_Proc (Replace_Node);
- -- Traverse an expression changing every occurrence of an entity
- -- reference to type T with a reference to the object argument.
+ procedure Replace_Type_Reference (N : Node_Id);
+ -- Replace a single occurrence N of the subtype name with a reference
+ -- to the formal of the predicate function. N can be an identifier
+ -- referencing the subtype, or a selected component, representing an
+ -- appropriately qualified occurrence of the subtype name.
+
+ procedure Replace_Type_References is
+ new Replace_Type_References_Generic (Replace_Type_Reference);
+ -- Traverse an expression replacing all occurrences of the subtype
+ -- name with appropriate references to the object that is the formal
+ -- parameter of the predicate function.
+
+ ----------------------------
+ -- Replace_Type_Reference --
+ ----------------------------
- ------------------
- -- Replace_Node --
- ------------------
-
- function Replace_Node (N : Node_Id) return Traverse_Result is
+ procedure Replace_Type_Reference (N : Node_Id) is
begin
- -- Case of entity name referencing the type
-
- if Is_Entity_Name (N)
- and then Entity (N) = T
- then
- -- Invariant'Class, replace with T'Class (obj)
+ -- Invariant'Class, replace with T'Class (obj)
- if Class_Present (Ritem) then
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (T, Loc),
- Attribute_Name => Name_Class),
- Expression =>
- Make_Identifier (Loc,
- Chars => Object_Name)));
-
- -- Invariant, replace with obj
-
- else
- Rewrite (N,
- Make_Identifier (Loc,
- Chars => Object_Name));
- end if;
-
- -- All done with this node
-
- return Skip;
+ if Class_Present (Ritem) then
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (T, Loc),
+ Attribute_Name => Name_Class),
+ Expression =>
+ Make_Identifier (Loc,
+ Chars => Object_Name)));
- -- Not an instance of the type entity, keep going
+ -- Invariant, replace with obj
else
- return OK;
+ Rewrite (N,
+ Make_Identifier (Loc,
+ Chars => Object_Name));
end if;
- end Replace_Node;
+ end Replace_Type_Reference;
-- Start of processing for Add_Invariants
@@ -3642,21 +3643,9 @@ package body Sem_Ch13 is
-- We need to replace any occurrences of the name of the type
-- with references to the object, converted to type'Class in
- -- the case of Invariant'Class aspects. We do this by first
- -- doing a preanalysis, to identify all the entities, then
- -- we traverse looking for the type entity, and doing the
- -- necessary substitution. The preanalysis is done with the
- -- special OK_To_Reference flag set on the type, so that if
- -- we get an occurrence of this type, it will be reognized
- -- as legitimate.
-
- Set_OK_To_Reference (T, True);
- Preanalyze_Spec_Expression (Exp, Standard_Boolean);
- Set_OK_To_Reference (T, False);
+ -- the case of Invariant'Class aspects.
- -- Do the traversal
-
- Replace_Type (Exp);
+ Replace_Type_References (Exp, Chars (T));
-- Build first two arguments for Check pragma
@@ -3833,9 +3822,6 @@ package body Sem_Ch13 is
FDecl : Node_Id;
FBody : Node_Id;
- TName : constant Name_Id := Chars (Typ);
- -- Name of the type, used for replacement in predicate expression
-
Expr : Node_Id;
-- This is the expression for the return statement in the function. It
-- is build by connecting the component predicates with AND THEN.
@@ -3911,107 +3897,26 @@ package body Sem_Ch13 is
Arg1 : Node_Id;
Arg2 : Node_Id;
- function Replace_Node (N : Node_Id) return Traverse_Result;
- -- Process single node for traversal to replace type references
+ procedure Replace_Type_Reference (N : Node_Id);
+ -- Replace a single occurrence N of the subtype name with a reference
+ -- to the formal of the predicate function. N can be an identifier
+ -- referencing the subtype, or a selected component, representing an
+ -- appropriately qualified occurrence of the subtype name.
- procedure Replace_Type is new Traverse_Proc (Replace_Node);
+ procedure Replace_Type_References is
+ new Replace_Type_References_Generic (Replace_Type_Reference);
-- Traverse an expression changing every occurrence of an identifier
- -- whose name is TName with a reference to the object argument.
-
- ------------------
- -- Replace_Node --
- ------------------
+ -- whose name mathches the name of the subtype with a reference to
+ -- the formal parameter of the predicate function.
- function Replace_Node (N : Node_Id) return Traverse_Result is
- S : Entity_Id;
- P : Node_Id;
+ ----------------------------
+ -- Replace_Type_Reference --
+ ----------------------------
+ procedure Replace_Type_Reference (N : Node_Id) is
begin
- -- Case of identifier
-
- if Nkind (N) = N_Identifier then
-
- -- If not the type name, all done with this node
-
- if Chars (N) /= TName then
- return Skip;
-
- -- Otherwise do the replacement
-
- else
- goto Do_Replace;
- end if;
-
- -- Case of selected component (which is what a qualification
- -- looks like in the unanalyzed tree, which is what we have.
-
- elsif Nkind (N) = N_Selected_Component then
-
- -- If selector name is not our type, keeping going (we might
- -- still have an occurrence of the type in the prefix).
-
- if Nkind (Selector_Name (N)) /= N_Identifier
- or else Chars (Selector_Name (N)) /= TName
- then
- return OK;
-
- -- Selector name is our type, check qualification
-
- else
- -- Loop through scopes and prefixes, doing comparison
-
- S := Current_Scope;
- P := Prefix (N);
- loop
- -- Continue if no more scopes or scope with no name
-
- if No (S) or else Nkind (S) not in N_Has_Chars then
- return OK;
- end if;
-
- -- Do replace if prefix is an identifier matching the
- -- scope that we are currently looking at.
-
- if Nkind (P) = N_Identifier
- and then Chars (P) = Chars (S)
- then
- goto Do_Replace;
- end if;
-
- -- Go check scope above us if prefix is itself of the
- -- form of a selected component, whose selector matches
- -- the scope we are currently looking at.
-
- if Nkind (P) = N_Selected_Component
- and then Nkind (Selector_Name (P)) = N_Identifier
- and then Chars (Selector_Name (P)) = Chars (S)
- then
- S := Scope (S);
- P := Prefix (P);
-
- -- For anything else, we don't have a match, so keep on
- -- going, there are still some weird cases where we may
- -- still have a replacement within the prefix.
-
- else
- return OK;
- end if;
- end loop;
- end if;
-
- -- Continue for any other node kind
-
- else
- return OK;
- end if;
-
- <<Do_Replace>>
-
- -- Replace with object
-
Rewrite (N, Make_Identifier (Loc, Chars => Object_Name));
- return Skip;
- end Replace_Node;
+ end Replace_Type_Reference;
-- Start of processing for Add_Predicates
@@ -4036,7 +3941,7 @@ package body Sem_Ch13 is
-- First We need to replace any occurrences of the name of
-- the type with references to the object.
- Replace_Type (Arg2);
+ Replace_Type_References (Arg2, Chars (Typ));
-- OK, replacement complete, now we can add the expression
@@ -6751,6 +6656,113 @@ package body Sem_Ch13 is
return False;
end Rep_Item_Too_Late;
+ -------------------------------------
+ -- Replace_Type_References_Generic --
+ -------------------------------------
+
+ procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is
+
+ function Replace_Node (N : Node_Id) return Traverse_Result;
+ -- Processes a single node in the traversal procedure below, checking
+ -- if node N should be replaced, and if so, doing the replacement.
+
+ procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node);
+ -- This instantiation provides the body of Replace_Type_References
+
+ ------------------
+ -- Replace_Node --
+ ------------------
+
+ function Replace_Node (N : Node_Id) return Traverse_Result is
+ S : Entity_Id;
+ P : Node_Id;
+
+ begin
+ -- Case of identifier
+
+ if Nkind (N) = N_Identifier then
+
+ -- If not the type name, all done with this node
+
+ if Chars (N) /= TName then
+ return Skip;
+
+ -- Otherwise do the replacement and we are done with this node
+
+ else
+ Replace_Type_Reference (N);
+ return Skip;
+ end if;
+
+ -- Case of selected component (which is what a qualification
+ -- looks like in the unanalyzed tree, which is what we have.
+
+ elsif Nkind (N) = N_Selected_Component then
+
+ -- If selector name is not our type, keeping going (we might
+ -- still have an occurrence of the type in the prefix).
+
+ if Nkind (Selector_Name (N)) /= N_Identifier
+ or else Chars (Selector_Name (N)) /= TName
+ then
+ return OK;
+
+ -- Selector name is our type, check qualification
+
+ else
+ -- Loop through scopes and prefixes, doing comparison
+
+ S := Current_Scope;
+ P := Prefix (N);
+ loop
+ -- Continue if no more scopes or scope with no name
+
+ if No (S) or else Nkind (S) not in N_Has_Chars then
+ return OK;
+ end if;
+
+ -- Do replace if prefix is an identifier matching the
+ -- scope that we are currently looking at.
+
+ if Nkind (P) = N_Identifier
+ and then Chars (P) = Chars (S)
+ then
+ Replace_Type_Reference (N);
+ return Skip;
+ end if;
+
+ -- Go check scope above us if prefix is itself of the
+ -- form of a selected component, whose selector matches
+ -- the scope we are currently looking at.
+
+ if Nkind (P) = N_Selected_Component
+ and then Nkind (Selector_Name (P)) = N_Identifier
+ and then Chars (Selector_Name (P)) = Chars (S)
+ then
+ S := Scope (S);
+ P := Prefix (P);
+
+ -- For anything else, we don't have a match, so keep on
+ -- going, there are still some weird cases where we may
+ -- still have a replacement within the prefix.
+
+ else
+ return OK;
+ end if;
+ end loop;
+ end if;
+
+ -- Continue for any other node kind
+
+ else
+ return OK;
+ end if;
+ end Replace_Node;
+
+ begin
+ Replace_Type_Refs (N);
+ end Replace_Type_References_Generic;
+
-------------------------
-- Same_Representation --
-------------------------