The compiler was expanding choices in variant parts and case
statements and expressions prematurely, so that the ASIS tree
had these expansions, causing malfunction of ASIS tools (notably
gnatpp, the pretty printer) to malfunction. This patch moves
the expansion to the expander where it belongs so that it only
occurs if code is being generated.
If the following program is compiled with -gnatct -gnatG:
1. procedure Predicate_ASIS 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. X : Color := Red;
15.
16. begin
17. case X is
18. when Other => null;
19. when S1 | S2 => null;
20. end case;
21. end Predicate_ASIS;
then the -gnatG output after the begin is:
begin
case x is
when other =>
null;
when s1 | s2 =>
null;
end case;
end predicate_asis;
And the "other" choice is not expanded.
The following makes sure we are still properly diagnosing missing
cases etc in the -gnatct case:
1. procedure Predicate_ASIS2 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. X : Color := Red;
15.
16. begin
17. case X is
|
>>> missing case values: "Orange" .. "Yellow"
18. when Other => null;
19. when S2 => null;
20. end case;
21. end Predicate_ASIS2;
Finally, this test makes sure the code generator is handling the case
of a static predicate correctly, the following is compiled without
-gnatct and bound and linked in the usual manner:
1. with Ada.Text_IO; use Ada.Text_IO;
2. procedure Predicate_ASIS3 is
3. type Color is
4. (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
5.
6. subtype S1 is Color with
7. Predicate => S1 in Orange .. Yellow;
8.
9. subtype S2 is Color with
10. Predicate => S2 in Blue .. Blue;
11.
12. subtype Other is Color with
13. Predicate => Other not in S1 | S2;
14.
15. begin
16. for X in Color loop
17. case X is
18. when Other => Put_Line (X'Img & " is in Other");
19. when S1 => Put_Line (X'Img & " is in S1");
20. when S2 => Put_Line (X'Img & " is in S2");
21. end case;
22. end loop;
23.
24. New_Line;
25.
26. for X in Color loop
27. Put_Line (X'Img &
28. (case X is
29. when Other => " is in Other",
30. when S1 => " is in S1",
31. when S2 => " is in S2"));
32. end loop;
33. end Predicate_ASIS3;
The output is:
RED is in Other
ORANGE is in S1
YELLOW is in S1
GREEN is in Other
BLUE is in S2
INDIGO is in Other
VIOLET is in Other
RED is in Other
ORANGE is in S1
YELLOW is in S1
GREEN is in Other
BLUE is in S2
INDIGO is in Other
VIOLET is in Other
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): Expand statically
predicated subtype which appears in Discrete_Choices list.
* exp_ch5.adb (Expand_N_Case_Statement): Expand statically
predicated subtype which appears in Discrete_Choices list of
case statement alternative.
* exp_util.ads, exp_util.adb (Expand_Static_Predicates_In_Choices): New
procedure.
* sem_case.adb: Minor reformatting (Analyze_Choices): Don't
expand out Discrete_Choices that are names of subtypes with
static predicates. This is now done in the analyzer so that the
-gnatct tree is properly formed for ASIS.
* sem_case.ads (Generic_Choices_Processing): Does not apply
to aggregates any more, so change doc accordingly, and remove
unneeded Get_Choices argument.
* sem_ch3.adb (Analyze_Variant_Part): Remove no
longer used Get_Choices argument in instantiation of
Generic_Choices_Processing.
* sem_ch4.adb (Analyze_Case_Expression): Remove no
longer used Get_Choices argument in instantiation of
Generic_Choices_Processing.
* sem_ch5.adb (Analyze_Case_Statement): Remove no
longer used Get_Choices argument in instantiation of
Generic_Choices_Processing.
* sinfo.ads: For N_Variant_Part, and N_Case_Statement_Alternative,
document that choices that are names of statically predicated
subtypes are expanded in the code generation tree passed to the
back end, but not in the ASIS tree generated for -gnatct.
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 203342)
+++ exp_ch5.adb (working copy)
@@ -2537,8 +2537,12 @@
-- if statement, since this can result in subsequent optimizations.
-- This helps not only with case statements in the source of a
-- simple form, but also with generated code (discriminant check
- -- functions in particular)
+ -- functions in particular).
+ -- Note: it is OK to do this before expanding out choices for any
+ -- static predicates, since the if statement processing will handle
+ -- the static predicate case fine.
+
elsif Len = 2 then
Chlist := Discrete_Choices (First (Alternatives (N)));
@@ -2617,12 +2621,14 @@
Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
end if;
- Alt := First (Alternatives (N));
- while Present (Alt)
- and then Nkind (Alt) = N_Case_Statement_Alternative
- loop
+ -- Deal with possible declarations of controlled objects, and also
+ -- with rewriting choice sequences for static predicate references.
+
+ Alt := First_Non_Pragma (Alternatives (N));
+ while Present (Alt) loop
Process_Statements_For_Controlled_Objects (Alt);
- Next (Alt);
+ Expand_Static_Predicates_In_Choices (Alt);
+ Next_Non_Pragma (Alt);
end loop;
end;
end Expand_N_Case_Statement;
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 203343)
+++ sem_ch3.adb (working copy)
@@ -4602,7 +4602,6 @@
package Variant_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Variants,
- Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Declarations);
Index: sem_ch5.adb
===================================================================
--- sem_ch5.adb (revision 203342)
+++ sem_ch5.adb (working copy)
@@ -1045,7 +1045,6 @@
package Case_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Alternatives,
- Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Statements);
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 203348)
+++ exp_util.adb (working copy)
@@ -1946,6 +1946,69 @@
end if;
end Evolve_Or_Else;
+ -----------------------------------------
+ -- Expand_Static_Predicates_In_Choices --
+ -----------------------------------------
+
+ procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
+ pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
+
+ Choices : constant List_Id := Discrete_Choices (N);
+
+ Choice : Node_Id;
+ Next_C : Node_Id;
+ P : Node_Id;
+ C : Node_Id;
+
+ begin
+ Choice := First (Choices);
+ while Present (Choice) loop
+ Next_C := Next (Choice);
+
+ -- Check for name of subtype with static predicate
+
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ and then Has_Predicates (Entity (Choice))
+ then
+ -- Loop through entries in predicate list, converting to choices
+ -- and inserting in the list before the current choice. Note that
+ -- if the list is empty, corresponding to a False predicate, then
+ -- no choices are inserted.
+
+ P := First (Static_Predicate (Entity (Choice)));
+ while Present (P) loop
+
+ -- If low bound and high bounds are equal, copy simple choice
+
+ if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
+ C := New_Copy (Low_Bound (P));
+
+ -- Otherwise copy a range
+
+ else
+ C := New_Copy (P);
+ end if;
+
+ -- Change Sloc to referencing choice (rather than the Sloc of
+ -- the predicate declarationo element itself).
+
+ Set_Sloc (C, Sloc (Choice));
+ Insert_Before (Choice, C);
+ Next (P);
+ end loop;
+
+ -- Delete the predicated entry
+
+ Remove (Choice);
+ end if;
+
+ -- Move to next choice to check
+
+ Choice := Next_C;
+ end loop;
+ end Expand_Static_Predicates_In_Choices;
+
------------------------------
-- Expand_Subtype_From_Expr --
------------------------------
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 203342)
+++ exp_util.ads (working copy)
@@ -377,6 +377,12 @@
-- indicating that no checks were required). The Sloc field of the
-- constructed N_Or_Else node is copied from Cond1.
+ procedure Expand_Static_Predicates_In_Choices (N : Node_Id);
+ -- N is either a case alternative or a variant. The Discrete_Choices field
+ -- of N points to a list of choices. If any of these choices is the name
+ -- of a (statically) predicated subtype, then it is rewritten as the series
+ -- of choices that correspond to the values allowed for the subtype.
+
procedure Expand_Subtype_From_Expr
(N : Node_Id;
Unc_Type : Entity_Id;
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 203349)
+++ sinfo.ads (working copy)
@@ -3084,6 +3084,12 @@
-- Present_Expr (Uint3-Sem)
-- Dcheck_Function (Node5-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.
+
---------------------------------
-- 3.8.1 Discrete Choice List --
---------------------------------
@@ -4382,6 +4388,12 @@
-- Discrete_Choices (List4)
-- Statements (List3)
+ -- 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.
+
-------------------------
-- 5.5 Loop Statement --
-------------------------
Index: sem_case.adb
===================================================================
--- sem_case.adb (revision 203342)
+++ sem_case.adb (working copy)
@@ -57,9 +57,9 @@
-- to the choice node itself.
type Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
- -- Table type used to sort the choices present in a case statement, array
- -- aggregate or record variant. The actual entries are stored in 1 .. Last,
- -- but we have a 0 entry for convenience in sorting.
+ -- Table type used to sort the choices present in a case statement or
+ -- record variant. The actual entries are stored in 1 .. Last, but we
+ -- have a 0 entry for use in sorting.
-----------------------
-- Local Subprograms --
@@ -145,8 +145,7 @@
procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint);
-- Emit an error message for each non-covered static predicate set.
- -- Prev_Hi denotes the upper bound of the last choice that covered a
- -- set.
+ -- Prev_Hi denotes the upper bound of the last choice covering a set.
procedure Move_Choice (From : Natural; To : Natural);
-- Move routine for sorting the Choice_Table
@@ -263,7 +262,6 @@
else
Illegal_Range (Loc, Choice_Lo, Choice_Hi);
Error := True;
-
return;
end if;
@@ -443,21 +441,21 @@
if Nkind (Case_Node) = N_Variant_Part then
Error_Msg_NE
- ("bounds of & are not static," &
- " alternatives must cover base type", Expr, Expr);
+ ("bounds of & are not static, "
+ & "alternatives must cover base type!", Expr, Expr);
-- If this is a case statement, the expression may be non-static
-- or else the subtype may be at fault.
elsif Is_Entity_Name (Expr) then
Error_Msg_NE
- ("bounds of & are not static," &
- " alternatives must cover base type", Expr, Expr);
+ ("bounds of & are not static, "
+ & "alternatives must cover base type!", Expr, Expr);
else
Error_Msg_N
- ("subtype of expression is not static,"
- & " alternatives must cover base type!", Expr);
+ ("subtype of expression is not static, "
+ & "alternatives must cover base type!", Expr);
end if;
-- Otherwise the expression is not static, even if the bounds of the
@@ -1220,10 +1218,13 @@
if Nkind (Alt) = N_Pragma then
Analyze (Alt);
- -- Otherwise check each choice against its base type
+ -- 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 (Get_Choices (Alt));
+ Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
Delete_Choice := False;
Analyze (Choice);
@@ -1260,33 +1261,29 @@
then
Bad_Predicated_Subtype_Use
("cannot use subtype& with non-static "
- & "predicate as case alternative", Choice, E,
- Suggest_Static => True);
+ & "predicate as case alternative",
+ Choice, E, Suggest_Static => True);
- -- Static predicate case
+ -- Static predicate case
else
declare
- Copy : constant List_Id := Empty_List;
- P : Node_Id;
- C : Node_Id;
+ P : Node_Id;
+ C : Node_Id;
begin
-- Loop through entries in predicate list,
- -- converting to choices. Note that if the
+ -- checking each entry. Note that if the
-- list is empty, corresponding to a False
- -- predicate, then no choices are inserted.
+ -- predicate, then no choices are checked.
P := First (Static_Predicate (E));
while Present (P) loop
C := New_Copy (P);
Set_Sloc (C, Sloc (Choice));
- Append_To (Copy, C);
+ Check (C, Low_Bound (C), High_Bound (C));
Next (P);
end loop;
-
- Insert_List_After (Choice, Copy);
- Delete_Choice := True;
end;
end if;
@@ -1306,8 +1303,6 @@
Resolve_Discrete_Subtype_Indication
(Choice, Expected_Type);
- -- Here for other than predicated subtype case
-
if Etype (Choice) /= Any_Type then
declare
C : constant Node_Id := Constraint (Choice);
@@ -1351,9 +1346,9 @@
-- alternative and as its only choice.
elsif Kind = N_Others_Choice then
- if not (Choice = First (Get_Choices (Alt))
- and then Choice = Last (Get_Choices (Alt))
- and then Alt = Last (Get_Alternatives (N)))
+ if not (Choice = First (Discrete_Choices (Alt))
+ and then Choice = Last (Discrete_Choices (Alt))
+ and then Alt = Last (Get_Alternatives (N)))
then
Error_Msg_N
("the choice OTHERS must appear alone and last",
Index: sem_case.ads
===================================================================
--- sem_case.ads (revision 203342)
+++ sem_case.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -40,28 +40,22 @@
generic
with function Get_Alternatives (N : Node_Id) return List_Id;
- -- Function needed to get to the actual list of case statement
- -- alternatives, or array aggregate component associations or
- -- record variants from which we can then access the actual lists
- -- of discrete choices. N is the node for the original construct
- -- i.e. a case statement, an array aggregate or a record variant.
+ -- 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 function Get_Choices (A : Node_Id) return List_Id;
- -- Given a case statement alternative, array aggregate component
- -- association or record variant A we need different access functions
- -- to get to the actual list of discrete choices.
-
with procedure Process_Empty_Choice (Choice : Node_Id);
- -- Processing to carry out for an empty Choice
+ -- 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
with procedure Process_Associated_Node (A : Node_Id);
- -- Associated with each case alternative, aggregate component
- -- association or record variant A there is a node or list of nodes
- -- that need semantic processing. This routine implements that
- -- processing.
+ -- 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
@@ -70,12 +64,12 @@
Subtyp : Entity_Id;
Raises_CE : out Boolean;
Others_Present : out Boolean);
- -- From a case expression, case statement, array aggregate 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.
+ -- 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.
--
- -- In one of the bounds of a discrete choice raises a constraint
+ -- If one of the bounds of a discrete choice raises a constraint
-- error the flag Raise_CE is set.
--
-- Finally Others_Present is set to True if an Others choice is present
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 203345)
+++ sem_ch4.adb (working copy)
@@ -1318,7 +1318,6 @@
package Case_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Alternatives,
- Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => No_OP);
@@ -3962,8 +3961,8 @@
Next (Param);
end loop;
- -- One of the specs has additional formals, there is no match,
- -- unless this may be an indexing of a parameterless call.
+ -- One of the specs has additional formals; there is no match, unless
+ -- this may be an indexing of a parameterless call.
-- Note that when expansion is disabled, the corresponding record
-- type of synchronized types is not constructed, so that there is
@@ -3977,7 +3976,6 @@
and then not Expander_Active
then
return True;
-
else
return False;
end if;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 203342)
+++ exp_ch3.adb (working copy)
@@ -5846,23 +5846,35 @@
-- Expand_N_Variant_Part --
---------------------------
- -- 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 that
- -- corresponds to the others choice (it's the list we are replacing!)
-
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
+ -- 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!)
+
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;
+
+ -- 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.
+
+ 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;
---------------------------------
