[Ada] Add -gnatX support for casing on array values
gcc/ada/ * exp_ch5.adb (Expand_General_Case_Statement.Pattern_Match): Add new function Indexed_Element to handle array element comparisons. Handle case choices that are array aggregates, string literals, or names denoting constants. * sem_case.adb (Composite_Case_Ops.Array_Case_Ops): New package providing utilities needed for casing on arrays. (Composite_Case_Ops.Choice_Analysis): If necessary, include array length as a "component" (like a discriminant) when traversing components. We do not (yet) partition choice analysis to deal with unequal length choices separately. Instead, we embed everything in the minimum-dimensionality Cartesian product space needed to handle all choices properly; this is determined by the length of the longest choice pattern. (Composite_Case_Ops.Choice_Analysis.Traverse_Discrete_Parts): Include length as a "component" in the traversal if necessary. (Composite_Case_Ops.Choice_Analysis.Parse_Choice.Traverse_Choice): Add support for case choices that are string literals or names denoting constants. (Composite_Case_Ops.Choice_Analysis): Include length as a "component" in the analysis if necessary. (Check_Choices.Check_Case_Pattern_Choices.Ops.Value_Sets.Value_Index_Count): Improve error message when capacity exceeded. * doc/gnat_rm/implementation_defined_pragmas.rst: Update documentation to reflect current implementation status. * gnat_rm.texi: Regenerate.
This commit is contained in:
Steve Baird
Pierre-Marie de Rodat
parent
c5ff859dc0
commit
ec813d06f7
@ -2270,8 +2270,15 @@ of GNAT specific extensions are recognized as follows:
|
||||
values of the composite type shall be covered. The composite type of the
|
||||
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.
|
||||
subtypes or record types that meet the same restrictions.
|
||||
|
||||
Support for casing on arrays (and on records that contain arrays) is
|
||||
currently subject to some restrictions. Non-positional
|
||||
array aggregates are not supported as (or within) case choices. Likewise
|
||||
for array type and subtype names. The current implementation exceeds
|
||||
compile-time capacity limits in some annoyingly common scenarios; the
|
||||
message generated in such cases is usually "Capacity exceeded in compiling
|
||||
case statement with composite selector type".
|
||||
|
||||
In addition, pattern bindings are supported. This is a mechanism
|
||||
for binding a name to a component of a matching value for use within
|
||||
@ -2280,7 +2287,8 @@ of GNAT specific extensions are recognized as follows:
|
||||
"is <identifier>". In the special case of a "box" component association,
|
||||
the identifier may instead be provided within the box. Either of these
|
||||
indicates that the given identifer denotes (a constant view of) the matching
|
||||
subcomponent of the case selector.
|
||||
subcomponent of the case selector. Binding is not yet supported for arrays
|
||||
or subcomponents thereof.
|
||||
|
||||
Consider this example (which uses type Rec from the previous example):
|
||||
|
||||
|
||||
@ -31,7 +31,6 @@ 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 Exp_Aggr; use Exp_Aggr;
|
||||
with Exp_Ch6; use Exp_Ch6;
|
||||
with Exp_Ch7; use Exp_Ch7;
|
||||
@ -3365,6 +3364,30 @@ package body Exp_Ch5 is
|
||||
renames Pattern_Match;
|
||||
-- convenient rename for recursive calls
|
||||
|
||||
function Indexed_Element (Idx : Pos) return Node_Id;
|
||||
-- Returns the Nth (well, ok, the Idxth) element of Object
|
||||
|
||||
---------------------
|
||||
-- Indexed_Element --
|
||||
---------------------
|
||||
|
||||
function Indexed_Element (Idx : Pos) return Node_Id is
|
||||
Obj_Index : constant Node_Id :=
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_First,
|
||||
Prefix => New_Copy_Tree (Object)),
|
||||
Right_Opnd =>
|
||||
Make_Integer_Literal (Loc, Idx - 1));
|
||||
begin
|
||||
return Make_Indexed_Component (Loc,
|
||||
Prefix => New_Copy_Tree (Object),
|
||||
Expressions => New_List (Obj_Index));
|
||||
end Indexed_Element;
|
||||
|
||||
-- Start of processing for Pattern_Match
|
||||
|
||||
begin
|
||||
if Choice_Index /= 0 and not Suppress_Choice_Index_Update then
|
||||
pragma Assert (Present (Choice_Index_Decl));
|
||||
@ -3399,16 +3422,51 @@ package body Exp_Ch5 is
|
||||
|
||||
case Nkind (Pattern) is
|
||||
when N_Aggregate =>
|
||||
return Result : Node_Id :=
|
||||
New_Occurrence_Of (Standard_True, Loc)
|
||||
do
|
||||
declare
|
||||
Result : Node_Id;
|
||||
begin
|
||||
if Is_Array_Type (Etype (Pattern)) then
|
||||
-- Calling Error_Msg_N during expansion is usually a
|
||||
-- mistake but is ok for an "unimplemented" message.
|
||||
Error_Msg_N
|
||||
("array-valued case choices unimplemented",
|
||||
Pattern);
|
||||
return;
|
||||
|
||||
-- Nonpositional aggregates currently unimplemented.
|
||||
-- We flag that case during analysis, so an assertion
|
||||
-- is ok here.
|
||||
--
|
||||
pragma Assert
|
||||
(not Is_Non_Empty_List
|
||||
(Component_Associations (Pattern)));
|
||||
|
||||
declare
|
||||
Agg_Length : constant Node_Id :=
|
||||
Make_Integer_Literal (Loc,
|
||||
List_Length (Expressions (Pattern)));
|
||||
|
||||
Obj_Length : constant Node_Id :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix => New_Copy_Tree (Object));
|
||||
begin
|
||||
Result := Make_Op_Eq (Loc,
|
||||
Left_Opnd => Obj_Length,
|
||||
Right_Opnd => Agg_Length);
|
||||
end;
|
||||
|
||||
declare
|
||||
Expr : Node_Id := First (Expressions (Pattern));
|
||||
Idx : Pos := 1;
|
||||
begin
|
||||
while Present (Expr) loop
|
||||
Result :=
|
||||
Make_And_Then (Loc,
|
||||
Left_Opnd => Result,
|
||||
Right_Opnd =>
|
||||
PM (Pattern => Expr,
|
||||
Object => Indexed_Element (Idx)));
|
||||
Next (Expr);
|
||||
Idx := Idx + 1;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
return Result;
|
||||
end if;
|
||||
|
||||
-- positional notation should have been normalized
|
||||
@ -3425,6 +3483,8 @@ package body Exp_Ch5 is
|
||||
Selector_Name => New_Occurrence_Of
|
||||
(Entity (Choice), Loc)));
|
||||
begin
|
||||
Result := New_Occurrence_Of (Standard_True, Loc);
|
||||
|
||||
while Present (Component_Assoc) loop
|
||||
Choice := First (Choices (Component_Assoc));
|
||||
while Present (Choice) loop
|
||||
@ -3530,27 +3590,82 @@ package body Exp_Ch5 is
|
||||
Next (Component_Assoc);
|
||||
end loop;
|
||||
end;
|
||||
return Result;
|
||||
end;
|
||||
|
||||
when N_String_Literal =>
|
||||
return Result : Node_Id do
|
||||
declare
|
||||
Char_Type : constant Entity_Id :=
|
||||
Root_Type (Component_Type (Etype (Pattern)));
|
||||
|
||||
-- If the component type is not a standard character
|
||||
-- type then this string lit should have already been
|
||||
-- transformed into an aggregate in
|
||||
-- Resolve_String_Literal.
|
||||
--
|
||||
pragma Assert (Is_Standard_Character_Type (Char_Type));
|
||||
|
||||
Str : constant String_Id := Strval (Pattern);
|
||||
Strlen : constant Nat := String_Length (Str);
|
||||
|
||||
Lit_Length : constant Node_Id :=
|
||||
Make_Integer_Literal (Loc, Strlen);
|
||||
|
||||
Obj_Length : constant Node_Id :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix => New_Copy_Tree (Object));
|
||||
begin
|
||||
Result := Make_Op_Eq (Loc,
|
||||
Left_Opnd => Obj_Length,
|
||||
Right_Opnd => Lit_Length);
|
||||
|
||||
for Idx in 1 .. Strlen loop
|
||||
declare
|
||||
C : constant Char_Code :=
|
||||
Get_String_Char (Str, Idx);
|
||||
Obj_Element : constant Node_Id :=
|
||||
Indexed_Element (Idx);
|
||||
Char_Lit : Node_Id;
|
||||
begin
|
||||
Set_Character_Literal_Name (C);
|
||||
Char_Lit :=
|
||||
Make_Character_Literal (Loc,
|
||||
Chars => Name_Find,
|
||||
Char_Literal_Value => UI_From_CC (C));
|
||||
|
||||
Result :=
|
||||
Make_And_Then (Loc,
|
||||
Left_Opnd => Result,
|
||||
Right_Opnd =>
|
||||
Make_Op_Eq (Loc,
|
||||
Left_Opnd => Obj_Element,
|
||||
Right_Opnd => Char_Lit));
|
||||
end;
|
||||
end loop;
|
||||
end;
|
||||
end return;
|
||||
|
||||
when N_Qualified_Expression =>
|
||||
-- Make a copy for one of the two uses of Object; the choice
|
||||
-- of where to use the original and where to use the copy
|
||||
-- is arbitrary.
|
||||
|
||||
return Make_And_Then (Loc,
|
||||
Left_Opnd => Make_In (Loc,
|
||||
Left_Opnd => New_Copy_Tree (Object),
|
||||
Right_Opnd => New_Copy_Tree (Subtype_Mark (Pattern))),
|
||||
Right_Opnd =>
|
||||
PM (Pattern => Expression (Pattern),
|
||||
Object => Object));
|
||||
Object => New_Copy_Tree (Object)));
|
||||
|
||||
when N_Identifier | N_Expanded_Name =>
|
||||
if Is_Type (Entity (Pattern)) then
|
||||
return Make_In (Loc,
|
||||
Left_Opnd => Object,
|
||||
Left_Opnd => New_Copy_Tree (Object),
|
||||
Right_Opnd => New_Occurrence_Of
|
||||
(Entity (Pattern), Loc));
|
||||
elsif Ekind (Entity (Pattern)) = E_Constant then
|
||||
return PM (Pattern =>
|
||||
Expression (Parent (Entity (Pattern))),
|
||||
Object => Object);
|
||||
end if;
|
||||
|
||||
when N_Others_Choice =>
|
||||
|
||||
@ -21,7 +21,7 @@
|
||||
|
||||
@copying
|
||||
@quotation
|
||||
GNAT Reference Manual , Jun 23, 2021
|
||||
GNAT Reference Manual , Aug 03, 2021
|
||||
|
||||
AdaCore
|
||||
|
||||
@ -3698,8 +3698,15 @@ 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 (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.
|
||||
subtypes or record types that meet the same restrictions.
|
||||
|
||||
Support for casing on arrays (and on records that contain arrays) is
|
||||
currently subject to some restrictions. Non-positional
|
||||
array aggregates are not supported as (or within) case choices. Likewise
|
||||
for array type and subtype names. The current implementation exceeds
|
||||
compile-time capacity limits in some annoyingly common scenarios; the
|
||||
message generated in such cases is usually “Capacity exceeded in compiling
|
||||
case statement with composite selector type”.
|
||||
|
||||
In addition, pattern bindings are supported. This is a mechanism
|
||||
for binding a name to a component of a matching value for use within
|
||||
@ -3708,7 +3715,8 @@ that occurs within a case choice, the expression may be followed by
|
||||
“is <identifier>”. In the special case of a “box” component association,
|
||||
the identifier may instead be provided within the box. Either of these
|
||||
indicates that the given identifer denotes (a constant view of) the matching
|
||||
subcomponent of the case selector.
|
||||
subcomponent of the case selector. Binding is not yet supported for arrays
|
||||
or subcomponents thereof.
|
||||
|
||||
Consider this example (which uses type Rec from the previous example):
|
||||
|
||||
|
||||
@ -44,6 +44,7 @@ with Stand; use Stand;
|
||||
with Sinfo; use Sinfo;
|
||||
with Sinfo.Nodes; use Sinfo.Nodes;
|
||||
with Sinfo.Utils; use Sinfo.Utils;
|
||||
with Stringt; use Stringt;
|
||||
with Table;
|
||||
with Tbuild; use Tbuild;
|
||||
with Uintp; use Uintp;
|
||||
@ -105,25 +106,70 @@ package body Sem_Case is
|
||||
|
||||
package Composite_Case_Ops is
|
||||
|
||||
function Choice_Count (Alternatives : List_Id) return Nat;
|
||||
-- The sum of the number of choices for each alternative in the given
|
||||
-- list.
|
||||
|
||||
function Scalar_Part_Count (Subtyp : Entity_Id) return Nat;
|
||||
-- Given the composite type Subtyp of a case selector, returns the
|
||||
-- number of scalar parts in an object of this type. This is the
|
||||
-- dimensionality of the associated Cartesian product space.
|
||||
|
||||
function Choice_Count (Alternatives : List_Id) return Nat;
|
||||
-- The sum of the number of choices for each alternative in the given
|
||||
-- list.
|
||||
package Array_Case_Ops is
|
||||
function Array_Choice_Length (Choice : Node_Id) return Nat;
|
||||
-- Given a choice expression of an array type, returns its length.
|
||||
|
||||
function Normalized_Case_Expr_Type
|
||||
(Case_Statement : Node_Id) return Entity_Id;
|
||||
-- Usually returns the Etype of the selector expression of the
|
||||
-- case statement. However, in the case of a constrained array
|
||||
-- subtype with a nonstatic constraint, returns the unconstrained
|
||||
-- array base type.
|
||||
|
||||
function Unconstrained_Array_Effective_Length
|
||||
(Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat;
|
||||
-- If the nominal subtype of the case selector is unconstrained,
|
||||
-- then use the length of the longest choice of the case statement.
|
||||
-- Components beyond that index value will not influence the case
|
||||
-- selection decision.
|
||||
|
||||
function Unconstrained_Array_Scalar_Part_Count
|
||||
(Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat;
|
||||
-- Same as Scalar_Part_Count except that the value used for the
|
||||
-- "length" of the array subtype being cased on is determined by
|
||||
-- calling Unconstrained_Array_Effective_Length.
|
||||
end Array_Case_Ops;
|
||||
|
||||
generic
|
||||
Case_Statement : Node_Id;
|
||||
package Choice_Analysis is
|
||||
|
||||
use Array_Case_Ops;
|
||||
|
||||
type Alternative_Id is
|
||||
new Int range 1 .. List_Length (Alternatives (Case_Statement));
|
||||
type Choice_Id is
|
||||
new Int range 1 .. Choice_Count (Alternatives (Case_Statement));
|
||||
|
||||
Case_Expr_Type : constant Entity_Id :=
|
||||
Normalized_Case_Expr_Type (Case_Statement);
|
||||
|
||||
Unconstrained_Array_Case : constant Boolean :=
|
||||
Is_Array_Type (Case_Expr_Type)
|
||||
and then not Is_Constrained (Case_Expr_Type);
|
||||
|
||||
-- If Unconstrained_Array_Case is True, choice lengths may differ:
|
||||
-- when "Aaa" | "Bb" | "C" | "" =>
|
||||
--
|
||||
-- Strictly speaking, the name "Unconstrained_Array_Case" is
|
||||
-- slightly imprecise; a subtype with a nonstatic constraint is
|
||||
-- also treated as unconstrained (see Normalize_Case_Expr_Type).
|
||||
|
||||
type Part_Id is new Int range
|
||||
1 .. Scalar_Part_Count (Etype (Expression (Case_Statement)));
|
||||
1 .. (if Unconstrained_Array_Case
|
||||
then Unconstrained_Array_Scalar_Part_Count
|
||||
(Case_Expr_Type, Case_Statement)
|
||||
else Scalar_Part_Count (Case_Expr_Type));
|
||||
|
||||
type Discrete_Range_Info is
|
||||
record
|
||||
@ -1118,6 +1164,21 @@ package body Sem_Case is
|
||||
return UI_To_Int (Len);
|
||||
end Static_Array_Length;
|
||||
|
||||
------------------
|
||||
-- Choice_Count --
|
||||
------------------
|
||||
|
||||
function Choice_Count (Alternatives : List_Id) return Nat is
|
||||
Result : Nat := 0;
|
||||
Alt : Node_Id := First (Alternatives);
|
||||
begin
|
||||
while Present (Alt) loop
|
||||
Result := Result + List_Length (Discrete_Choices (Alt));
|
||||
Next (Alt);
|
||||
end loop;
|
||||
return Result;
|
||||
end Choice_Count;
|
||||
|
||||
-----------------------
|
||||
-- Scalar_Part_Count --
|
||||
-----------------------
|
||||
@ -1147,20 +1208,118 @@ package body Sem_Case is
|
||||
end if;
|
||||
end Scalar_Part_Count;
|
||||
|
||||
------------------
|
||||
-- Choice_Count --
|
||||
------------------
|
||||
package body Array_Case_Ops is
|
||||
|
||||
function Choice_Count (Alternatives : List_Id) return Nat is
|
||||
Result : Nat := 0;
|
||||
Alt : Node_Id := First (Alternatives);
|
||||
begin
|
||||
while Present (Alt) loop
|
||||
Result := Result + List_Length (Discrete_Choices (Alt));
|
||||
Next (Alt);
|
||||
end loop;
|
||||
return Result;
|
||||
end Choice_Count;
|
||||
-------------------------
|
||||
-- Array_Choice_Length --
|
||||
-------------------------
|
||||
|
||||
function Array_Choice_Length (Choice : Node_Id) return Nat is
|
||||
begin
|
||||
case Nkind (Choice) is
|
||||
when N_String_Literal =>
|
||||
return String_Length (Strval (Choice));
|
||||
when N_Aggregate =>
|
||||
declare
|
||||
Bounds : constant Node_Id :=
|
||||
Aggregate_Bounds (Choice);
|
||||
pragma Assert (Is_OK_Static_Range (Bounds));
|
||||
Lo : constant Uint :=
|
||||
Expr_Value (Low_Bound (Bounds));
|
||||
Hi : constant Uint :=
|
||||
Expr_Value (High_Bound (Bounds));
|
||||
Len : constant Uint := (Hi - Lo) + 1;
|
||||
begin
|
||||
return UI_To_Int (Len);
|
||||
end;
|
||||
when N_Has_Entity =>
|
||||
if Present (Entity (Choice))
|
||||
and then Ekind (Entity (Choice)) = E_Constant
|
||||
then
|
||||
return Array_Choice_Length
|
||||
(Expression (Parent (Entity (Choice))));
|
||||
end if;
|
||||
when N_Others_Choice =>
|
||||
return 0;
|
||||
when others =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
if Nkind (Original_Node (Choice))
|
||||
in N_String_Literal | N_Aggregate
|
||||
then
|
||||
return Array_Choice_Length (Original_Node (Choice));
|
||||
end if;
|
||||
|
||||
Error_Msg_N ("Unsupported case choice", Choice);
|
||||
return 0;
|
||||
end Array_Choice_Length;
|
||||
|
||||
-------------------------------
|
||||
-- Normalized_Case_Expr_Type --
|
||||
-------------------------------
|
||||
|
||||
function Normalized_Case_Expr_Type
|
||||
(Case_Statement : Node_Id) return Entity_Id
|
||||
is
|
||||
Unnormalized : constant Entity_Id :=
|
||||
Etype (Expression (Case_Statement));
|
||||
begin
|
||||
if Is_Array_Type (Unnormalized)
|
||||
and then Is_Constrained (Unnormalized)
|
||||
and then not Has_Static_Array_Bounds (Unnormalized)
|
||||
then
|
||||
return Base_Type (Unnormalized);
|
||||
else
|
||||
return Unnormalized;
|
||||
end if;
|
||||
end Normalized_Case_Expr_Type;
|
||||
|
||||
------------------------------------------
|
||||
-- Unconstrained_Array_Effective_Length --
|
||||
------------------------------------------
|
||||
|
||||
function Unconstrained_Array_Effective_Length
|
||||
(Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat
|
||||
is
|
||||
pragma Assert (Is_Array_Type (Array_Type));
|
||||
-- Array_Type is otherwise unreferenced for now.
|
||||
|
||||
Result : Nat := 0;
|
||||
Alt : Node_Id := First (Alternatives (Case_Statement));
|
||||
begin
|
||||
while Present (Alt) loop
|
||||
declare
|
||||
Choice : Node_Id := First (Discrete_Choices (Alt));
|
||||
begin
|
||||
while Present (Choice) loop
|
||||
Result := Nat'Max (Result, Array_Choice_Length (Choice));
|
||||
Next (Choice);
|
||||
end loop;
|
||||
end;
|
||||
Next (Alt);
|
||||
end loop;
|
||||
|
||||
return Result;
|
||||
end Unconstrained_Array_Effective_Length;
|
||||
|
||||
-------------------------------------------
|
||||
-- Unconstrained_Array_Scalar_Part_Count --
|
||||
-------------------------------------------
|
||||
|
||||
function Unconstrained_Array_Scalar_Part_Count
|
||||
(Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat
|
||||
is
|
||||
begin
|
||||
-- Add one for the length, which is treated like a discriminant
|
||||
|
||||
return 1 + (Unconstrained_Array_Effective_Length
|
||||
(Array_Type => Array_Type,
|
||||
Case_Statement => Case_Statement)
|
||||
* Scalar_Part_Count (Component_Type (Array_Type)));
|
||||
end Unconstrained_Array_Scalar_Part_Count;
|
||||
|
||||
end Array_Case_Ops;
|
||||
|
||||
package body Choice_Analysis is
|
||||
|
||||
@ -1220,9 +1379,32 @@ package body Sem_Case is
|
||||
((Low => Expr_Value (Type_Low_Bound (Subtyp)),
|
||||
High => Expr_Value (Type_High_Bound (Subtyp))));
|
||||
elsif Is_Array_Type (Subtyp) then
|
||||
for I in 1 .. Static_Array_Length (Subtyp) loop
|
||||
Traverse_Discrete_Parts (Component_Type (Subtyp));
|
||||
end loop;
|
||||
declare
|
||||
Len : Nat;
|
||||
begin
|
||||
if Is_Constrained (Subtyp) then
|
||||
Len := Static_Array_Length (Subtyp);
|
||||
else
|
||||
-- Length will be treated like a discriminant;
|
||||
-- We could compute High more precisely as
|
||||
-- 1 + Index_Subtype'Last - Index_Subtype'First
|
||||
-- (we currently require that those bounds be
|
||||
-- static, so this is an option), but only downside of
|
||||
-- overshooting is if somebody wants to omit a
|
||||
-- "when others" choice and exhaustively cover all
|
||||
-- possibilities explicitly.
|
||||
Update_Result
|
||||
((Low => Uint_0,
|
||||
High => Uint_2 ** Uint_32));
|
||||
|
||||
Len := Unconstrained_Array_Effective_Length
|
||||
(Array_Type => Subtyp,
|
||||
Case_Statement => Case_Statement);
|
||||
end if;
|
||||
for I in 1 .. Len loop
|
||||
Traverse_Discrete_Parts (Component_Type (Subtyp));
|
||||
end loop;
|
||||
end;
|
||||
elsif Is_Record_Type (Subtyp) then
|
||||
if Has_Static_Discriminant_Constraint (Subtyp) then
|
||||
|
||||
@ -1274,7 +1456,7 @@ package body Sem_Case is
|
||||
end Traverse_Discrete_Parts;
|
||||
|
||||
begin
|
||||
Traverse_Discrete_Parts (Etype (Expression (Case_Statement)));
|
||||
Traverse_Discrete_Parts (Case_Expr_Type);
|
||||
pragma Assert (Done or else Serious_Errors_Detected > 0);
|
||||
return Result;
|
||||
end Component_Bounds_Info;
|
||||
@ -1531,6 +1713,19 @@ package body Sem_Case is
|
||||
& "choice not implemented", Expr);
|
||||
end if;
|
||||
|
||||
if not Unconstrained_Array_Case
|
||||
and then List_Length (Expressions (Expr))
|
||||
/= Nat (Part_Id'Last)
|
||||
then
|
||||
Error_Msg_N
|
||||
("Array aggregate length"
|
||||
& List_Length (Expressions (Expr))'Image
|
||||
& " does not match length of"
|
||||
& " statically constrained case selector"
|
||||
& Part_Id'Last'Image, Expr);
|
||||
return;
|
||||
end if;
|
||||
|
||||
declare
|
||||
Subexpr : Node_Id := First (Expressions (Expr));
|
||||
begin
|
||||
@ -1542,9 +1737,50 @@ package body Sem_Case is
|
||||
else
|
||||
raise Program_Error;
|
||||
end if;
|
||||
elsif Nkind (Expr) = N_String_Literal then
|
||||
if not Is_Array_Type (Etype (Expr)) then
|
||||
Error_Msg_N
|
||||
("User-defined string literal not allowed as/within"
|
||||
& "case choice", Expr);
|
||||
else
|
||||
declare
|
||||
Char_Type : constant Entity_Id :=
|
||||
Root_Type (Component_Type (Etype (Expr)));
|
||||
|
||||
-- If the component type is not a standard character
|
||||
-- type then this string lit should have already been
|
||||
-- transformed into an aggregate in
|
||||
-- Resolve_String_Literal.
|
||||
--
|
||||
pragma Assert (Is_Standard_Character_Type (Char_Type));
|
||||
|
||||
Str : constant String_Id := Strval (Expr);
|
||||
Strlen : constant Nat := String_Length (Str);
|
||||
Char_Val : Uint;
|
||||
begin
|
||||
if not Unconstrained_Array_Case
|
||||
and then Strlen /= Nat (Part_Id'Last)
|
||||
then
|
||||
Error_Msg_N
|
||||
("String literal length"
|
||||
& Strlen'Image
|
||||
& " does not match length of"
|
||||
& " statically constrained case selector"
|
||||
& Part_Id'Last'Image, Expr);
|
||||
return;
|
||||
end if;
|
||||
|
||||
for Idx in 1 .. Strlen loop
|
||||
Char_Val :=
|
||||
UI_From_CC (Get_String_Char (Str, Idx));
|
||||
Update_Result ((Low | High => Char_Val));
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
elsif Is_Discrete_Type (Etype (Expr)) then
|
||||
if Nkind (Expr) in N_Has_Entity and then
|
||||
Is_Type (Entity (Expr))
|
||||
if Nkind (Expr) in N_Has_Entity
|
||||
and then Present (Entity (Expr))
|
||||
and then Is_Type (Entity (Expr))
|
||||
then
|
||||
declare
|
||||
Low : constant Node_Id :=
|
||||
@ -1559,10 +1795,20 @@ package body Sem_Case is
|
||||
pragma Assert (Compile_Time_Known_Value (Expr));
|
||||
Update_Result ((Low | High => Expr_Value (Expr)));
|
||||
end if;
|
||||
elsif Nkind (Expr) in N_Has_Entity
|
||||
and then Present (Entity (Expr))
|
||||
and then Ekind (Entity (Expr)) = E_Constant
|
||||
then
|
||||
Traverse_Choice (Expression (Parent (Entity (Expr))));
|
||||
elsif Nkind (Original_Node (Expr))
|
||||
in N_Aggregate | N_String_Literal
|
||||
then
|
||||
Traverse_Choice (Original_Node (Expr));
|
||||
else
|
||||
Error_Msg_N
|
||||
("non-aggregate case choice subexpression which is not"
|
||||
& " of a discrete type not implemented", Expr);
|
||||
("non-aggregate case choice (or subexpression thereof)"
|
||||
& " that is not of a discrete type not implemented",
|
||||
Expr);
|
||||
end if;
|
||||
end Traverse_Choice;
|
||||
|
||||
@ -1572,8 +1818,26 @@ package body Sem_Case is
|
||||
if Nkind (Choice) = N_Others_Choice then
|
||||
return (Is_Others => True);
|
||||
end if;
|
||||
|
||||
if Unconstrained_Array_Case then
|
||||
-- Treat length like a discriminant
|
||||
Update_Result ((Low | High =>
|
||||
UI_From_Int (Array_Choice_Length (Choice))));
|
||||
end if;
|
||||
|
||||
Traverse_Choice (Choice);
|
||||
|
||||
if Unconstrained_Array_Case then
|
||||
-- This is somewhat tricky. Suppose we are casing on String,
|
||||
-- the longest choice in the case statement is length 10, and
|
||||
-- the choice we are looking at now is of length 6. We fill
|
||||
-- in the trailing 4 slots here.
|
||||
while Next_Part <= Part_Id'Last loop
|
||||
Update_Result_For_Full_Coverage
|
||||
(Comp_Type => Component_Type (Case_Expr_Type));
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Avoid returning uninitialized garbage in error case
|
||||
if Next_Part /= Part_Id'Last + 1 then
|
||||
pragma Assert (Serious_Errors_Detected > 0);
|
||||
@ -2098,6 +2362,12 @@ package body Sem_Case is
|
||||
Result := Result * Value_Index_Base (Uint_Sets.Size (Set));
|
||||
end loop;
|
||||
return Result;
|
||||
exception
|
||||
when Constraint_Error =>
|
||||
Error_Msg_N
|
||||
("Capacity exceeded in compiling case statement with"
|
||||
& " composite selector type", Case_Statement);
|
||||
raise;
|
||||
end Value_Index_Count;
|
||||
|
||||
Max_Value_Index : constant Value_Index_Base := Value_Index_Count;
|
||||
@ -3014,12 +3284,20 @@ package body Sem_Case is
|
||||
"an enumeration representation clause", N);
|
||||
end if;
|
||||
elsif Is_Array_Type (Subtyp) then
|
||||
pragma Assert (Is_Constrained (Subtyp));
|
||||
|
||||
if Number_Dimensions (Subtyp) /= 1 then
|
||||
Error_Msg_N
|
||||
("dimensionality of array type of case selector (or " &
|
||||
"subcomponent thereof) is greater than 1", N);
|
||||
|
||||
elsif not Is_Constrained (Subtyp) then
|
||||
if not Is_Static_Subtype
|
||||
(Etype (First_Index (Subtyp)))
|
||||
then
|
||||
Error_Msg_N
|
||||
("Unconstrained array subtype of case selector" &
|
||||
" has nonstatic index subtype", N);
|
||||
end if;
|
||||
|
||||
elsif not Is_OK_Static_Range (First_Index (Subtyp)) then
|
||||
Error_Msg_N
|
||||
("array subtype of case selector (or " &
|
||||
@ -3077,10 +3355,6 @@ package body Sem_Case is
|
||||
elsif Needs_Finalization (Subtyp) then
|
||||
Error_Msg_N ("case selector type requires finalization", N);
|
||||
|
||||
elsif Is_Array_Type (Subtyp) and not Is_Constrained (Subtyp) then
|
||||
Error_Msg_N
|
||||
("case selector subtype is unconstrained array subtype", N);
|
||||
|
||||
else
|
||||
Check_Component_Subtype (Subtyp);
|
||||
end if;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user