FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

exp_ch6.adb (Check_View_Conversion): Created this function to properly chain calls to check type invariants that may...

Browse source 
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.

From-SVN: r244354
This commit is contained in:
Justin Squirek 2017-01-12 13:24:16 +00:00 • committed by Arnaud Charlet
parent e51102b29c
commit 84e1361435
4 changed files with 115 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/ada/ChangeLog
View file

@ -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.

67
gcc/ada/exp_ch6.adb
View file

@ -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
@ -2350,6 +2355,57 @@ package body Exp_Ch6 is
end if;
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.

22
gcc/ada/nlists.adb
View file

@ -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 --
----------------

22
gcc/ada/nlists.ads
View file

@ -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.