This flag is set on N_Subtype_Declaration nodes and on all expression
nodes to prevent checks from being generated multiple times for the
same node. It was probably deemed necessary because semantic analysis
and expansion for Ch3 tread on each other's toes and can generate the
same check twice, in particular through Process_Range_Expr_In_Decl.
However its usage is awkward and, in particular, it is also set on
N_Subtype_Declaration nodes, which causes Analyze_Subtype_Declaration
to do a little dance around it so as to be able to generate the checks
required for declarations of array subtypes with multiple dimensions.
It turns out that preventing the front-end from generating or inserting
the duplicate checks beforehand is straightforward and requires only a
couple of adjustments in Exp_Ch3 and Sem_Ch3. The patch does that and
also adds an assertion that a duplicate check is never avoided anymore
by means of the flag; it's the last step before the complete removal.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-05 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* atree.adb (New_Copy): Clear Has_Dynamic_Range_Check on
subexpression nodes.
* checks.adb (Append_Range_Checks): Assert that the node
doesn't have the Has_Dynamic_Range_Check flag set.
(Insert_Range_Checks): Likewise.
* exp_ch3.adb (Expand_N_Subtype_Indication): Do not apply
range checks for a full type or object declaration.
* sem_ch3.ads: Move with and use clauses for Nlists to...
(Process_Range_Expr_In_Decl): Change default to No_List for
the Check_List parameter.
* sem_ch3.adb: ...here.
(Process_Range_Expr_In_Decl): Likewise. When the insertion
node is a declaration, only insert on the list if is present
when the declaration involves discriminants, and only insert
on the node when there is no list otherwise.--- gcc/ada/atree.adb
+++ gcc/ada/atree.adb
@@ -1659,6 +1659,12 @@ package body Atree is
Nodes.Table (New_Id).Rewrite_Ins := False;
pragma Debug (New_Node_Debugging_Output (New_Id));
+ -- Clear Has_Dynamic_Range_Check since it doesn't apply anymore
+
+ if Nkind (Source) in N_Subexpr then
+ Set_Has_Dynamic_Range_Check (New_Id, False);
+ end if;
+
-- Clear Is_Overloaded since we cannot have semantic interpretations
-- of this new node.
--- gcc/ada/checks.adb
+++ gcc/ada/checks.adb
@@ -514,7 +514,11 @@ package body Checks is
if Nkind (Checks (J)) = N_Raise_Constraint_Error
and then Present (Condition (Checks (J)))
then
- if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
+ if Has_Dynamic_Range_Check (Internal_Flag_Node) then
+ pragma Assert (False);
+ null;
+
+ else
Append_To (Stmts, Checks (J));
Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
end if;
@@ -7470,7 +7474,11 @@ package body Checks is
if Nkind (Checks (J)) = N_Raise_Constraint_Error
and then Present (Condition (Checks (J)))
then
- if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
+ if Has_Dynamic_Range_Check (Internal_Flag_Node) then
+ pragma Assert (False);
+ null;
+
+ else
Check_Node := Checks (J);
Mark_Rewrite_Insertion (Check_Node);
--- gcc/ada/exp_ch3.adb
+++ gcc/ada/exp_ch3.adb
@@ -7294,10 +7294,7 @@ package body Exp_Ch3 is
-- Expand_N_Subtype_Indication --
---------------------------------
- -- Add a check on the range of the subtype. The static case is partially
- -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
- -- to check here for the static case in order to avoid generating
- -- extraneous expanded code. Also deal with validity checking.
+ -- Add a check on the range of the subtype and deal with validity checking
procedure Expand_N_Subtype_Indication (N : Node_Id) is
Ran : constant Node_Id := Range_Expression (Constraint (N));
@@ -7308,7 +7305,12 @@ package body Exp_Ch3 is
Validity_Check_Range (Range_Expression (Constraint (N)));
end if;
- if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
+ -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
+
+ if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice)
+ and then Nkind (Parent (Parent (N))) /= N_Full_Type_Declaration
+ and then Nkind (Parent (Parent (N))) /= N_Object_Declaration
+ then
Apply_Range_Check (Ran, Typ);
end if;
end Expand_N_Subtype_Indication;
--- gcc/ada/sem_ch3.adb
+++ gcc/ada/sem_ch3.adb
@@ -45,6 +45,7 @@ with Layout; use Layout;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
+with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
@@ -21214,7 +21215,7 @@ package body Sem_Ch3 is
(R : Node_Id;
T : Entity_Id;
Subtyp : Entity_Id := Empty;
- Check_List : List_Id := Empty_List;
+ Check_List : List_Id := No_List;
R_Check_Off : Boolean := False;
In_Iter_Schm : Boolean := False)
is
@@ -21435,9 +21436,13 @@ package body Sem_Ch3 is
end if;
end;
- -- Insertion before a declaration. If the declaration
- -- includes discriminants, the list of applicable checks
- -- is given by the caller.
+ -- Case of declarations. If the declaration is for a type
+ -- and involves discriminants, the checks are premature at
+ -- the declaration point and need to wait for the expansion
+ -- of the initialization procedure, which will pass in the
+ -- list to put them on; otherwise, the checks are done at
+ -- the declaration point and there is no need to do them
+ -- again in the initialization procedure.
elsif Nkind (Insert_Node) in N_Declaration then
Def_Id := Defining_Identifier (Insert_Node);
@@ -21448,19 +21453,22 @@ package body Sem_Ch3 is
(Ekind (Def_Id) = E_Protected_Type
and then Has_Discriminants (Def_Id))
then
- Append_Range_Checks
- (R_Checks,
- Check_List, Def_Id, Sloc (Insert_Node), R);
+ if Present (Check_List) then
+ Append_Range_Checks
+ (R_Checks,
+ Check_List, Def_Id, Sloc (Insert_Node), R);
+ end if;
else
- Insert_Range_Checks
- (R_Checks,
- Insert_Node, Def_Id, Sloc (Insert_Node), R);
-
+ if No (Check_List) then
+ Insert_Range_Checks
+ (R_Checks,
+ Insert_Node, Def_Id, Sloc (Insert_Node), R);
+ end if;
end if;
- -- Insertion before a statement. Range appears in the
- -- context of a quantified expression. Insertion will
+ -- Case of statements. Drop the checks, as the range appears
+ -- in the context of a quantified expression. Insertion will
-- take place when expression is expanded.
else
--- gcc/ada/sem_ch3.ads
+++ gcc/ada/sem_ch3.ads
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Nlists; use Nlists;
with Types; use Types;
package Sem_Ch3 is
@@ -265,7 +264,7 @@ package Sem_Ch3 is
(R : Node_Id;
T : Entity_Id;
Subtyp : Entity_Id := Empty;
- Check_List : List_Id := Empty_List;
+ Check_List : List_Id := No_List;
R_Check_Off : Boolean := False;
In_Iter_Schm : Boolean := False);
-- Process a range expression that appears in a declaration context. The
