Seen : Subprogram_List (Subps'Range) := (others => Empty);
function Inherit_Condition
- (Par_Subp : Entity_Id;
- Subp : Entity_Id) return Node_Id;
- -- Inherit the class-wide condition from Par_Subp to Subp and adjust
- -- all the references to formals in the inherited condition.
+ (Par_Subp : Entity_Id) return Node_Id;
+ -- Inherit the class-wide condition from Par_Subp. Simply makes
+ -- a copy of the condition in preparation for later mapping of
+ -- referenced formals and functions by Build_Class_Wide_Expression.
procedure Merge_Conditions (From : Node_Id; Into : Node_Id);
-- Merge two class-wide preconditions or postconditions (the former
-----------------------
function Inherit_Condition
- (Par_Subp : Entity_Id;
- Subp : Entity_Id) return Node_Id
- is
- function Check_Condition (Expr : Node_Id) return Boolean;
- -- Used in assertion to check that Expr has no reference to the
- -- formals of Par_Subp.
-
- ---------------------
- -- Check_Condition --
- ---------------------
-
- function Check_Condition (Expr : Node_Id) return Boolean is
- Par_Formal_Id : Entity_Id;
-
- function Check_Entity (N : Node_Id) return Traverse_Result;
- -- Check occurrence of Par_Formal_Id
-
- ------------------
- -- Check_Entity --
- ------------------
-
- function Check_Entity (N : Node_Id) return Traverse_Result is
- begin
- if Nkind (N) = N_Identifier
- and then Present (Entity (N))
- and then Entity (N) = Par_Formal_Id
- then
- return Abandon;
- end if;
-
- return OK;
- end Check_Entity;
-
- function Check_Expression is new Traverse_Func (Check_Entity);
-
- -- Start of processing for Check_Condition
-
- begin
- Par_Formal_Id := First_Formal (Par_Subp);
-
- while Present (Par_Formal_Id) loop
- if Check_Expression (Expr) = Abandon then
- return False;
- end if;
-
- Next_Formal (Par_Formal_Id);
- end loop;
-
- return True;
- end Check_Condition;
-
- -- Local variables
-
- Assoc_List : constant Elist_Id := New_Elmt_List;
- Par_Formal_Id : Entity_Id := First_Formal (Par_Subp);
- Subp_Formal_Id : Entity_Id := First_Formal (Subp);
- New_Condition : Node_Id;
-
+ (Par_Subp : Entity_Id) return Node_Id is
begin
- while Present (Par_Formal_Id) loop
- Append_Elmt (Par_Formal_Id, Assoc_List);
- Append_Elmt (Subp_Formal_Id, Assoc_List);
-
- Next_Formal (Par_Formal_Id);
- Next_Formal (Subp_Formal_Id);
- end loop;
-
- -- Check that Parent field of all the nodes have their correct
- -- decoration; required because otherwise mapped nodes with
- -- wrong Parent field are left unmodified in the copied tree
- -- and cause reporting wrong errors at later stages.
-
- pragma Assert
- (Check_Parents (Class_Condition (Kind, Par_Subp), Assoc_List));
-
- New_Condition :=
+ return
New_Copy_Tree
- (Source => Class_Condition (Kind, Par_Subp),
- Map => Assoc_List);
-
- -- Ensure that the inherited condition has no reference to the
- -- formals of the parent subprogram.
-
- pragma Assert (Check_Condition (New_Condition));
-
- return New_Condition;
+ (Source => Class_Condition (Kind, Par_Subp));
end Inherit_Condition;
----------------------
Par_Prim := Subp_Id;
Par_Iface_Prims := Covered_Interface_Primitives (Par_Prim);
- Cond := Inherit_Condition
- (Subp => Spec_Id,
- Par_Subp => Subp_Id);
+ Cond := Inherit_Condition (Par_Subp => Subp_Id);
if Present (Class_Cond) then
Merge_Conditions (Cond, Class_Cond);
then
Seen (Index) := Subp_Id;
- Cond := Inherit_Condition
- (Subp => Spec_Id,
- Par_Subp => Subp_Id);
+ Cond := Inherit_Condition (Par_Subp => Subp_Id);
Check_Class_Condition
(Cond => Cond,
New_E := Type_Map.Get (Entity (N));
if Present (New_E) then
- Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
+ declare
+
+ Ctrl_Type : constant Entity_Id
+ := Find_Dispatching_Type (Par_Subp);
+
+ function Call_To_Parent_Dispatching_Op_Must_Be_Mapped
+ (Call_Node : Node_Id) return Boolean;
+ -- If Call_Node is a call to a primitive function F of the
+ -- tagged type T associated with Par_Subp that either has
+ -- any actuals that are controlling formals of Par_Subp,
+ -- or else the call to F is an actual parameter of an
+ -- enclosing call to a primitive of T that has any actuals
+ -- that are controlling formals of Par_Subp (and recursively
+ -- up the tree of enclosing function calls), returns True;
+ -- otherwise returns False. Returning True implies that the
+ -- call to F must be mapped to a call that instead targets
+ -- the corresponding function F of the tagged type for which
+ -- Subp is a primitive function.
+
+ --------------------------------------------------
+ -- Call_To_Parent_Dispatching_Op_Must_Be_Mapped --
+ --------------------------------------------------
+
+ function Call_To_Parent_Dispatching_Op_Must_Be_Mapped
+ (Call_Node : Node_Id) return Boolean
+ is
+ pragma Assert (Nkind (Call_Node) = N_Function_Call);
+
+ Actual : Node_Id := First_Actual (Call_Node);
+ Actual_Type : Entity_Id;
+ Actual_Or_Prefix : Node_Id;
+
+ begin
+ if Is_Entity_Name (Name (Call_Node))
+ and then Is_Dispatching_Operation
+ (Entity (Name (Call_Node)))
+ and then
+ Is_Ancestor
+ (Ctrl_Type,
+ Find_Dispatching_Type
+ (Entity (Name (Call_Node))))
+ then
+ while Present (Actual) loop
+
+ -- Account for 'Old and explicit dereferences,
+ -- picking up the prefix object in those cases.
+
+ if (Nkind (Actual) = N_Attribute_Reference
+ and then Attribute_Name (Actual) = Name_Old)
+ or else Nkind (Actual) = N_Explicit_Dereference
+ then
+ Actual_Or_Prefix := Prefix (Actual);
+ else
+ Actual_Or_Prefix := Actual;
+ end if;
+
+ Actual_Type := Etype (Actual);
+
+ if Is_Anonymous_Access_Type (Actual_Type) then
+ Actual_Type := Designated_Type (Actual_Type);
+ end if;
+
+ if Nkind (Actual_Or_Prefix)
+ in N_Identifier
+ | N_Expanded_Name
+ | N_Operator_Symbol
+
+ and then Is_Formal (Entity (Actual_Or_Prefix))
+
+ and then Covers (Ctrl_Type, Actual_Type)
+ then
+ -- At least one actual is a formal parameter of
+ -- Par_Subp with type Ctrl_Type.
+
+ return True;
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+
+ if Nkind (Parent (Call_Node)) = N_Function_Call then
+ return
+ Call_To_Parent_Dispatching_Op_Must_Be_Mapped
+ (Parent (Call_Node));
+ end if;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Call_To_Parent_Dispatching_Op_Must_Be_Mapped;
+
+ begin
+ -- If N's entity is in the map, then the entity is either
+ -- a formal of the parent subprogram that should necessarily
+ -- be mapped, or it's a function call's target entity that
+ -- that should be mapped if the call involves any actuals
+ -- that reference formals of the parent subprogram (or the
+ -- function call is part of an enclosing call that similarly
+ -- qualifies for mapping). Rewrite a node that references
+ -- any such qualified entity to a new node referencing the
+ -- corresponding entity associated with the derived type.
+
+ if not Is_Subprogram (Entity (N))
+ or else Nkind (Parent (N)) /= N_Function_Call
+ or else
+ Call_To_Parent_Dispatching_Op_Must_Be_Mapped (Parent (N))
+ then
+ Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
+ end if;
+ end;
end if;
-- Update type of function call node, which should be the same as
projects / thirdparty / gcc.git / commitdiff
