For a default (as opposed to user-defined) Read operation of a composite
type with a scalar component, the RM says that in some cases the
constraint check that is normally performed upon return from a
procedure with an out-mode scalar parameter (in particular, the call
to the procedure Scalar_Component_Type'Read) is omitted. The
compiler was improperly omitting these checks in additional cases.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
--- 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
--- 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
