public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-2079] [Ada] Implement missing constraint checks for default streaming operations
@ 2021-07-06 14:50 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-07-06 14:50 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:fb632ef567d8af061e7f73fcf7bb2b75796cdfb4
commit r12-2079-gfb632ef567d8af061e7f73fcf7bb2b75796cdfb4
Author: Steve Baird <baird@adacore.com>
Date: Tue May 11 11:43:31 2021 -0700
[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:
---
gcc/ada/exp_attr.adb | 26 +++++-----------
gcc/ada/sem_ch5.adb | 88 +++++++++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 95 insertions(+), 19 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 067e7ede704..e33a36ef8a3 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 ccd5a3728c7..fbb6904b2c5 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
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-07-06 14:50 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-07-06 14:50 [gcc r12-2079] [Ada] Implement missing constraint checks for default streaming operations Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).