FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
gcc/ada/

	* exp_ch5.adb (Expand_General_Case_Statement): Add new function
	Else_Statements to handle the case of invalid data analogously
	to how it is handled when casing on a discrete value.
	* sem_case.adb (Has_Static_Discriminant_Constraint): A new
	Boolean-valued function.
	(Composite_Case_Ops.Scalar_Part_Count): Include discriminants
	when traversing components.
	(Composite_Case_Ops.Choice_Analysis.Traverse_Discrete_Parts):
	Include discriminants when traversing components; the component
	range for a constrained discriminant is a single value.
	(Composite_Case_Ops.Choice_Analysis.Parse_Choice): Eliminate
	Done variable and modify how Next_Part is computed so that it is
	always correct (as opposed to being incorrect when Done is
	True).  This includes changes in Update_Result (a local
	procedure).  Add new local procedure
	Update_Result_For_Box_Component and call it not just for box
	components but also for "missing" components (components
	associated with an inactive variant).
	(Check_Choices.Check_Composite_Case_Selector.Check_Component_Subtype):
	Instead of disallowing all discriminated component types, allow
	those that are unconstrained or statically constrained. Check
	discriminant subtypes along with other component subtypes.
	* 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-06-10 11:20:27 -07:00 • committed by Pierre-Marie de Rodat
parent 765ca22b17
commit e4de29f467
4 changed files with 242 additions and 94 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
View file

@ -2237,8 +2237,7 @@ of GNAT specific extensions are recognized as follows:
some restrictions (described below). Aggregate syntax is used for choices some restrictions (described below). Aggregate syntax is used for choices
of such a case statement; however, in cases where a "normal" aggregate would 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 require a discrete value, a discrete subtype may be used instead; box
notation can also be used to match all values (but currently only notation can also be used to match all values.
for discrete subcomponents).
Consider this example: 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 set shall be a proper subset of the second (and the later alternative
will not be executed if the earlier alternative "matches"). All possible will not be executed if the earlier alternative "matches"). All possible
values of the composite type shall be covered. The composite type of the values of the composite type shall be covered. The composite type of the
selector shall be a nonlimited untagged undiscriminated record type, all selector shall be a nonlimited untagged (but possibly discriminated)
of whose subcomponent subtypes are either static discrete subtypes or record type, all of whose subcomponent subtypes are either static discrete
record types that meet the same restrictions. Support for arrays is subtypes or record types that meet the same restrictions. Support for arrays
planned, but not yet implemented. is planned, but not yet implemented.
In addition, pattern bindings are supported. This is a mechanism In addition, pattern bindings are supported. This is a mechanism
for binding a name to a component of a matching value for use within for binding a name to a component of a matching value for use within

27
gcc/ada/exp_ch5.adb
View file

@ -3641,16 +3641,37 @@ package body Exp_Ch5 is
return Result; return Result;
end Elsif_Parts; 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 := If_Stmt : constant Node_Id :=
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => Top_Level_Pattern_Match_Condition (First_Alt), Condition => Top_Level_Pattern_Match_Condition (First_Alt),
Then_Statements => Statements (First_Alt), Then_Statements => Statements (First_Alt),
Elsif_Parts => Elsif_Parts); Elsif_Parts => Elsif_Parts,
-- Do we want an implicit "else raise Program_Error" here??? Else_Statements => Else_Statements);
-- Perhaps only if Exception-related restrictions are not in effect.
Declarations : constant List_Id := New_List (Selector_Decl); Declarations : constant List_Id := New_List (Selector_Decl);
-- Start of processing for Expand_General_Case_Statment
begin begin
if Present (Choice_Index_Decl) then if Present (Choice_Index_Decl) then
Append_To (Declarations, Choice_Index_Decl); Append_To (Declarations, Choice_Index_Decl);

11
gcc/ada/gnat_rm.texi
View file

@ -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 some restrictions (described below). Aggregate syntax is used for choices
of such a case statement; however, in cases where a “normal” aggregate would 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 require a discrete value, a discrete subtype may be used instead; box
notation can also be used to match all values (but currently only notation can also be used to match all values.
for discrete subcomponents).
Consider this example: 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 set shall be a proper subset of the second (and the later alternative
will not be executed if the earlier alternative “matches”). All possible will not be executed if the earlier alternative “matches”). All possible
values of the composite type shall be covered. The composite type of the values of the composite type shall be covered. The composite type of the
selector shall be a nonlimited untagged undiscriminated record type, all selector shall be a nonlimited untagged (but possibly discriminated)
of whose subcomponent subtypes are either static discrete subtypes or record type, all of whose subcomponent subtypes are either static discrete
record types that meet the same restrictions. Support for arrays is subtypes or record types that meet the same restrictions. Support for arrays
planned, but not yet implemented. is planned, but not yet implemented.
In addition, pattern bindings are supported. This is a mechanism In addition, pattern bindings are supported. This is a mechanism
for binding a name to a component of a matching value for use within for binding a name to a component of a matching value for use within

287
gcc/ada/sem_case.adb
View file

@ -27,6 +27,7 @@ with Atree; use Atree;
with Einfo; use Einfo; with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities; with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils; with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Namet; use Namet; with Namet; use Namet;
with Nlists; use Nlists; 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 -- 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. -- the alternatives must cover its base type.
function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
-- Given a Pos value of enumeration type Ctype, returns the name -- Given a Pos value of enumeration type Ctype, returns the name
-- ID of an appropriate string to be used in error message output. -- 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 package Composite_Case_Ops is
function Scalar_Part_Count (Subtyp : Entity_Id) return Nat; 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. -- is posted at location C. Caller sets Error_Msg_Sloc for xx.
procedure Explain_Non_Static_Bound; 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 -- 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; function Lt_Choice (C1, C2 : Natural) return Boolean;
-- Comparison routine for comparing Choice_Table entries. Use the lower -- Comparison routine for comparing Choice_Table entries. Use the lower
@ -734,7 +740,7 @@ package body Sem_Case is
("bounds of & are not static, " ("bounds of & are not static, "
& "alternatives must cover base type!", Expr, Expr); & "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. -- or else the subtype may be at fault.
elsif Is_Entity_Name (Expr) then elsif Is_Entity_Name (Expr) then
@ -1124,14 +1130,14 @@ package body Sem_Case is
return Static_Array_Length (Subtyp) return Static_Array_Length (Subtyp)
* Scalar_Part_Count (Component_Type (Subtyp)); * Scalar_Part_Count (Component_Type (Subtyp));
elsif Is_Record_Type (Subtyp) then elsif Is_Record_Type (Subtyp) then
pragma Assert (not Has_Discriminants (Subtyp));
declare declare
Result : Nat := 0; Result : Nat := 0;
Comp : Entity_Id := First_Component (Subtyp); Comp : Entity_Id := First_Component_Or_Discriminant
(Base_Type (Subtyp));
begin begin
while Present (Comp) loop while Present (Comp) loop
Result := Result + Scalar_Part_Count (Etype (Comp)); Result := Result + Scalar_Part_Count (Etype (Comp));
Next_Component (Comp); Next_Component_Or_Discriminant (Comp);
end loop; end loop;
return Result; return Result;
end; end;
@ -1218,15 +1224,47 @@ package body Sem_Case is
Traverse_Discrete_Parts (Component_Type (Subtyp)); Traverse_Discrete_Parts (Component_Type (Subtyp));
end loop; end loop;
elsif Is_Record_Type (Subtyp) then elsif Is_Record_Type (Subtyp) then
pragma Assert (not Has_Discriminants (Subtyp)); if Has_Static_Discriminant_Constraint (Subtyp) then
declare
Comp : Entity_Id := First_Component (Subtyp); -- The component range for a constrained discriminant
begin -- is a single value.
while Present (Comp) loop declare
Traverse_Discrete_Parts (Etype (Comp)); Dc_Elmt : Elmt_Id :=
Next_Component (Comp); First_Elmt (Discriminant_Constraint (Subtyp));
end loop; Dc_Value : Uint;
end; 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 else
Error_Msg_N Error_Msg_N
("case selector type having a non-discrete non-record" ("case selector type having a non-discrete non-record"
@ -1234,6 +1272,7 @@ package body Sem_Case is
Expression (Case_Statement)); Expression (Case_Statement));
end if; end if;
end Traverse_Discrete_Parts; end Traverse_Discrete_Parts;
begin begin
Traverse_Discrete_Parts (Etype (Expression (Case_Statement))); Traverse_Discrete_Parts (Etype (Expression (Case_Statement)));
pragma Assert (Done or else Serious_Errors_Detected > 0); pragma Assert (Done or else Serious_Errors_Detected > 0);
@ -1338,12 +1377,23 @@ package body Sem_Case is
is is
Result : Choice_Range_Info (Is_Others => False); Result : Choice_Range_Info (Is_Others => False);
Ranges : Composite_Range_Info renames Result.Ranges; Ranges : Composite_Range_Info renames Result.Ranges;
Next_Part : Part_Id := 1; Next_Part : Part_Id'Base range 1 .. Part_Id'Last + 1 := 1;
Done : Boolean := False;
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); procedure Update_Result (Discrete_Range : Discrete_Range_Info);
-- Initialize first remaining uninitialized element of Ranges. -- 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 -- -- Update_Result --
@ -1351,19 +1401,21 @@ package body Sem_Case is
procedure Update_Result (Discrete_Range : Discrete_Range_Info) is procedure Update_Result (Discrete_Range : Discrete_Range_Info) is
begin begin
pragma Assert (not Done);
Ranges (Next_Part) := Discrete_Range; Ranges (Next_Part) := Discrete_Range;
if Next_Part = Part_Id'Last then Next_Part := Next_Part + 1;
Done := True;
else
Next_Part := Next_Part + 1;
end if;
end Update_Result; end Update_Result;
procedure Traverse_Choice (Expr : Node_Id); -------------------------------------
-- Traverse a legal choice expression, looking for -- Update_Result_For_Full_Coverage --
-- values/ranges of discrete parts. Call Update_Result -------------------------------------
-- for each.
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 -- -- Traverse_Choice --
@ -1388,52 +1440,89 @@ package body Sem_Case is
Refresh_Binding_Info (Aggr => Expr); Refresh_Binding_Info (Aggr => Expr);
declare declare
Comp : Node_Id := Comp_Assoc : Node_Id :=
First (Component_Associations (Expr)); First (Component_Associations (Expr));
-- Ok to assume that components are in order here? -- Aggregate has been normalized (components in
begin -- order, only one component per choice, etc.).
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.
Error_Msg_N Comp_From_Type : Node_Id :=
("box values for nondiscrete pattern " First_Component_Or_Discriminant
& "subcomponents unimplemented", Comp); (Base_Type (Etype (Expr)));
Saved_Next_Part : constant Part_Id := Next_Part;
begin
while Present (Comp_Assoc) loop
pragma Assert
(List_Length (Choices (Comp_Assoc)) = 1);
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 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 else
Traverse_Choice (Expression (Comp)); Traverse_Choice (Expression (Comp_Assoc));
end if; end if;
if Binding_Chars (Comp) /= No_Name if Binding_Chars (Comp_Assoc) /= No_Name
then then
Case_Bindings.Note_Binding Case_Bindings.Note_Binding
(Comp_Assoc => Comp, (Comp_Assoc => Comp_Assoc,
Choice => Choice, Choice => Choice,
Alt => Alt); Alt => Alt);
end if; end if;
Next (Comp); Next (Comp_Assoc);
end loop; 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; end;
elsif Is_Array_Type (Etype (Expr)) then elsif Is_Array_Type (Etype (Expr)) then
if Is_Non_Empty_List (Component_Associations (Expr)) then if Is_Non_Empty_List (Component_Associations (Expr)) then
@ -1477,6 +1566,8 @@ package body Sem_Case is
end if; end if;
end Traverse_Choice; end Traverse_Choice;
-- Start of processing for Parse_Choice
begin begin
if Nkind (Choice) = N_Others_Choice then if Nkind (Choice) = N_Others_Choice then
return (Is_Others => True); return (Is_Others => True);
@ -1484,7 +1575,7 @@ package body Sem_Case is
Traverse_Choice (Choice); Traverse_Choice (Choice);
-- Avoid returning uninitialized garbage in error case -- 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); pragma Assert (Serious_Errors_Detected > 0);
Result.Ranges := (others => (Low => Uint_1, High => Uint_0)); Result.Ranges := (others => (Low => Uint_1, High => Uint_0));
end if; end if;
@ -2936,20 +3027,34 @@ package body Sem_Case is
end if; end if;
Check_Component_Subtype (Component_Type (Subtyp)); Check_Component_Subtype (Component_Type (Subtyp));
elsif Is_Record_Type (Subtyp) then elsif Is_Record_Type (Subtyp) then
if Has_Discriminants (Subtyp) then
Error_Msg_N if Has_Discriminants (Subtyp)
("type of case selector (or subcomponent thereof) " & and then Is_Constrained (Subtyp)
"is discriminated", N); and then not Has_Static_Discriminant_Constraint (Subtyp)
else then
declare -- We are only disallowing nonstatic constraints for
Comp : Entity_Id := First_Component (Subtyp); -- subcomponent subtypes, not for the subtype of the
begin -- expression we are casing on. This test could be
while Present (Comp) loop -- implemented via an Is_Recursive_Call parameter if
Check_Component_Subtype (Etype (Comp)); -- that seems preferable.
Next_Component (Comp);
end loop; if Subtyp /= Check_Choices.Subtyp then
end; Error_Msg_N
("constrained discriminated subtype of case " &
"selector subcomponent has nonstatic " &
"constraint", N);
end if;
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 else
Error_Msg_N Error_Msg_N
("type of case selector (or subcomponent thereof) is " & ("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 -- bounds of its base type to determine the values covered by the
-- discrete choices. -- 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. -- range of the base type must be covered as well.
if Is_OK_Static_Subtype (Subtyp) then if Is_OK_Static_Subtype (Subtyp) then
@ -3075,7 +3180,7 @@ package body Sem_Case is
end if; end if;
-- Obtain static bounds of type, unless this is a generic formal -- 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)) if not Is_Generic_Type (Root_Type (Bounds_Type))
or else Ekind (Bounds_Type) /= E_Enumeration_Type or else Ekind (Bounds_Type) /= E_Enumeration_Type
@ -3137,7 +3242,7 @@ package body Sem_Case is
if Has_Predicates (E) then 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) if not Is_Discrete_Type (E)
or else not Has_Static_Predicate (E) or else not Has_Static_Predicate (E)
@ -3298,6 +3403,30 @@ package body Sem_Case is
end Generic_Check_Choices; 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 -- -- Is_Case_Choice_Pattern --
---------------------------- ----------------------------