This is a preliminary internal change for setting Do_Discriminant_Check
flags properly in the tree. No functional effect, so no test needed
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-01-21 Robert Dewar <de...@adacore.com>
* sinfo.ads, sinfo.adb: Change Do_Discriminant_Check to use new Flag1.
Add this flag to type conversion nodes and assignment nodes.
* treepr.adb: Deal properly with Flag 1,2,3.
* treeprs.adt: Minor comment update.
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 206804)
+++ sinfo.adb (working copy)
@@ -930,8 +930,10 @@
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Selected_Component);
- return Flag13 (N);
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Selected_Component
+ or else NT (N).Nkind = N_Type_Conversion);
+ return Flag1 (N);
end Do_Discriminant_Check;
function Do_Division_Check
@@ -4078,8 +4080,10 @@
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Selected_Component);
- Set_Flag13 (N, Val);
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Selected_Component
+ or else NT (N).Nkind = N_Type_Conversion);
+ Set_Flag1 (N, Val);
end Set_Do_Discriminant_Check;
procedure Set_Do_Division_Check
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 206813)
+++ sinfo.ads (working copy)
@@ -638,9 +638,7 @@
-- A flag set in the N_Subprogram_Body node for a subprogram body which
-- is acting as its own spec, except in the case of a library level
-- subprogram, in which case the flag is set on the parent compilation
- -- unit node instead (see further description in spec of Lib package).
- -- ??? Above note about Lib is dubious since lib.ads does not mention
- -- Acts_As_Spec at all.
+ -- unit node instead.
-- Actual_Designated_Subtype (Node4-Sem)
-- Present in N_Free_Statement and N_Explicit_Dereference nodes. If gigi
@@ -902,14 +900,16 @@
-- that an accessibility check is required for the parameter. It is
-- not yet decided who takes care of this check (TBD ???).
- -- Do_Discriminant_Check (Flag13-Sem)
+ -- Do_Discriminant_Check (Flag1-Sem)
-- This flag is set on N_Selected_Component nodes to indicate that a
-- discriminant check is required using the discriminant check routine
-- associated with the selector. The actual check is generated by the
-- expander when processing selected components. In the case of
-- Unchecked_Union, the flag is also set, but no discriminant check
-- routine is associated with the selector, and the expander does not
- -- generate a check.
+ -- generate a check. This flag is also present in assignment statements
+ -- (and set if the assignment requires a discriminant check), and in type
+ -- conversion nodes (and set if the conversion requires a check).
-- Do_Division_Check (Flag13-Sem)
-- This flag is set on a division operator (/ mod rem) to indicate
@@ -1682,11 +1682,10 @@
-- is undefined and should not be read).
-- No_Ctrl_Actions (Flag7-Sem)
- -- Present in N_Assignment_Statement to indicate that no finalize nor
- -- adjust should take place on this assignment even though the rhs is
+ -- Present in N_Assignment_Statement to indicate that no Finalize nor
+ -- Adjust should take place on this assignment even though the RHS is
-- controlled. This is used in init procs and aggregate expansions where
- -- the generated assignments are more initialisations than real
- -- assignments.
+ -- the generated assignments are initializations, not real assignments.
-- No_Elaboration_Check (Flag14-Sem)
-- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates
@@ -3439,7 +3438,7 @@
-- Prefix (Node3)
-- Selector_Name (Node2)
-- Associated_Node (Node4-Sem)
- -- Do_Discriminant_Check (Flag13-Sem)
+ -- Do_Discriminant_Check (Flag1-Sem)
-- Is_In_Discriminant_Check (Flag11-Sem)
-- Is_Prefixed_Call (Flag17-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
@@ -4197,12 +4196,13 @@
-- Sloc points to first token of subtype mark
-- Subtype_Mark (Node4)
-- Expression (Node3)
+ -- Do_Discriminant_Check (Flag1-Sem)
+ -- Do_Length_Check (Flag4-Sem)
+ -- Float_Truncate (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
- -- Do_Length_Check (Flag4-Sem)
+ -- Conversion_OK (Flag14-Sem)
-- Do_Overflow_Check (Flag17-Sem)
- -- Float_Truncate (Flag11-Sem)
-- Rounded_Result (Flag18-Sem)
- -- Conversion_OK (Flag14-Sem)
-- plus fields for expression
-- Note: if a range check is required, then the Do_Range_Check flag
@@ -4360,6 +4360,7 @@
-- Sloc points to :=
-- Name (Node2)
-- Expression (Node3)
+ -- Do_Discriminant_Check (Flag1-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- Do_Length_Check (Flag4-Sem)
-- Forwards_OK (Flag5-Sem)
@@ -8680,7 +8681,7 @@
(N : Node_Id) return Boolean; -- Flag13
function Do_Discriminant_Check
- (N : Node_Id) return Boolean; -- Flag13
+ (N : Node_Id) return Boolean; -- Flag1
function Do_Division_Check
(N : Node_Id) return Boolean; -- Flag13
@@ -9682,7 +9683,7 @@
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Do_Discriminant_Check
- (N : Node_Id; Val : Boolean := True); -- Flag13
+ (N : Node_Id; Val : Boolean := True); -- Flag1
procedure Set_Do_Division_Check
(N : Node_Id; Val : Boolean := True); -- Flag13
Index: treepr.adb
===================================================================
--- treepr.adb (revision 206804)
+++ treepr.adb (working copy)
@@ -1184,10 +1184,9 @@
when F_Field5 =>
Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
- -- Flag3 is obsolete, so this probably gets removed ???
-
- when F_Flag3 => Field_To_Be_Printed := Has_Aspects (N);
-
+ when F_Flag1 => Field_To_Be_Printed := Flag1 (N);
+ when F_Flag2 => Field_To_Be_Printed := Flag2 (N);
+ when F_Flag3 => Field_To_Be_Printed := Flag3 (N);
when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
@@ -1203,11 +1202,6 @@
when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
-
- -- Flag1,2 are no longer used
-
- when F_Flag1 => raise Program_Error;
- when F_Flag2 => raise Program_Error;
end case;
-- Print field if it is to be printed
@@ -1233,14 +1227,15 @@
-- Special case End_Span = Uint5
when F_Field5 =>
- if Nkind (N) = N_Case_Statement
- or else Nkind (N) = N_If_Statement
- then
+ if Nkind_In (N, N_Case_Statement, N_If_Statement) then
Print_End_Span (N);
else
Print_Field (Field5 (N), Fmt);
end if;
+ when F_Flag1 => Print_Flag (Flag1 (N));
+ when F_Flag2 => Print_Flag (Flag2 (N));
+ when F_Flag3 => Print_Flag (Flag3 (N));
when F_Flag4 => Print_Flag (Flag4 (N));
when F_Flag5 => Print_Flag (Flag5 (N));
when F_Flag6 => Print_Flag (Flag6 (N));
@@ -1256,15 +1251,6 @@
when F_Flag16 => Print_Flag (Flag16 (N));
when F_Flag17 => Print_Flag (Flag17 (N));
when F_Flag18 => Print_Flag (Flag18 (N));
-
- -- Flag1,2 are no longer used
-
- when F_Flag1 => raise Program_Error;
- when F_Flag2 => raise Program_Error;
-
- -- Not clear why we need the following ???
-
- when F_Flag3 => Print_Flag (Has_Aspects (N));
end case;
Print_Eol;
Index: treeprs.adt
===================================================================
--- treeprs.adt (revision 206804)
+++ treeprs.adt (working copy)
@@ -6,7 +6,7 @@
-- --
-- T e m p l a t e --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -50,6 +50,9 @@
-- could never occur in a field name, so they also mark the end of the
-- previous name.
+ -- Note the following definitions do not include Flag0. This will have to
+ -- be addressed if we ever need to use Flag0 (it's not currently used).
+
subtype Fchar is Character range '#' .. '9';
F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#)
