This patch completes the implementation of statically predicated
subtypes as choices in record variants. The following should
compile quietly in both code generation and -gnatct mode:
1. package Predicate_Variant is
2. type Color is
3. (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
4.
5. subtype S1 is Color with
6. Predicate => S1 in Orange .. Yellow;
7.
8. subtype S2 is Color with
9. Predicate => S2 in Blue .. Blue;
10.
11. subtype Other is Color with
12. Predicate => Other not in S1 | S2;
13.
14. type R (D : Color) is record
15. case D is
16. when S1 => F : Float;
17. when S2 => I : Integer;
18. when Other => C : Character;
19. end case;
20. end record;
21.
22. R1 : constant R := (Red , 'A');
23. R2 : constant R := (Orange , 2.0);
24. R3 : constant R := (Yellow , 1.0);
25. R4 : constant R := (Green , 'G');
26. R5 : constant R := (Blue , 10);
27. R6 : constant R := (Indigo , 'I');
28. R7 : constant R := (Violet , 'V');
29. end Predicate_Variant;
And the following should compile with the indicated errors in both
code generation and -gnatct mode:
1. PROCEDURE Variant_Errors IS
2. SUBTYPE STATCHAR IS CHARACTER RANGE 'I' .. 'N';
3. TYPE REC1 (DISC : STATCHAR) IS
4. RECORD
5. CASE DISC IS
|
>>> missing case value: 'K'
>>> missing case value: 'N'
6. WHEN 'I' => NULL;
7. WHEN 'J' => NULL;
8. WHEN 'L' => NULL;
9. WHEN 'M' => NULL;
10. END CASE;
11. END RECORD;
12. BEGIN
13. NULL;
14. end Variant_Errors;
Note: there is one problem left, which will be addressed in a
separate patch, namely we have lost diagnosis of missing cases
etc in generic templates (the erors will appear when the generic
is instantiated, so it's not a major problem).
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-10 Robert Dewar <de...@adacore.com>
* freeze.adb (Freeze_Record_Type): Move choice checking to
Analyze_Freeze_Entity (Freeze_Record_Type): Make sure all choices
are properly frozen
* sem_case.adb (Check_Choices): Remove misguided attempt to
freeze choices (this is now done in Freeze_Record_Type where
it belongs).
(Check_Choices): Remove some analyze/resolve calls
that are redundant since they are done in Analyze_Choices.
* sem_ch13.adb (Analyze_Freeze_Entity): Do the error
checking for choices in variant records here (moved here from
Freeze.Freeze_Record_Type)
Index: freeze.adb
===================================================================
--- freeze.adb (revision 203362)
+++ freeze.adb (working copy)
@@ -46,7 +46,6 @@
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;
@@ -1995,6 +1994,11 @@
-- freeze node at some eventual point of call. Protected operations
-- are handled elsewhere.
+ procedure Freeze_Choices_In_Variant_Part (VP : Node_Id);
+ -- Make sure that all types mentioned in Discrete_Choices of the
+ -- variants referenceed by the Variant_Part VP are frozen. This is
+ -- a recursive routine to deal with nested variants.
+
---------------------
-- Check_Allocator --
---------------------
@@ -2047,6 +2051,50 @@
end if;
end Check_Itype;
+ ------------------------------------
+ -- Freeze_Choices_In_Variant_Part --
+ ------------------------------------
+
+ procedure Freeze_Choices_In_Variant_Part (VP : Node_Id) is
+ pragma Assert (Nkind (VP) = N_Variant_Part);
+
+ Variant : Node_Id;
+ Choice : Node_Id;
+ CL : Node_Id;
+
+ begin
+ -- Loop through variants
+
+ Variant := First_Non_Pragma (Variants (VP));
+ while Present (Variant) loop
+
+ -- Loop through choices, checking that all types are frozen
+
+ Choice := First_Non_Pragma (Discrete_Choices (Variant));
+ while Present (Choice) loop
+ if Nkind (Choice) in N_Has_Etype
+ and then Present (Etype (Choice))
+ then
+ Freeze_And_Append (Etype (Choice), N, Result);
+ end if;
+
+ Next_Non_Pragma (Choice);
+ end loop;
+
+ -- Check for nested variant part to process
+
+ CL := Component_List (Variant);
+
+ if not Null_Present (CL) then
+ if Present (Variant_Part (CL)) then
+ Freeze_Choices_In_Variant_Part (Variant_Part (CL));
+ end if;
+ end if;
+
+ Next_Non_Pragma (Variant);
+ end loop;
+ end Freeze_Choices_In_Variant_Part;
+
-- Start of processing for Freeze_Record_Type
begin
@@ -2627,109 +2675,15 @@
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.
+ -- Finally we need to check the variant part to make sure that
+ -- all types within choices are properly frozen as part of the
+ -- freezing of the record type.
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
@@ -2751,44 +2705,15 @@
-- Case of variant part present
if Present (C) and then Present (Variant_Part (C)) then
- V := Variant_Part (C);
+ Freeze_Choices_In_Variant_Part (Variant_Part (C));
+ end if;
- -- Check choices
+ -- Note: we used to call Check_Choices here, but it is too early,
+ -- since predicated subtypes are frozen here, but their freezing
+ -- actions are in Analyze_Freeze_Entity, which has not been called
+ -- yet for entities frozen within this procedure, so we moved that
+ -- call to the Analyze_Freeze_Entity for the record type.
- Check_Choices
- (V, Variants (V), Etype (Name (V)), Others_Present);
-
- -- If the last variant does not contain the Others choice,
- -- replace it with an N_Others_Choice node since Gigi always
- -- wants an Others. Note that we do not bother to call Analyze
- -- on the modified variant part, since its only effect would be
- -- to compute the Others_Discrete_Choices node laboriously, and
- -- of course we already know the list of choices corresponding
- -- to the others choice (it's the list we're replacing!)
-
- -- We only want to do this if the expander is active, since
- -- we do not want to clobber the ASIS tree!
-
- if Expander_Active then
- declare
- Last_Var : constant Node_Id :=
- Last_Non_Pragma (Variants (V));
-
- Others_Node : Node_Id;
-
- begin
- if Nkind (First (Discrete_Choices (Last_Var))) /=
- N_Others_Choice
- then
- Others_Node := Make_Others_Choice (Sloc (Last_Var));
- Set_Others_Discrete_Choices
- (Others_Node, Discrete_Choices (Last_Var));
- Set_Discrete_Choices
- (Last_Var, New_List (Others_Node));
- end if;
- end;
- end if;
- end if;
end Check_Variant_Part;
end Freeze_Record_Type;
Index: sem_case.adb
===================================================================
--- sem_case.adb (revision 203358)
+++ sem_case.adb (working copy)
@@ -26,8 +26,6 @@
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;
@@ -1297,9 +1295,7 @@
-- 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
+ if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
return;
end if;
@@ -1357,7 +1353,6 @@
else
Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
- Analyze (Choice);
Kind := Nkind (Choice);
-- Choice is a Range
@@ -1366,7 +1361,6 @@
or else (Kind = N_Attribute_Reference
and then Attribute_Name (Choice) = Name_Range)
then
- Resolve (Choice, Expected_Type);
Check (Choice, Low_Bound (Choice), High_Bound (Choice));
-- Choice is a subtype name
@@ -1374,12 +1368,6 @@
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
@@ -1505,7 +1493,6 @@
-- Only other possibility is an expression
else
- Resolve (Choice, Expected_Type);
Check (Choice, Choice, Choice);
end if;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 203361)
+++ sem_ch13.adb (working copy)
@@ -44,6 +44,7 @@
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Case; use Sem_Case;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
@@ -5239,6 +5240,171 @@
Uninstall_Discriminants_And_Pop_Scope (E);
end if;
+
+ -- For a record type, deal with variant parts. This has to be delayed
+ -- to this point, because of the issue of statically precicated
+ -- subtypes, which we have to ensure are frozen before checking
+ -- choices, since we need to have the static choice list set.
+
+ if Is_Record_Type (E) then
+ Check_Variant_Part : declare
+ D : constant Node_Id := Declaration_Node (E);
+ T : Node_Id;
+ C : Node_Id;
+ VP : 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;
+
+ -- Case of variant part present
+
+ if Present (C) and then Present (Variant_Part (C)) then
+ VP := Variant_Part (C);
+
+ -- Check choices
+
+ Check_Choices
+ (VP, Variants (VP), Etype (Name (VP)), Others_Present);
+
+ -- If the last variant does not contain the Others choice,
+ -- replace it with an N_Others_Choice node since Gigi always
+ -- wants an Others. Note that we do not bother to call Analyze
+ -- on the modified variant part, since its only effect would be
+ -- to compute the Others_Discrete_Choices node laboriously, and
+ -- of course we already know the list of choices corresponding
+ -- to the others choice (it's the list we're replacing!)
+
+ -- We only want to do this if the expander is active, since
+ -- we do not want to clobber the ASIS tree!
+
+ if Expander_Active then
+ declare
+ Last_Var : constant Node_Id :=
+ Last_Non_Pragma (Variants (VP));
+
+ Others_Node : Node_Id;
+
+ begin
+ if Nkind (First (Discrete_Choices (Last_Var))) /=
+ N_Others_Choice
+ then
+ Others_Node := Make_Others_Choice (Sloc (Last_Var));
+ Set_Others_Discrete_Choices
+ (Others_Node, Discrete_Choices (Last_Var));
+ Set_Discrete_Choices
+ (Last_Var, New_List (Others_Node));
+ end if;
+ end;
+ end if;
+ end if;
+ end Check_Variant_Part;
+ end if;
end Analyze_Freeze_Entity;
------------------------------------------
