exp_ch6.adb (Check_View_Conversion): Created this function to properly chain…

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

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

gcc/ada/ChangeLog

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

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.
 

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

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.