From: Steve Baird Date: Tue, 11 May 2021 18:43:31 +0000 (-0700) Subject: [Ada] Implement missing constraint checks for default streaming operations X-Git-Tag: basepoints/gcc-13~6234 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=fb632ef567d8af061e7f73fcf7bb2b75796cdfb4;p=thirdparty%2Fgcc.git [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. --- diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 067e7ede7046..e33a36ef8a3a 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 ccd5a3728c7e..fbb6904b2c58 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