diff options
Diffstat (limited to 'gcc/ada/exp_util.adb')
| -rw-r--r-- | gcc/ada/exp_util.adb | 118 |
1 files changed, 117 insertions, 1 deletions
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 028ee01..8ac1b90 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1523,7 +1523,123 @@ package body Exp_Util is 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_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; + + -- If at least one actual is a controlling formal + -- parameter of a class-wide Pre/Post aspect's + -- subprogram, the rule in RM 6.1.1(7) applies, + -- and we want to map the call to target the + -- corresponding function of the derived type. + + if Nkind (Actual_Or_Prefix) + in N_Identifier + | N_Expanded_Name + | N_Operator_Symbol + + and then Is_Formal (Entity (Actual_Or_Prefix)) + + and then Is_Controlling_Formal + (Entity (Actual_Or_Prefix)) + then + return True; + + -- RM 6.1.1(7) also applies to Result attributes + -- of primitive functions with controlling results. + + elsif Is_Attribute_Result (Actual) + and then Has_Controlling_Result (Subp) + then + 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 |