[Ada] Implement missing constraint checks for default streaming operations

gcc/ada/

	* sem_ch5.adb (Analyze_Assignment): Add new nested function,
	Omit_Range_Check_For_Streaming, and make call to
	Apply_Scalar_Range_Check conditional on the result of this new
	function.
	* exp_attr.adb (Compile_Stream_Body_In_Scope): Eliminate Check
	parameter, update callers.  The new
	Omit_Range_Check_For_Streaming parameter takes the place of the
	old use of calling Insert_Action with Suppress => All_Checks,
	which was insufficiently precise (it did not allow suppressing
	checks for one component but not for another).
	(Expand_N_Attribute_Reference): Eliminate another "Suppress =>
	All_Checks" from an Insert_Action call, this one in generating
	the expansion of a T'Read attribute reference for a composite
	type T.

2 files changed, 95 insertions, 19 deletions

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 067e7ed..e33a36e 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -117,8 +117,7 @@ package body Exp_Attr is
    procedure Compile_Stream_Body_In_Scope
      (N     : Node_Id;
       Decl  : Node_Id;
-      Arr   : Entity_Id;
-      Check : Boolean);
+      Arr   : Entity_Id);
    --  The body for a stream subprogram may be generated outside of the scope
    --  of the type. If the type is fully private, it may depend on the full
    --  view of other types (e.g. indexes) that are currently private as well.
@@ -867,8 +866,7 @@ package body Exp_Attr is
    procedure Compile_Stream_Body_In_Scope
      (N     : Node_Id;
       Decl  : Node_Id;
-      Arr   : Entity_Id;
-      Check : Boolean)
+      Arr   : Entity_Id)
    is
       C_Type  : constant Entity_Id := Base_Type (Component_Type (Arr));
       Curr    : constant Entity_Id := Current_Scope;
@@ -922,11 +920,7 @@ package body Exp_Attr is
          Install := False;
       end if;
 
-      if Check then
-         Insert_Action (N, Decl);
-      else
-         Insert_Action (N, Decl, Suppress => All_Checks);
-      end if;
+      Insert_Action (N, Decl);
 
       if Install then
 
@@ -4128,7 +4122,7 @@ package body Exp_Attr is
 
             elsif Is_Array_Type (U_Type) then
                Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
-               Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
+               Compile_Stream_Body_In_Scope (N, Decl, U_Type);
 
             --  Dispatching case with class-wide type
 
@@ -5238,7 +5232,7 @@ package body Exp_Attr is
 
             elsif Is_Array_Type (U_Type) then
                Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
-               Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
+               Compile_Stream_Body_In_Scope (N, Decl, U_Type);
 
             --  Class-wide case, first output external tag, then dispatch
             --  to the appropriate primitive Output function (RM 13.13.2(31)).
@@ -6090,7 +6084,7 @@ package body Exp_Attr is
 
             elsif Is_Array_Type (U_Type) then
                Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
-               Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
+               Compile_Stream_Body_In_Scope (N, Decl, U_Type);
 
             --  Tagged type case, use the primitive Read function. Note that
             --  this will dispatch in the class-wide case which is what we want
@@ -6129,11 +6123,7 @@ package body Exp_Attr is
                     (Loc, Full_Base (U_Type), Decl, Pname);
                end if;
 
-               --  Suppress checks, uninitialized or otherwise invalid
-               --  data does not cause constraint errors to be raised for
-               --  a complete record read.
-
-               Insert_Action (N, Decl, All_Checks);
+               Insert_Action (N, Decl);
             end if;
          end if;
 
@@ -7718,7 +7708,7 @@ package body Exp_Attr is
 
             elsif Is_Array_Type (U_Type) then
                Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
-               Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
+               Compile_Stream_Body_In_Scope (N, Decl, U_Type);
 
             --  Tagged type case, use the primitive Write function. Note that
             --  this will dispatch in the class-wide case which is what we want
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index ccd5a37..fbb6904 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -33,6 +33,7 @@ with Einfo.Utils;    use Einfo.Utils;
 with Errout;         use Errout;
 with Expander;       use Expander;
 with Exp_Ch6;        use Exp_Ch6;
+with Exp_Tss;        use Exp_Tss;
 with Exp_Util;       use Exp_Util;
 with Freeze;         use Freeze;
 with Ghost;          use Ghost;
@@ -979,7 +980,92 @@ package body Sem_Ch5 is
       end if;
 
       if Is_Scalar_Type (T1) then
-         Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
+         declare
+
+            function Omit_Range_Check_For_Streaming return Boolean;
+            --  Return True if this assignment statement is the expansion of
+            --  a Some_Scalar_Type'Read procedure call such that all conditions
+            --  of 13.3.2(35)'s "no check is made" rule are met.
+
+            ------------------------------------
+            -- Omit_Range_Check_For_Streaming --
+            ------------------------------------
+
+            function Omit_Range_Check_For_Streaming return Boolean is
+            begin
+               --  Have we got an implicitly generated assignment to a
+               --  component of a composite object? If not, return False.
+
+               if Comes_From_Source (N)
+                 or else Serious_Errors_Detected > 0
+                 or else Nkind (Lhs)
+                           not in N_Selected_Component | N_Indexed_Component
+               then
+                  return False;
+               end if;
+
+               declare
+                  Pref : constant Node_Id := Prefix (Lhs);
+               begin
+                  --  Are we in the implicitly-defined Read subprogram
+                  --  for a composite type, reading the value of a scalar
+                  --  component from the stream? If not, return False.
+
+                  if Nkind (Pref) /= N_Identifier
+                    or else not Is_TSS (Scope (Entity (Pref)), TSS_Stream_Read)
+                  then
+                     return False;
+                  end if;
+
+                  --  Return False if Default_Value or Default_Component_Value
+                  --  aspect applies.
+
+                  if Has_Default_Aspect (Etype (Lhs))
+                    or else Has_Default_Aspect (Etype (Pref))
+                  then
+                     return False;
+
+                  --  Are we assigning to a record component (as opposed to
+                  --  an array component)?
+
+                  elsif Nkind (Lhs) = N_Selected_Component then
+
+                     --  Are we assigning to a nondiscriminant component
+                     --  that lacks a default initial value expression?
+                     --  If so, return True.
+
+                     declare
+                        Comp_Id : constant Entity_Id :=
+                          Original_Record_Component
+                            (Entity (Selector_Name (Lhs)));
+                     begin
+                        if Ekind (Comp_Id) = E_Component
+                          and then Nkind (Parent (Comp_Id))
+                                     = N_Component_Declaration
+                          and then
+                            not Present (Expression (Parent (Comp_Id)))
+                        then
+                           return True;
+                        end if;
+                        return False;
+                     end;
+
+                  --  We are assigning to a component of an array
+                  --  (and we tested for both Default_Value and
+                  --  Default_Component_Value above), so return True.
+
+                  else
+                     pragma Assert (Nkind (Lhs) = N_Indexed_Component);
+                     return True;
+                  end if;
+               end;
+            end Omit_Range_Check_For_Streaming;
+
+         begin
+            if not Omit_Range_Check_For_Streaming then
+               Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
+            end if;
+         end;
 
       --  For array types, verify that lengths match. If the right hand side
       --  is a function call that has been inlined, the assignment has been