This is a fairly major reorganization of the way that choices are
handled. The processing of such choices in variants was completely
wrong before, since we attempted to do it when the variant is first
seen, but the statically predicated subtype may not be frozen yet,
so this processing has to be delayed to the freeze point.
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-10 Robert Dewar <de...@adacore.com>
* exp_ch3.adb (Expand_N_Variant_Part): Don't expand choices, too early
* exp_ch5.adb (Expand_N_Case_Statement): Use new Has_SP_Choice
flag to avoid expanding choices when not necessary.
* exp_util.adb: Minor reformatting
* freeze.adb (Freeze_Record_Type): Redo expansion of variants
* sem_aggr.adb: Minor reformatting
* sem_case.ads, sem_case.adb: Major rewrite, separating Analysis and
Checking of choices.
* sem_ch3.adb (Analyze_Variant_Part): Rewrite to call new
Analyze_Choices.
* sem_ch4.adb (Analyze_Case_Expression): Call Analyze_Choices
and Check_Choices
* sem_ch5.adb (Analyze_Case_Statement): Call Analyze_Choices
and Check_Choices
* sem_util.adb: Minor reformatting
* sinfo.ads, sinfo.adb (Has_SP_Choice): New flag.
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 203342)
+++ sem_aggr.adb (working copy)
@@ -3416,6 +3416,7 @@
begin
-- A record aggregate is restricted in SPARK:
+
-- Each named association can have only a single choice.
-- OTHERS cannot be used.
-- Positional and named associations cannot be mixed.
@@ -3758,6 +3759,8 @@
end loop;
end Find_Private_Ancestor;
+ -- Start of processing for Step_5
+
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
@@ -3822,11 +3825,12 @@
if Nkind (Dnode) = N_Full_Type_Declaration then
Record_Def := Type_Definition (Dnode);
- Gather_Components (Base_Type (Typ),
- Component_List (Record_Def),
- Governed_By => New_Assoc_List,
- Into => Components,
- Report_Errors => Errors_Found);
+ Gather_Components
+ (Base_Type (Typ),
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
end if;
end if;
@@ -3915,19 +3919,20 @@
null;
elsif not Has_Unknown_Discriminants (Typ) then
- Gather_Components (Base_Type (Typ),
- Component_List (Record_Def),
- Governed_By => New_Assoc_List,
- Into => Components,
- Report_Errors => Errors_Found);
+ Gather_Components
+ (Base_Type (Typ),
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
else
Gather_Components
(Base_Type (Underlying_Record_View (Typ)),
- Component_List (Record_Def),
- Governed_By => New_Assoc_List,
- Into => Components,
- Report_Errors => Errors_Found);
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
end if;
end if;
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 203350)
+++ exp_ch5.adb (working copy)
@@ -2627,7 +2627,11 @@
Alt := First_Non_Pragma (Alternatives (N));
while Present (Alt) loop
Process_Statements_For_Controlled_Objects (Alt);
- Expand_Static_Predicates_In_Choices (Alt);
+
+ if Has_SP_Choice (Alt) then
+ Expand_Static_Predicates_In_Choices (Alt);
+ end if;
+
Next_Non_Pragma (Alt);
end loop;
end;
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 203350)
+++ sem_ch3.adb (working copy)
@@ -4590,61 +4590,32 @@
--------------------------
procedure Analyze_Variant_Part (N : Node_Id) is
+ Discr_Name : Node_Id;
+ Discr_Type : Entity_Id;
- procedure Non_Static_Choice_Error (Choice : Node_Id);
- -- Error routine invoked by the generic instantiation below when the
- -- variant part has a non static choice.
+ procedure Process_Variant (A : Node_Id);
+ -- Analyze declarations for a single variant
- procedure Process_Declarations (Variant : Node_Id);
- -- Analyzes all the declarations associated with a Variant. Needed by
- -- the generic instantiation below.
+ package Analyze_Variant_Choices is
+ new Generic_Analyze_Choices (Process_Variant);
+ use Analyze_Variant_Choices;
- package Variant_Choices_Processing is new
- Generic_Choices_Processing
- (Get_Alternatives => Variants,
- Process_Empty_Choice => No_OP,
- Process_Non_Static_Choice => Non_Static_Choice_Error,
- Process_Associated_Node => Process_Declarations);
- use Variant_Choices_Processing;
- -- Instantiation of the generic choice processing package
+ ---------------------
+ -- Process_Variant --
+ ---------------------
- -----------------------------
- -- Non_Static_Choice_Error --
- -----------------------------
-
- procedure Non_Static_Choice_Error (Choice : Node_Id) is
+ procedure Process_Variant (A : Node_Id) is
+ CL : constant Node_Id := Component_List (A);
begin
- Flag_Non_Static_Expr
- ("choice given in variant part is not static!", Choice);
- end Non_Static_Choice_Error;
+ if not Null_Present (CL) then
+ Analyze_Declarations (Component_Items (CL));
- --------------------------
- -- Process_Declarations --
- --------------------------
-
- procedure Process_Declarations (Variant : Node_Id) is
- begin
- if not Null_Present (Component_List (Variant)) then
- Analyze_Declarations (Component_Items (Component_List (Variant)));
-
- if Present (Variant_Part (Component_List (Variant))) then
- Analyze (Variant_Part (Component_List (Variant)));
+ if Present (Variant_Part (CL)) then
+ Analyze (Variant_Part (CL));
end if;
end if;
- end Process_Declarations;
+ end Process_Variant;
- -- Local Variables
-
- Discr_Name : Node_Id;
- Discr_Type : Entity_Id;
-
- Dont_Care : Boolean;
- Others_Present : Boolean := False;
-
- pragma Warnings (Off, Dont_Care);
- pragma Warnings (Off, Others_Present);
- -- We don't care about the assigned values of any of these
-
-- Start of processing for Analyze_Variant_Part
begin
@@ -4672,9 +4643,18 @@
return;
end if;
- -- Call the instantiated Analyze_Choices which does the rest of the work
+ -- Now analyze the choices, which also analyzes the declarations that
+ -- are associated with each choice.
- Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present);
+ Analyze_Choices (Variants (N), Discr_Type);
+
+ -- Note: we used to instantiate and call Check_Choices here to check
+ -- that the choices covered the discriminant, but it's too early to do
+ -- that because of statically predicated subtypes, whose analysis may
+ -- be deferred to their freeze point which may be as late as the freeze
+ -- point of the containing record. So this call is now to be found in
+ -- Freeze_Record_Declaration.
+
end Analyze_Variant_Part;
----------------------------
Index: sem_ch5.adb
===================================================================
--- sem_ch5.adb (revision 203350)
+++ sem_ch5.adb (working copy)
@@ -1018,12 +1018,12 @@
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Last_Choice : Nat;
- Dont_Care : Boolean;
+
Others_Present : Boolean;
+ -- Indicates if Others was present
pragma Warnings (Off, Last_Choice);
- pragma Warnings (Off, Dont_Care);
- -- Don't care about assigned values
+ -- Don't care about assigned value
Statements_Analyzed : Boolean := False;
-- Set True if at least some statement sequences get analyzed. If False
@@ -1039,16 +1039,21 @@
-- case statement has a non static choice.
procedure Process_Statements (Alternative : Node_Id);
- -- Analyzes all the statements associated with a case alternative.
- -- Needed by the generic instantiation below.
+ -- Analyzes the statements associated with a case alternative. Needed
+ -- by instantiation below.
- package Case_Choices_Processing is new
- Generic_Choices_Processing
- (Get_Alternatives => Alternatives,
- Process_Empty_Choice => No_OP,
+ package Analyze_Case_Choices is new
+ Generic_Analyze_Choices
+ (Process_Associated_Node => Process_Statements);
+ use Analyze_Case_Choices;
+ -- Instantiation of the generic choice analysis package
+
+ package Check_Case_Choices is new
+ Generic_Check_Choices
+ (Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
- Process_Associated_Node => Process_Statements);
- use Case_Choices_Processing;
+ Process_Associated_Node => No_Op);
+ use Check_Case_Choices;
-- Instantiation of the generic choice processing package
-----------------------------
@@ -1154,9 +1159,7 @@
-- If error already reported by Resolve, nothing more to do
- if Exp_Btype = Any_Discrete
- or else Exp_Btype = Any_Type
- then
+ if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
return;
elsif Exp_Btype = Any_Character then
@@ -1185,12 +1188,12 @@
Exp_Type := Exp_Btype;
end if;
- -- Call instantiated Analyze_Choices which does the rest of the work
+ -- Call instantiated procedures to analyzwe and check discrete choices
- Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
+ Analyze_Choices (Alternatives (N), Exp_Type);
+ Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
- -- A case statement with a single OTHERS alternative is not allowed
- -- in SPARK.
+ -- Case statement with single OTHERS alternative not allowed in SPARK
if Others_Present and then List_Length (Alternatives (N)) = 1 then
Check_SPARK_Restriction
@@ -1213,6 +1216,12 @@
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
end if;
+ -- If the expander is active it will detect the case of a statically
+ -- determined single alternative and remove warnings for the case, but
+ -- if we are not doing expansion, that circuit won't be active. Here we
+ -- duplicate the effect of removing warnings in the same way, so that
+ -- we will get the same set of warnings in -gnatc mode.
+
if not Expander_Active
and then Compile_Time_Known_Value (Expression (N))
and then Serious_Errors_Detected = 0
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 203350)
+++ exp_util.adb (working copy)
@@ -1991,7 +1991,7 @@
end if;
-- Change Sloc to referencing choice (rather than the Sloc of
- -- the predicate declarationo element itself).
+ -- the predicate declaration element itself).
Set_Sloc (C, Sloc (Choice));
Insert_Before (Choice, C);
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 203355)
+++ sinfo.adb (working copy)
@@ -1552,6 +1552,16 @@
return Flag13 (N);
end Has_Self_Reference;
+ function Has_SP_Choice
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Expression_Alternative
+ or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Variant);
+ return Flag15 (N);
+ end Has_SP_Choice;
+
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean is
begin
@@ -4680,6 +4690,16 @@
Set_Flag13 (N, Val);
end Set_Has_Self_Reference;
+ procedure Set_Has_SP_Choice
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Expression_Alternative
+ or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Variant);
+ Set_Flag15 (N, Val);
+ end Set_Has_SP_Choice;
+
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True) is
begin
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 203355)
+++ sinfo.ads (working copy)
@@ -1243,6 +1243,12 @@
-- enclosing type. Such a self-reference can only appear in default-
-- initialized aggregate for a record type.
+ -- Has_SP_Choice (Flag15-Sem)
+ -- Present in all nodes containing a Discrete_Choices field (N_Variant,
+ -- N_Case_Expression_Alternative, N_Case_Statement_Alternative). Set to
+ -- True if the Discrete_Choices list has at least one occurrence of a
+ -- statically predicated subtype.
+
-- Has_Storage_Size_Pragma (Flag5-Sem)
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Storage_Size pragma.
@@ -3061,8 +3067,7 @@
-- VARIANT_PART ::=
-- case discriminant_DIRECT_NAME is
- -- VARIANT
- -- {VARIANT}
+ -- VARIANT {VARIANT}
-- end case;
-- Note: the variants list can contain pragmas as well as variants.
@@ -3088,12 +3093,14 @@
-- Enclosing_Variant (Node2-Sem)
-- Present_Expr (Uint3-Sem)
-- Dcheck_Function (Node5-Sem)
+ -- Has_SP_Choice (Flag15-Sem)
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
-- predicated subtypes. Such entries are always expanded out to the list
-- of equivalent values or ranges. The ASIS tree generated in -gnatct
- -- mode does not have this expansion, and has the original choices.
+ -- mode also has this expansion, but done with a proper Rewrite call on
+ -- the N_Variant node so that ASIS can properly retrieve the original.
---------------------------------
-- 3.8.1 Discrete Choice List --
@@ -4078,12 +4085,16 @@
-- Actions (List1)
-- Discrete_Choices (List4)
-- Expression (Node3)
+ -- Has_SP_Choice (Flag15-Sem)
-- Note: The Actions field temporarily holds any actions associated with
-- evaluation of the Expression. During expansion of the case expression
-- these actions are wrapped into an N_Expressions_With_Actions node
-- replacing the original expression.
+ -- Note: this node never appears in the tree passed to the back end,
+ -- since the expander converts case expressions into case statements.
+
---------------------------------
-- 4.5.9 Quantified Expression --
---------------------------------
@@ -4392,6 +4403,7 @@
-- Sloc points to WHEN
-- Discrete_Choices (List4)
-- Statements (List3)
+ -- Has_SP_Choice (Flag15-Sem)
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
@@ -8773,6 +8785,9 @@
function Has_Self_Reference
(N : Node_Id) return Boolean; -- Flag13
+ function Has_SP_Choice
+ (N : Node_Id) return Boolean; -- Flag15
+
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean; -- Flag5
@@ -9769,6 +9784,9 @@
procedure Set_Has_Self_Reference
(N : Node_Id; Val : Boolean := True); -- Flag13
+ procedure Set_Has_SP_Choice
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag5
@@ -12195,6 +12213,7 @@
pragma Inline (Has_Init_Expression);
pragma Inline (Has_Local_Raise);
pragma Inline (Has_Self_Reference);
+ pragma Inline (Has_SP_Choice);
pragma Inline (Has_No_Elaboration_Code);
pragma Inline (Has_Pragma_Suppress_All);
pragma Inline (Has_Private_View);
@@ -12528,6 +12547,7 @@
pragma Inline (Set_Has_Private_View);
pragma Inline (Set_Has_Relative_Deadline_Pragma);
pragma Inline (Set_Has_Self_Reference);
+ pragma Inline (Set_Has_SP_Choice);
pragma Inline (Set_Has_Storage_Size_Pragma);
pragma Inline (Set_Has_Wide_Character);
pragma Inline (Set_Has_Wide_Wide_Character);
Index: freeze.adb
===================================================================
--- freeze.adb (revision 203349)
+++ freeze.adb (working copy)
@@ -46,6 +46,7 @@
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
@@ -846,8 +847,9 @@
and then Nkind (Type_Definition (Parent (T))) =
N_Record_Definition
and then not Null_Present (Type_Definition (Parent (T)))
- and then Present (Variant_Part
- (Component_List (Type_Definition (Parent (T)))))
+ and then
+ Present (Variant_Part
+ (Component_List (Type_Definition (Parent (T)))))
then
-- If variant part is present, and type is unconstrained,
-- then we must have defaulted discriminants, or a size
@@ -2272,7 +2274,7 @@
begin
if Present (Alloc) then
- -- If component is pointer to a classwide type, freeze
+ -- If component is pointer to a class-wide type, freeze
-- the specific type in the expression being allocated.
-- The expression may be a subtype indication, in which
-- case freeze the subtype mark.
@@ -2367,8 +2369,9 @@
if Present (ADC) and then Base_Type (Rec) = Rec then
if not (Placed_Component or else Is_Packed (Rec)) then
- Error_Msg_N ("??bit order specification has no effect", ADC);
Error_Msg_N
+ ("??bit order specification has no effect", ADC);
+ Error_Msg_N
("\??since no component clauses were specified", ADC);
-- Here is where we do the processing for reversed bit order
@@ -2443,15 +2446,13 @@
-- remote type here since that is what we are semantically freezing.
-- This prevents the freeze node for that type in an inner scope.
- -- Also, Check for controlled components and unchecked unions.
- -- Finally, enforce the restriction that access attributes with a
- -- current instance prefix can only apply to limited types.
-
if Ekind (Rec) = E_Record_Type then
if Present (Corresponding_Remote_Type (Rec)) then
Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result);
end if;
+ -- Check for controlled components and unchecked unions.
+
Comp := First_Component (Rec);
while Present (Comp) loop
@@ -2459,18 +2460,18 @@
-- equivalent type. See Make_CW_Equivalent_Type.
if not Is_Class_Wide_Equivalent_Type (Rec)
- and then (Has_Controlled_Component (Etype (Comp))
- or else (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Etype (Comp)))
- or else (Is_Protected_Type (Etype (Comp))
- and then
- Present
- (Corresponding_Record_Type
- (Etype (Comp)))
- and then
- Has_Controlled_Component
- (Corresponding_Record_Type
- (Etype (Comp)))))
+ and then
+ (Has_Controlled_Component (Etype (Comp))
+ or else
+ (Chars (Comp) /= Name_uParent
+ and then Is_Controlled (Etype (Comp)))
+ or else
+ (Is_Protected_Type (Etype (Comp))
+ and then
+ Present (Corresponding_Record_Type (Etype (Comp)))
+ and then
+ Has_Controlled_Component
+ (Corresponding_Record_Type (Etype (Comp)))))
then
Set_Has_Controlled_Component (Rec);
end if;
@@ -2490,11 +2491,17 @@
end loop;
end if;
+ -- Enforce the restriction that access attributes with a current
+ -- instance prefix can only apply to limited types. This comment
+ -- is floating here, but does not seem to belong here???
+
+ -- Set component alignment if not otherwise already set
+
Set_Component_Alignment_If_Not_Set (Rec);
-- For first subtypes, check if there are any fixed-point fields with
-- component clauses, where we must check the size. This is not done
- -- till the freeze point, since for fixed-point types, we do not know
+ -- till the freeze point since for fixed-point types, we do not know
-- the size until the type is frozen. Similar processing applies to
-- bit packed arrays.
@@ -2613,6 +2620,142 @@
end;
end if;
end if;
+
+ -- All done if not a full record definition
+
+ if Ekind (Rec) /= E_Record_Type then
+ return;
+ end if;
+
+ -- Finallly we need to check the variant part to make sure that
+ -- the set of choices for each variant covers the corresponding
+ -- discriminant. This check has to be delayed to the freeze point
+ -- because we may have statically predicated subtypes, whose choice
+ -- list is not known till the subtype is frozen.
+
+ Check_Variant_Part : declare
+ D : constant Node_Id := Declaration_Node (Rec);
+ T : Node_Id;
+ C : Node_Id;
+ V : Node_Id;
+
+ Others_Present : Boolean;
+ pragma Warnings (Off, Others_Present);
+ -- Indicates others present, not used in this case
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id);
+ -- Error routine invoked by the generic instantiation below when
+ -- the variant part has a non static choice.
+
+ procedure Process_Declarations (Variant : Node_Id);
+ -- Processes declarations associated with a variant. We analyzed
+ -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
+ -- but we still need the recursive call to Check_Choices for any
+ -- nested variant to get its choices properly processed. This is
+ -- also where we expand out the choices if expansion is active.
+
+ package Variant_Choices_Processing is new
+ Generic_Check_Choices
+ (Process_Empty_Choice => No_OP,
+ Process_Non_Static_Choice => Non_Static_Choice_Error,
+ Process_Associated_Node => Process_Declarations);
+ use Variant_Choices_Processing;
+
+ -----------------------------
+ -- Non_Static_Choice_Error --
+ -----------------------------
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id) is
+ begin
+ Flag_Non_Static_Expr
+ ("choice given in variant part is not static!", Choice);
+ end Non_Static_Choice_Error;
+
+ --------------------------
+ -- Process_Declarations --
+ --------------------------
+
+ procedure Process_Declarations (Variant : Node_Id) is
+ CL : constant Node_Id := Component_List (Variant);
+ VP : Node_Id;
+
+ begin
+ -- Check for static predicate present in this variant
+
+ if Has_SP_Choice (Variant) then
+
+ -- Here we expand. You might expect to find this call in
+ -- Expand_N_Variant_Part, but that is called when we first
+ -- see the variant part, and we cannot do this expansion
+ -- earlier than the freeze point, since for statically
+ -- predicated subtypes, the predicate is not known till
+ -- the freeze point.
+
+ -- Furthermore, we do this expansion even if the expander
+ -- is not active, because other semantic processing, e.g.
+ -- for aggregates, requires the expanded list of choices.
+
+ -- If the expander is not active, then we can't just clobber
+ -- the list since it would invalidate the ASIS -gnatct tree.
+ -- So we have to rewrite the variant part with a Rewrite
+ -- call that replaces it with a copy and clobber the copy.
+
+ if not Expander_Active then
+ declare
+ NewV : constant Node_Id := New_Copy (Variant);
+ begin
+ Set_Discrete_Choices
+ (NewV, New_Copy_List (Discrete_Choices (Variant)));
+ Rewrite (Variant, NewV);
+ end;
+ end if;
+
+ Expand_Static_Predicates_In_Choices (Variant);
+ end if;
+
+ -- We don't need to worry about the declarations in the variant
+ -- (since they were analyzed by Analyze_Choices when we first
+ -- encountered the variant), but we do need to take care of
+ -- expansion of any nested variants.
+
+ if not Null_Present (CL) then
+ VP := Variant_Part (CL);
+
+ if Present (VP) then
+ Check_Choices
+ (VP, Variants (VP), Etype (Name (VP)), Others_Present);
+ end if;
+ end if;
+ end Process_Declarations;
+
+ -- Start of processing for Check_Variant_Part
+
+ begin
+ -- Find component list
+
+ C := Empty;
+
+ if Nkind (D) = N_Full_Type_Declaration then
+ T := Type_Definition (D);
+
+ if Nkind (T) = N_Record_Definition then
+ C := Component_List (T);
+
+ elsif Nkind (T) = N_Derived_Type_Definition
+ and then Present (Record_Extension_Part (T))
+ then
+ C := Component_List (Record_Extension_Part (T));
+ end if;
+ end if;
+
+ -- If we have a variant part, check choices
+
+ if Present (C) and then Present (Variant_Part (C)) then
+ V := Variant_Part (C);
+ Check_Choices
+ (V, Variants (V), Etype (Name (V)), Others_Present);
+ end if;
+ end Check_Variant_Part;
end Freeze_Record_Type;
-- Start of processing for Freeze_Entity
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 203349)
+++ sem_util.adb (working copy)
@@ -5184,9 +5184,9 @@
Discrim := First (Choices (Assoc));
exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
or else (Present (Corresponding_Discriminant (Entity (Discrim)))
- and then
- Chars (Corresponding_Discriminant (Entity (Discrim)))
- = Chars (Discrim_Name))
+ and then
+ Chars (Corresponding_Discriminant (Entity (Discrim))) =
+ Chars (Discrim_Name))
or else Chars (Original_Record_Component (Entity (Discrim)))
= Chars (Discrim_Name);
@@ -5274,7 +5274,6 @@
Find_Discrete_Value : while Present (Variant) loop
Discrete_Choice := First (Discrete_Choices (Variant));
while Present (Discrete_Choice) loop
-
exit Find_Discrete_Value when
Nkind (Discrete_Choice) = N_Others_Choice;
@@ -5305,8 +5304,8 @@
-- If we have found the corresponding choice, recursively add its
-- components to the Into list.
- Gather_Components (Empty,
- Component_List (Variant), Governed_By, Into, Report_Errors);
+ Gather_Components
+ (Empty, Component_List (Variant), Governed_By, Into, Report_Errors);
end Gather_Components;
------------------------
@@ -8655,6 +8654,7 @@
return Is_Fully_Initialized_Variant (U);
end if;
end;
+
else
return False;
end if;
Index: sem_case.adb
===================================================================
--- sem_case.adb (revision 203350)
+++ sem_case.adb (working copy)
@@ -26,6 +26,8 @@
with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -65,7 +67,7 @@
-- Local Subprograms --
-----------------------
- procedure Check_Choices
+ procedure Check_Choice_Set
(Choice_Table : in out Choice_Table_Type;
Bounds_Type : Entity_Id;
Subtyp : Entity_Id;
@@ -95,7 +97,7 @@
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id);
- -- The case table is the table generated by a call to Analyze_Choices
+ -- The case table is the table generated by a call to Check_Choices
-- (with just 1 .. Last_Choice entries present). Others_Choice is a
-- pointer to the N_Others_Choice node (this routine is only called if
-- an others choice is present), and Choice_Type is the discrete type
@@ -103,11 +105,11 @@
-- determine the set of values covered by others. This choice list is
-- set in the Others_Discrete_Choices field of the N_Others_Choice node.
- -------------------
- -- Check_Choices --
- -------------------
+ ----------------------
+ -- Check_Choice_Set --
+ ----------------------
- procedure Check_Choices
+ procedure Check_Choice_Set
(Choice_Table : in out Choice_Table_Type;
Bounds_Type : Entity_Id;
Subtyp : Entity_Id;
@@ -598,7 +600,7 @@
Prev_Lo : Uint;
Prev_Hi : Uint;
- -- Start of processing for Check_Choices
+ -- Start of processing for Check_Choice_Set
begin
-- Choice_Table must start at 0 which is an unused location used by the
@@ -714,7 +716,7 @@
end if;
end if;
end if;
- end Check_Choices;
+ end Check_Choice_Set;
------------------
-- Choice_Image --
@@ -799,11 +801,10 @@
Previous_Hi : Uint;
function Build_Choice (Value1, Value2 : Uint) return Node_Id;
- -- Builds a node representing the missing choices given by the
- -- Value1 and Value2. A N_Range node is built if there is more than
- -- one literal value missing. Otherwise a single N_Integer_Literal,
- -- N_Identifier or N_Character_Literal is built depending on what
- -- Choice_Type is.
+ -- Builds a node representing the missing choices given by Value1 and
+ -- Value2. A N_Range node is built if there is more than one literal
+ -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
+ -- or N_Character_Literal is built depending on what Choice_Type is.
function Lit_Of (Value : Uint) return Node_Id;
-- Returns the Node_Id for the enumeration literal corresponding to the
@@ -975,11 +976,11 @@
null;
end No_OP;
- --------------------------------
- -- Generic_Choices_Processing --
- --------------------------------
+ -----------------------------
+ -- Generic_Analyze_Choices --
+ -----------------------------
- package body Generic_Choices_Processing is
+ package body Generic_Analyze_Choices is
-- The following type is used to gather the entries for the choice
-- table, so that we can then allocate the right length.
@@ -992,20 +993,143 @@
Nxt : Link_Ptr;
end record;
- procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
-
---------------------
-- Analyze_Choices --
---------------------
procedure Analyze_Choices
- (N : Node_Id;
- Subtyp : Entity_Id;
- Raises_CE : out Boolean;
- Others_Present : out Boolean)
+ (Alternatives : List_Id;
+ Subtyp : Entity_Id)
is
+ Choice_Type : constant Entity_Id := Base_Type (Subtyp);
+ -- The actual type against which the discrete choices are resolved.
+ -- Note that this type is always the base type not the subtype of the
+ -- ruling expression, index or discriminant.
+
+ Expected_Type : Entity_Id;
+ -- The expected type of each choice. Equal to Choice_Type, except if
+ -- the expression is universal, in which case the choices can be of
+ -- any integer type.
+
+ Alt : Node_Id;
+ -- A case statement alternative or a variant in a record type
+ -- declaration.
+
+ Choice : Node_Id;
+ Kind : Node_Kind;
+ -- The node kind of the current Choice
+
+ begin
+ -- Set Expected type (= choice type except for universal integer,
+ -- where we accept any integer type as a choice).
+
+ if Choice_Type = Universal_Integer then
+ Expected_Type := Any_Integer;
+ else
+ Expected_Type := Choice_Type;
+ end if;
+
+ -- Now loop through the case alternatives or record variants
+
+ Alt := First (Alternatives);
+ while Present (Alt) loop
+
+ -- If pragma, just analyze it
+
+ if Nkind (Alt) = N_Pragma then
+ Analyze (Alt);
+
+ -- Otherwise we have an alternative. In most cases the semantic
+ -- processing leaves the list of choices unchanged
+
+ -- Check each choice against its base type
+
+ else
+ Choice := First (Discrete_Choices (Alt));
+ while Present (Choice) loop
+ Analyze (Choice);
+ Kind := Nkind (Choice);
+
+ -- Choice is a Range
+
+ if Kind = N_Range
+ or else (Kind = N_Attribute_Reference
+ and then Attribute_Name (Choice) = Name_Range)
+ then
+ Resolve (Choice, Expected_Type);
+
+ -- Choice is a subtype name, nothing further to do now
+
+ elsif Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ null;
+
+ -- Choice is a subtype indication
+
+ elsif Kind = N_Subtype_Indication then
+ Resolve_Discrete_Subtype_Indication
+ (Choice, Expected_Type);
+
+ -- Others choice, no analysis needed
+
+ elsif Kind = N_Others_Choice then
+ null;
+
+ -- Only other possibility is an expression
+
+ else
+ Resolve (Choice, Expected_Type);
+ end if;
+
+ -- Move to next choice
+
+ Next (Choice);
+ end loop;
+
+ Process_Associated_Node (Alt);
+ end if;
+
+ Next (Alt);
+ end loop;
+ end Analyze_Choices;
+
+ end Generic_Analyze_Choices;
+
+ ---------------------------
+ -- Generic_Check_Choices --
+ ---------------------------
+
+ package body Generic_Check_Choices is
+
+ -- The following type is used to gather the entries for the choice
+ -- table, so that we can then allocate the right length.
+
+ type Link;
+ type Link_Ptr is access all Link;
+
+ type Link is record
+ Val : Choice_Bounds;
+ Nxt : Link_Ptr;
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
+
+ -------------------
+ -- Check_Choices --
+ -------------------
+
+ procedure Check_Choices
+ (N : Node_Id;
+ Alternatives : List_Id;
+ Subtyp : Entity_Id;
+ Others_Present : out Boolean)
+ is
E : Entity_Id;
+ Raises_CE : Boolean;
+ -- Set True if one of the bounds of a choice raises CE
+
Enode : Node_Id;
-- This is where we post error messages for bounds out of range
@@ -1042,9 +1166,6 @@
Kind : Node_Kind;
-- The node kind of the current Choice
- Delete_Choice : Boolean;
- -- Set to True to delete the current choice
-
Others_Choice : Node_Id := Empty;
-- Remember others choice if it is present (empty otherwise)
@@ -1166,12 +1287,22 @@
Num_Choices := Num_Choices + 1;
end Check;
- -- Start of processing for Analyze_Choices
+ -- Start of processing for Check_Choices
begin
Raises_CE := False;
Others_Present := False;
+ -- If Subtyp is not a discrete type or there was some other error,
+ -- then don't try any semantic checking on the choices since we have
+ -- a complete mess.
+
+ if not Is_Discrete_Type (Subtyp)
+ or else Subtyp = Any_Type
+ then
+ return;
+ end if;
+
-- If Subtyp is not a static subtype Ada 95 requires then we use the
-- bounds of its base type to determine the values covered by the
-- discrete choices.
@@ -1210,7 +1341,7 @@
-- Now loop through the case alternatives or record variants
- Alt := First (Get_Alternatives (N));
+ Alt := First (Alternatives);
while Present (Alt) loop
-- If pragma, just analyze it
@@ -1226,7 +1357,6 @@
else
Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
- Delete_Choice := False;
Analyze (Choice);
Kind := Nkind (Choice);
@@ -1244,9 +1374,19 @@
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
+ -- We have to make sure the subtype is frozen, it must be
+ -- before we can do the following analyses on choices!
+
+ Insert_Actions
+ (N, Freeze_Entity (Entity (Choice), Choice));
+
+ -- Check for inappropriate type
+
if not Covers (Expected_Type, Etype (Choice)) then
Wrong_Type (Choice, Choice_Type);
+ -- Type is OK, so check further
+
else
E := Entity (Choice);
@@ -1285,6 +1425,8 @@
Next (P);
end loop;
end;
+
+ Set_Has_SP_Choice (Alt);
end if;
-- Not predicated subtype case
@@ -1318,7 +1460,8 @@
else
if Is_OK_Static_Expression (L)
- and then Is_OK_Static_Expression (H)
+ and then
+ Is_OK_Static_Expression (H)
then
if Expr_Value (L) > Expr_Value (H) then
Process_Empty_Choice (Choice);
@@ -1348,7 +1491,7 @@
elsif Kind = N_Others_Choice then
if not (Choice = First (Discrete_Choices (Alt))
and then Choice = Last (Discrete_Choices (Alt))
- and then Alt = Last (Get_Alternatives (N)))
+ and then Alt = Last (Alternatives))
then
Error_Msg_N
("the choice OTHERS must appear alone and last",
@@ -1366,18 +1509,9 @@
Check (Choice, Choice, Choice);
end if;
- -- Move to next choice, deleting the current one if the
- -- flag requesting this deletion is set True.
+ -- Move to next choice
- declare
- C : constant Node_Id := Choice;
- begin
- Next (Choice);
-
- if Delete_Choice then
- Remove (C);
- end if;
- end;
+ Next (Choice);
end loop;
Process_Associated_Node (Alt);
@@ -1407,7 +1541,7 @@
end loop;
end;
- Check_Choices
+ Check_Choice_Set
(Choice_Table,
Bounds_Type,
Subtyp,
@@ -1426,8 +1560,8 @@
Choice_Type => Bounds_Type);
end if;
end;
- end Analyze_Choices;
+ end Check_Choices;
- end Generic_Choices_Processing;
+ end Generic_Check_Choices;
end Sem_Case;
Index: sem_case.ads
===================================================================
--- sem_case.ads (revision 203350)
+++ sem_case.ads (working copy)
@@ -30,52 +30,124 @@
-- aggregate case, since issues with nested aggregates make that case
-- substantially different.
+-- The following processing is required for such cases:
+
+-- 1. Analysis of names of subtypes, constants, expressions appearing within
+-- the choices. This must be done when the construct is encountered to get
+-- proper visibility of names.
+
+-- 2. Checking for semantic correctness of the choices. A lot of this could
+-- be done at the time when the construct is encountered, but not all, since
+-- in the case of variants, statically predicated subtypes won't be frozen
+-- (and the choice sets known) till the enclosing record type is frozen. So
+-- at least the check for no overlaps and covering the range must be delayed
+-- till the freeze point in this case.
+
+-- 3. Set the Others_Discrete_Choices list for an others choice. This is
+-- used in various ways, e.g. to construct the disriminant checking function
+-- for the case of a variant with an others choice.
+
+-- 4. In the case of static predicates, we need to expand out choices that
+-- correspond to the predicate for the back end. This expansion destroys
+-- the list of choices, so it should be delayed to expansion time. We do
+-- not want to mess up the -gnatct ASIS tree, which needs to be able to
+
+-- Step 1 is performed by the generic procedure Analyze_Choices, which is
+-- called when the variant record or case statement/expression is first
+-- encountered.
+
+-- Step 2 is performed by the generic procedure Check_Choices. We decide to
+-- do all semantic checking in that step, since as noted above some of this
+-- has to be deferred to the freeze point in any case for variants. For case
+-- statements and expressions, this procedure can be called at the time the
+-- case construct is encountered (after calling Analyze_Choices).
+
+-- Step 3 is also performed by Check_Choices, since we need the static ranges
+-- for predicated subtypes to accurately construct this.
+
+-- Step 4 is performed by the procedure Expand_Static_Predicates_In_Choices.
+-- For case statements, this call only happens during expansion, so the tree
+-- generated for ASIS does not have this expansion. For the Variant case, the
+-- expansion is done in the ASIS -gnatct case, but with a proper Rewrite call
+-- on the N_Variant node, so ASIS can retrieve the original. The reason we do
+-- the expansion unconditionally for variants is that other processing, for
+-- example for aggregates, relies on having a complete list of choices.
+
+-- Historical note: We used to perform all four of these functions at once in
+-- a single procedure called Analyze_Choices. This routine was called at the
+-- time the construct was first encountered. That seemed to work OK up to Ada
+-- 2005, but the introduction of statically predicated subtypes with delayed
+-- evaluation of the static ranges made this completely wrong, both because
+-- the ASIS tree got destroyed by step 4, and steps 2 and 3 were too early
+-- in the variant record case.
+
with Types; use Types;
package Sem_Case is
procedure No_OP (C : Node_Id);
-- The no-operation routine. Does absolutely nothing. Can be used
- -- in the following generic for the parameter Process_Empty_Choice.
+ -- in the following generics for the parameters Process_Empty_Choice,
+ -- or Process_Associated_Node.
generic
- with function Get_Alternatives (N : Node_Id) return List_Id;
- -- Function used to get the list of case statement alternatives or
- -- record variants, from which we can then access the actual lists of
- -- discrete choices. N is the node for the original construct (case
- -- statement or a record variant).
+ with procedure Process_Associated_Node (A : Node_Id);
+ -- Associated with each case alternative or record variant A there is
+ -- a node or list of nodes that need additional processing. This routine
+ -- implements that processing.
+ package Generic_Analyze_Choices is
+
+ procedure Analyze_Choices
+ (Alternatives : List_Id;
+ Subtyp : Entity_Id);
+ -- From a case expression, case statement, or record variant, this
+ -- routine analyzes the corresponding list of discrete choices which
+ -- appear in each element of the list Alternatives (for the variant
+ -- part case, this is the variants, for a case expression or statement,
+ -- this is the Alternatives).
+ --
+ -- Subtyp is the subtype of the discrete choices. The type against which
+ -- the discrete choices must be resolved is its base type.
+
+ end Generic_Analyze_Choices;
+
+ generic
with procedure Process_Empty_Choice (Choice : Node_Id);
-- Processing to carry out for an empty Choice. Set to No_Op (declared
-- above) if no such processing is required.
with procedure Process_Non_Static_Choice (Choice : Node_Id);
- -- Processing to carry out for a non static Choice
+ -- Processing to carry out for a non static Choice (gives an error msg)
with procedure Process_Associated_Node (A : Node_Id);
-- Associated with each case alternative or record variant A there is
-- a node or list of nodes that need semantic processing. This routine
-- implements that processing.
- package Generic_Choices_Processing is
+ package Generic_Check_Choices is
- procedure Analyze_Choices
- (N : Node_Id;
- Subtyp : Entity_Id;
- Raises_CE : out Boolean;
- Others_Present : out Boolean);
+ procedure Check_Choices
+ (N : Node_Id;
+ Alternatives : List_Id;
+ Subtyp : Entity_Id;
+ Others_Present : out Boolean);
-- From a case expression, case statement, or record variant N, this
- -- routine analyzes the corresponding list of discrete choices. Subtyp
- -- is the subtype of the discrete choices. The type against which the
- -- discrete choices must be resolved is its base type.
+ -- routine analyzes the corresponding list of discrete choices which
+ -- appear in each element of the list Alternatives (for the variant
+ -- part case, this is the variants, for a case expression or statement,
+ -- this is the Alternatives).
--
- -- If one of the bounds of a discrete choice raises a constraint
- -- error the flag Raise_CE is set.
+ -- Subtyp is the subtype of the discrete choices. The type against which
+ -- the discrete choices must be resolved is its base type.
--
- -- Finally Others_Present is set to True if an Others choice is present
- -- in the list of choices, and in this case the call also sets
- -- Others_Discrete_Choices in the N_Others_Choice node.
+ -- Others_Present is set to True if an Others choice is present in the
+ -- list of choices, and in this case Others_Discrete_Choices is set in
+ -- the N_Others_Choice node.
+ --
+ -- If a Discrete_Choice list contains at least one instance of a subtype
+ -- with a static predicate, then the Has_SP_Choice flag is set true in
+ -- the parent node (N_Variant, N_Case_Expression/Statement_Alternative).
- end Generic_Choices_Processing;
-
+ end Generic_Check_Choices;
end Sem_Case;
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 203350)
+++ sem_ch4.adb (working copy)
@@ -1315,13 +1315,17 @@
-- Error routine invoked by the generic instantiation below when
-- the case expression has a non static choice.
- package Case_Choices_Processing is new
- Generic_Choices_Processing
- (Get_Alternatives => Alternatives,
- Process_Empty_Choice => No_OP,
+ package Case_Choices_Analysis is new
+ Generic_Analyze_Choices
+ (Process_Associated_Node => No_OP);
+ use Case_Choices_Analysis;
+
+ package Case_Choices_Checking is new
+ Generic_Check_Choices
+ (Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => No_OP);
- use Case_Choices_Processing;
+ use Case_Choices_Checking;
--------------------------
-- Has_Static_Predicate --
@@ -1363,8 +1367,8 @@
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
- Dont_Care : Boolean;
Others_Present : Boolean;
+ -- Indicates if Others was present
-- Start of processing for Analyze_Case_Expression
@@ -1427,9 +1431,7 @@
-- If error already reported by Resolve, nothing more to do
- if Exp_Btype = Any_Discrete
- or else Exp_Btype = Any_Type
- then
+ if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
return;
elsif Exp_Btype = Any_Character then
@@ -1461,10 +1463,11 @@
then
null;
- -- Call instantiated Analyze_Choices which does the rest of the work
+ -- Call Analyze_Choices and Check_Choices to do the rest of the work
else
- Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
+ Analyze_Choices (Alternatives (N), Exp_Type);
+ Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
end if;
if Exp_Type = Universal_Integer and then not Others_Present then
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 203350)
+++ exp_ch3.adb (working copy)
@@ -5849,7 +5849,6 @@
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
Others_Node : Node_Id;
- Variant : Node_Id;
begin
-- If the last variant does not contain the Others choice, replace it
@@ -5866,15 +5865,12 @@
Set_Discrete_Choices (Last_Var, New_List (Others_Node));
end if;
- -- Deal with any static predicates in the variant choices. Note that we
- -- don't have to look at the last variant, since we know it is an others
- -- choice, because we just rewrote it that way if necessary.
+ -- We have one more expansion activity, which is to deal with static
+ -- predicates in the variant choices. But we have to defer that to
+ -- the freeze point, because the statically predicated subtype won't
+ -- be fully processed till then, so this expansion activity is carried
+ -- out in Freeze_Record_Type.
- Variant := First_Non_Pragma (Variants (N));
- while Variant /= Last_Var loop
- Expand_Static_Predicates_In_Choices (Variant);
- Next_Non_Pragma (Variant);
- end loop;
end Expand_N_Variant_Part;
---------------------------------
