diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 67 | ||||
| -rw-r--r-- | gcc/ada/nlists.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/nlists.ads | 22 |
4 files changed, 115 insertions, 6 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 37066f1d..4def327 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2017-01-12 Justin Squirek <squirek@adacore.com> + + * exp_ch6.adb (Check_View_Conversion): Created this function + to properly chain calls to check type invariants that may be + present in a subprogram call after the subprogram. + (Expand_Call): Add a conditional to identify when a view conversion + needs to be checked. + * nlists.adb, nlists.ads (Prepend_New): New routine. + (Prepend_New_To): New routine. + 2017-01-12 Hristian Kirtchev <kirtchev@adacore.com> * sinfo.ads: Minor reformatting. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index ff17867..9b740ca 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2264,6 +2264,11 @@ package body Exp_Ch6 is -- expression for the value of the actual, EF is the entity for the -- extra formal. + procedure Check_View_Conversion (Formal : Entity_Id; Actual : Node_Id); + -- Adds Invariant checks for every intermediate type between + -- the range of a view converted argument to its ancestor (from + -- parent to child). + function Inherited_From_Formal (S : Entity_Id) return Entity_Id; -- Within an instance, a type derived from an untagged formal derived -- type inherits from the original parent, not from the actual. The @@ -2351,6 +2356,57 @@ package body Exp_Ch6 is end Add_Extra_Actual; --------------------------- + -- Check_View_Conversion -- + --------------------------- + + procedure Check_View_Conversion (Formal : Entity_Id; Actual : Node_Id) is + Arg : Entity_Id; + Curr_Typ : Entity_Id := Empty; + Inv_Checks : List_Id; + Par_Typ : Entity_Id; + + begin + Inv_Checks := No_List; + + -- Extract actual object for type conversions + + Arg := Actual; + while Nkind (Arg) = N_Type_Conversion loop + Arg := Expression (Arg); + end loop; + + -- Move up the derivation chain starting with the type of the + -- the formal parameter down to the type of the actual object. + + Par_Typ := Etype (Arg); + while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop + Curr_Typ := Par_Typ; + if Has_Invariants (Curr_Typ) + and then Present (Invariant_Procedure (Curr_Typ)) + then + -- Verify the invariate of the current type. Generate: + -- Invariant_Check_Curr_Typ (Curr_Typ (Arg)); + + Prepend_New_To (Inv_Checks, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (Invariant_Procedure (Curr_Typ), Loc), + Parameter_Associations => New_List ( + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc), + Expression => New_Copy_Tree (Arg))))); + end if; + + Par_Typ := Base_Type (Etype (Curr_Typ)); + end loop; + + if not Is_Empty_List (Inv_Checks) then + Insert_Actions_After (N, Inv_Checks); + end if; + end Check_View_Conversion; + + --------------------------- -- Inherited_From_Formal -- --------------------------- @@ -3233,6 +3289,17 @@ package body Exp_Ch6 is Duplicate_Subexpr_Move_Checks (Actual))); end if; + -- Invariant checks are performed for every intermediate type between + -- the range of a view converted argument to its ancestor (from + -- parent to child) if it is passed as an "out" or "in out" parameter + -- after executing the call (RM 7.3.2 (11-14)). + + if Ekind (Formal) /= E_In_Parameter + and then Nkind (Actual) = N_Type_Conversion + then + Check_View_Conversion (Formal, Actual); + end if; + -- This label is required when skipping extra actual generation for -- Unchecked_Union parameters. diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index e366786..b5b2d8a 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -1158,6 +1158,28 @@ package body Nlists is Prepend_List (List, To); end Prepend_List_To; + ----------------- + -- Prepend_New -- + ----------------- + + procedure Prepend_New (Node : Node_Or_Entity_Id; To : in out List_Id) is + begin + if No (To) then + To := New_List; + end if; + + Prepend (Node, To); + end Prepend_New; + + -------------------- + -- Prepend_New_To -- + -------------------- + + procedure Prepend_New_To (To : in out List_Id; Node : Node_Or_Entity_Id) is + begin + Prepend_New (Node, To); + end Prepend_New_To; + ---------------- -- Prepend_To -- ---------------- diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 7bfeeb9..1cdcee6 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -289,12 +289,6 @@ package Nlists is -- node list. An attempt to prepend an error node is ignored without -- complaint and the list is unchanged. - procedure Prepend_To - (To : List_Id; - Node : Node_Or_Entity_Id); - pragma Inline (Prepend_To); - -- Like Prepend, but arguments are the other way round - procedure Prepend_List (List : List_Id; To : List_Id); @@ -307,6 +301,22 @@ package Nlists is pragma Inline (Prepend_List_To); -- Like Prepend_List, but arguments are the other way round + procedure Prepend_New (Node : Node_Or_Entity_Id; To : in out List_Id); + pragma Inline (Append_New); + -- Prepends Node at the end of node list To. If To is non-existent list, a + -- list is created. Node must be a non-empty node that is not already a + -- member of a node list, and To must be a node list. + + procedure Prepend_New_To (To : in out List_Id; Node : Node_Or_Entity_Id); + pragma Inline (Append_New_To); + -- Like Prepend_New, but the arguments are in reverse order + + procedure Prepend_To + (To : List_Id; + Node : Node_Or_Entity_Id); + pragma Inline (Prepend_To); + -- Like Prepend, but arguments are the other way round + procedure Remove (Node : Node_Or_Entity_Id); -- Removes Node, which must be a node that is a member of a node list, -- from this node list. The contents of Node are not otherwise affected. |