@@ -2237,8 +2237,7 @@ of GNAT specific extensions are recognized as follows:
some restrictions (described below). Aggregate syntax is used for choices
of such a case statement; however, in cases where a "normal" aggregate would
require a discrete value, a discrete subtype may be used instead; box
- notation can also be used to match all values (but currently only
- for discrete subcomponents).
+ notation can also be used to match all values.
Consider this example:
@@ -2269,10 +2268,10 @@ of GNAT specific extensions are recognized as follows:
set shall be a proper subset of the second (and the later alternative
will not be executed if the earlier alternative "matches"). All possible
values of the composite type shall be covered. The composite type of the
- selector shall be a nonlimited untagged undiscriminated record type, all
- of whose subcomponent subtypes are either static discrete subtypes or
- record types that meet the same restrictions. Support for arrays is
- planned, but not yet implemented.
+ selector shall be a nonlimited untagged (but possibly discriminated)
+ record type, all of whose subcomponent subtypes are either static discrete
+ subtypes or record types that meet the same restrictions. Support for arrays
+ is planned, but not yet implemented.
In addition, pattern bindings are supported. This is a mechanism
for binding a name to a component of a matching value for use within
@@ -3641,16 +3641,37 @@ package body Exp_Ch5 is
return Result;
end Elsif_Parts;
+ function Else_Statements return List_Id;
+ -- Returns a "raise Constraint_Error" statement if
+ -- exception propagate is permitted and No_List otherwise.
+
+ ---------------------
+ -- Else_Statements --
+ ---------------------
+
+ function Else_Statements return List_Id is
+ begin
+ if Restriction_Active (No_Exception_Propagation) then
+ return No_List;
+ else
+ return New_List (Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Invalid_Data));
+ end if;
+ end Else_Statements;
+
+ -- Local constants
+
If_Stmt : constant Node_Id :=
Make_If_Statement (Loc,
Condition => Top_Level_Pattern_Match_Condition (First_Alt),
Then_Statements => Statements (First_Alt),
- Elsif_Parts => Elsif_Parts);
- -- Do we want an implicit "else raise Program_Error" here???
- -- Perhaps only if Exception-related restrictions are not in effect.
+ Elsif_Parts => Elsif_Parts,
+ Else_Statements => Else_Statements);
Declarations : constant List_Id := New_List (Selector_Decl);
+ -- Start of processing for Expand_General_Case_Statment
+
begin
if Present (Choice_Index_Decl) then
Append_To (Declarations, Choice_Index_Decl);
@@ -3665,8 +3665,7 @@ The selector for a case statement may be of a composite type, subject to
some restrictions (described below). Aggregate syntax is used for choices
of such a case statement; however, in cases where a “normal” aggregate would
require a discrete value, a discrete subtype may be used instead; box
-notation can also be used to match all values (but currently only
-for discrete subcomponents).
+notation can also be used to match all values.
Consider this example:
@@ -3697,10 +3696,10 @@ overlaps the corresponding set of a later alternative, then the first
set shall be a proper subset of the second (and the later alternative
will not be executed if the earlier alternative “matches”). All possible
values of the composite type shall be covered. The composite type of the
-selector shall be a nonlimited untagged undiscriminated record type, all
-of whose subcomponent subtypes are either static discrete subtypes or
-record types that meet the same restrictions. Support for arrays is
-planned, but not yet implemented.
+selector shall be a nonlimited untagged (but possibly discriminated)
+record type, all of whose subcomponent subtypes are either static discrete
+subtypes or record types that meet the same restrictions. Support for arrays
+is planned, but not yet implemented.
In addition, pattern bindings are supported. This is a mechanism
for binding a name to a component of a matching value for use within
@@ -27,6 +27,7 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
with Errout; use Errout;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -90,13 +91,18 @@ package body Sem_Case is
--
-- Bounds_Type is the type whose range must be covered by the alternatives
--
- -- Subtyp is the subtype of the expression. If its bounds are non-static
+ -- Subtyp is the subtype of the expression. If its bounds are nonstatic
-- the alternatives must cover its base type.
function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
-- Given a Pos value of enumeration type Ctype, returns the name
-- ID of an appropriate string to be used in error message output.
+ function Has_Static_Discriminant_Constraint
+ (Subtyp : Entity_Id) return Boolean;
+ -- Returns True if the given subtype is subject to a discriminant
+ -- constraint and at least one of the constraint values is nonstatic.
+
package Composite_Case_Ops is
function Scalar_Part_Count (Subtyp : Entity_Id) return Nat;
@@ -255,9 +261,9 @@ package body Sem_Case is
-- is posted at location C. Caller sets Error_Msg_Sloc for xx.
procedure Explain_Non_Static_Bound;
- -- Called when we find a non-static bound, requiring the base type to
+ -- Called when we find a nonstatic bound, requiring the base type to
-- be covered. Provides where possible a helpful explanation of why the
- -- bounds are non-static, since this is not always obvious.
+ -- bounds are nonstatic, since this is not always obvious.
function Lt_Choice (C1, C2 : Natural) return Boolean;
-- Comparison routine for comparing Choice_Table entries. Use the lower
@@ -734,7 +740,7 @@ package body Sem_Case is
("bounds of & are not static, "
& "alternatives must cover base type!", Expr, Expr);
- -- If this is a case statement, the expression may be non-static
+ -- If this is a case statement, the expression may be nonstatic
-- or else the subtype may be at fault.
elsif Is_Entity_Name (Expr) then
@@ -1124,14 +1130,14 @@ package body Sem_Case is
return Static_Array_Length (Subtyp)
* Scalar_Part_Count (Component_Type (Subtyp));
elsif Is_Record_Type (Subtyp) then
- pragma Assert (not Has_Discriminants (Subtyp));
declare
Result : Nat := 0;
- Comp : Entity_Id := First_Component (Subtyp);
+ Comp : Entity_Id := First_Component_Or_Discriminant
+ (Base_Type (Subtyp));
begin
while Present (Comp) loop
Result := Result + Scalar_Part_Count (Etype (Comp));
- Next_Component (Comp);
+ Next_Component_Or_Discriminant (Comp);
end loop;
return Result;
end;
@@ -1218,15 +1224,47 @@ package body Sem_Case is
Traverse_Discrete_Parts (Component_Type (Subtyp));
end loop;
elsif Is_Record_Type (Subtyp) then
- pragma Assert (not Has_Discriminants (Subtyp));
- declare
- Comp : Entity_Id := First_Component (Subtyp);
- begin
- while Present (Comp) loop
- Traverse_Discrete_Parts (Etype (Comp));
- Next_Component (Comp);
- end loop;
- end;
+ if Has_Static_Discriminant_Constraint (Subtyp) then
+
+ -- The component range for a constrained discriminant
+ -- is a single value.
+ declare
+ Dc_Elmt : Elmt_Id :=
+ First_Elmt (Discriminant_Constraint (Subtyp));
+ Dc_Value : Uint;
+ begin
+ while Present (Dc_Elmt) loop
+ Dc_Value := Expr_Value (Node (Dc_Elmt));
+ Update_Result ((Low => Dc_Value,
+ High => Dc_Value));
+
+ Next_Elmt (Dc_Elmt);
+ end loop;
+ end;
+
+ -- Generate ranges for nondiscriminant components.
+ declare
+ Comp : Entity_Id := First_Component
+ (Base_Type (Subtyp));
+ begin
+ while Present (Comp) loop
+ Traverse_Discrete_Parts (Etype (Comp));
+ Next_Component (Comp);
+ end loop;
+ end;
+ else
+ -- Generate ranges for all components
+ declare
+ Comp : Entity_Id :=
+ First_Component_Or_Discriminant
+ (Base_Type (Subtyp));
+ begin
+ while Present (Comp) loop
+ Traverse_Discrete_Parts (Etype (Comp));
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end;
+ end if;
else
Error_Msg_N
("case selector type having a non-discrete non-record"
@@ -1234,6 +1272,7 @@ package body Sem_Case is
Expression (Case_Statement));
end if;
end Traverse_Discrete_Parts;
+
begin
Traverse_Discrete_Parts (Etype (Expression (Case_Statement)));
pragma Assert (Done or else Serious_Errors_Detected > 0);
@@ -1338,12 +1377,23 @@ package body Sem_Case is
is
Result : Choice_Range_Info (Is_Others => False);
Ranges : Composite_Range_Info renames Result.Ranges;
- Next_Part : Part_Id := 1;
- Done : Boolean := False;
+ Next_Part : Part_Id'Base range 1 .. Part_Id'Last + 1 := 1;
+
+ procedure Traverse_Choice (Expr : Node_Id);
+ -- Traverse a legal choice expression, looking for
+ -- values/ranges of discrete parts. Call Update_Result
+ -- for each.
procedure Update_Result (Discrete_Range : Discrete_Range_Info);
-- Initialize first remaining uninitialized element of Ranges.
- -- Also set Next_Part and Done.
+ -- Also set Next_Part.
+
+ procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id);
+ -- For each scalar part of the given component type, call
+ -- Update_Result with the full range for that scalar part.
+ -- This is used for both box components in aggregates and
+ -- for any inactive-variant components that do not appear in
+ -- a given aggregate.
-------------------
-- Update_Result --
@@ -1351,19 +1401,21 @@ package body Sem_Case is
procedure Update_Result (Discrete_Range : Discrete_Range_Info) is
begin
- pragma Assert (not Done);
Ranges (Next_Part) := Discrete_Range;
- if Next_Part = Part_Id'Last then
- Done := True;
- else
- Next_Part := Next_Part + 1;
- end if;
+ Next_Part := Next_Part + 1;
end Update_Result;
- procedure Traverse_Choice (Expr : Node_Id);
- -- Traverse a legal choice expression, looking for
- -- values/ranges of discrete parts. Call Update_Result
- -- for each.
+ -------------------------------------
+ -- Update_Result_For_Full_Coverage --
+ -------------------------------------
+
+ procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id)
+ is
+ begin
+ for Counter in 1 .. Scalar_Part_Count (Comp_Type) loop
+ Update_Result (Component_Bounds (Next_Part));
+ end loop;
+ end Update_Result_For_Full_Coverage;
---------------------
-- Traverse_Choice --
@@ -1388,52 +1440,89 @@ package body Sem_Case is
Refresh_Binding_Info (Aggr => Expr);
declare
- Comp : Node_Id :=
+ Comp_Assoc : Node_Id :=
First (Component_Associations (Expr));
- -- Ok to assume that components are in order here?
+ -- Aggregate has been normalized (components in
+ -- order, only one component per choice, etc.).
+
+ Comp_From_Type : Node_Id :=
+ First_Component_Or_Discriminant
+ (Base_Type (Etype (Expr)));
+
+ Saved_Next_Part : constant Part_Id := Next_Part;
begin
- while Present (Comp) loop
- pragma Assert (List_Length (Choices (Comp)) = 1);
- if Box_Present (Comp) then
- declare
- Comp_Type : constant Entity_Id :=
- Etype (First (Choices (Comp)));
- begin
- if Is_Discrete_Type (Comp_Type) then
- declare
- Low : constant Node_Id :=
- Type_Low_Bound (Comp_Type);
- High : constant Node_Id :=
- Type_High_Bound (Comp_Type);
- begin
- Update_Result
- ((Low => Expr_Value (Low),
- High => Expr_Value (High)));
- end;
- else
- -- Need to recursively traverse type
- -- here, calling Update_Result for
- -- each discrete subcomponent.
+ while Present (Comp_Assoc) loop
+ pragma Assert
+ (List_Length (Choices (Comp_Assoc)) = 1);
- Error_Msg_N
- ("box values for nondiscrete pattern "
- & "subcomponents unimplemented", Comp);
+ declare
+ Comp : constant Node_Id :=
+ Entity (First (Choices (Comp_Assoc)));
+ Comp_Seen : Boolean := False;
+ begin
+ loop
+ if Original_Record_Component (Comp) =
+ Original_Record_Component (Comp_From_Type)
+ then
+ Comp_Seen := True;
+ else
+ -- We have an aggregate of a type that
+ -- has a variant part (or has a
+ -- subcomponent type that has a variant
+ -- part) and we have to deal with a
+ -- component that is present in the type
+ -- but not in the aggregate (because the
+ -- component is in an inactive variant).
+ --
+ Update_Result_For_Full_Coverage
+ (Comp_Type => Etype (Comp_From_Type));
end if;
- end;
+
+ Comp_From_Type :=
+ Next_Component_Or_Discriminant
+ (Comp_From_Type);
+
+ exit when Comp_Seen;
+ end loop;
+ end;
+
+ if Box_Present (Comp_Assoc) then
+ -- Box matches all values
+ Update_Result_For_Full_Coverage
+ (Etype (First (Choices (Comp_Assoc))));
else
- Traverse_Choice (Expression (Comp));
+ Traverse_Choice (Expression (Comp_Assoc));
end if;
- if Binding_Chars (Comp) /= No_Name
+ if Binding_Chars (Comp_Assoc) /= No_Name
then
Case_Bindings.Note_Binding
- (Comp_Assoc => Comp,
+ (Comp_Assoc => Comp_Assoc,
Choice => Choice,
Alt => Alt);
end if;
- Next (Comp);
+ Next (Comp_Assoc);
end loop;
+
+ while Present (Comp_From_Type) loop
+ -- Deal with any trailing inactive-variant
+ -- components.
+ --
+ -- See earlier commment about calling
+ -- Update_Result_For_Full_Coverage for such
+ -- components.
+
+ Update_Result_For_Full_Coverage
+ (Comp_Type => Etype (Comp_From_Type));
+
+ Comp_From_Type :=
+ Next_Component_Or_Discriminant (Comp_From_Type);
+ end loop;
+
+ pragma Assert
+ (Nat (Next_Part - Saved_Next_Part)
+ = Scalar_Part_Count (Etype (Expr)));
end;
elsif Is_Array_Type (Etype (Expr)) then
if Is_Non_Empty_List (Component_Associations (Expr)) then
@@ -1477,6 +1566,8 @@ package body Sem_Case is
end if;
end Traverse_Choice;
+ -- Start of processing for Parse_Choice
+
begin
if Nkind (Choice) = N_Others_Choice then
return (Is_Others => True);
@@ -1484,7 +1575,7 @@ package body Sem_Case is
Traverse_Choice (Choice);
-- Avoid returning uninitialized garbage in error case
- if not Done then
+ if Next_Part /= Part_Id'Last + 1 then
pragma Assert (Serious_Errors_Detected > 0);
Result.Ranges := (others => (Low => Uint_1, High => Uint_0));
end if;
@@ -2936,20 +3027,34 @@ package body Sem_Case is
end if;
Check_Component_Subtype (Component_Type (Subtyp));
elsif Is_Record_Type (Subtyp) then
- if Has_Discriminants (Subtyp) then
- Error_Msg_N
- ("type of case selector (or subcomponent thereof) " &
- "is discriminated", N);
- else
- declare
- Comp : Entity_Id := First_Component (Subtyp);
- begin
- while Present (Comp) loop
- Check_Component_Subtype (Etype (Comp));
- Next_Component (Comp);
- end loop;
- end;
+
+ if Has_Discriminants (Subtyp)
+ and then Is_Constrained (Subtyp)
+ and then not Has_Static_Discriminant_Constraint (Subtyp)
+ then
+ -- We are only disallowing nonstatic constraints for
+ -- subcomponent subtypes, not for the subtype of the
+ -- expression we are casing on. This test could be
+ -- implemented via an Is_Recursive_Call parameter if
+ -- that seems preferable.
+
+ if Subtyp /= Check_Choices.Subtyp then
+ Error_Msg_N
+ ("constrained discriminated subtype of case " &
+ "selector subcomponent has nonstatic " &
+ "constraint", N);
+ end if;
end if;
+
+ declare
+ Comp : Entity_Id :=
+ First_Component_Or_Discriminant (Base_Type (Subtyp));
+ begin
+ while Present (Comp) loop
+ Check_Component_Subtype (Etype (Comp));
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end;
else
Error_Msg_N
("type of case selector (or subcomponent thereof) is " &
@@ -3058,7 +3163,7 @@ package body Sem_Case is
-- bounds of its base type to determine the values covered by the
-- discrete choices.
- -- In Ada 2012, if the subtype has a non-static predicate the full
+ -- In Ada 2012, if the subtype has a nonstatic predicate the full
-- range of the base type must be covered as well.
if Is_OK_Static_Subtype (Subtyp) then
@@ -3075,7 +3180,7 @@ package body Sem_Case is
end if;
-- Obtain static bounds of type, unless this is a generic formal
- -- discrete type for which all choices will be non-static.
+ -- discrete type for which all choices will be nonstatic.
if not Is_Generic_Type (Root_Type (Bounds_Type))
or else Ekind (Bounds_Type) /= E_Enumeration_Type
@@ -3137,7 +3242,7 @@ package body Sem_Case is
if Has_Predicates (E) then
- -- Use of non-static predicate is an error
+ -- Use of nonstatic predicate is an error
if not Is_Discrete_Type (E)
or else not Has_Static_Predicate (E)
@@ -3298,6 +3403,30 @@ package body Sem_Case is
end Generic_Check_Choices;
+ -----------------------------------------
+ -- Has_Static_Discriminant_Constraint --
+ -----------------------------------------
+
+ function Has_Static_Discriminant_Constraint
+ (Subtyp : Entity_Id) return Boolean
+ is
+ begin
+ if Has_Discriminants (Subtyp) and then Is_Constrained (Subtyp) then
+ declare
+ DC_Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Subtyp));
+ begin
+ while Present (DC_Elmt) loop
+ if not All_Composite_Constraints_Static (Node (DC_Elmt)) then
+ return False;
+ end if;
+ Next_Elmt (DC_Elmt);
+ end loop;
+ return True;
+ end;
+ end if;
+ return False;
+ end Has_Static_Discriminant_Constraint;
+
----------------------------
-- Is_Case_Choice_Pattern --
----------------------------