OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Add -gnatX support for casing on array values

Browse Source 
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 2021-07-09 12:04:09 -07:00 committed by Pierre-Marie de Rodat
parent c5ff859dc0
commit ec813d06f7
4 changed files with 459 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
View File

@ -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):

147
gcc/ada/exp_ch5.adb
View File

@ -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 =>

16
gcc/ada/gnat_rm.texi
View File

@ -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):

320
gcc/ada/sem_case.adb
View File

@ -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
-------------------------
-- 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.
function Choice_Count (Alternatives : List_Id) return Nat is
Result : Nat := 0;
Alt : Node_Id := First (Alternatives);
Alt : Node_Id := First (Alternatives (Case_Statement));
begin
while Present (Alt) loop
Result := Result + List_Length (Discrete_Choices (Alt));
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 Choice_Count;
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
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;