From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id 6B9BE3987030; Fri, 9 Jul 2021 12:39:34 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 6B9BE3987030 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-2212] [Ada] Add -gnatX support for casing on discriminated values X-Act-Checkin: gcc X-Git-Author: Steve Baird X-Git-Refname: refs/heads/master X-Git-Oldrev: 765ca22b1792b613d2801b6d2ef9986e18bba3ab X-Git-Newrev: e4de29f4677e81e71c60eb2b9f247eaa12ea1353 Message-Id: <20210709123934.6B9BE3987030@sourceware.org> Date: Fri, 9 Jul 2021 12:39:34 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Fri, 09 Jul 2021 12:39:34 -0000 https://gcc.gnu.org/g:e4de29f4677e81e71c60eb2b9f247eaa12ea1353 commit r12-2212-ge4de29f4677e81e71c60eb2b9f247eaa12ea1353 Author: Steve Baird Date: Thu Jun 10 11:20:27 2021 -0700 [Ada] Add -gnatX support for casing on discriminated values 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. Diff: --- .../doc/gnat_rm/implementation_defined_pragmas.rst | 11 +- gcc/ada/exp_ch5.adb | 27 +- gcc/ada/gnat_rm.texi | 11 +- gcc/ada/sem_case.adb | 285 +++++++++++++++------ 4 files changed, 241 insertions(+), 93 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index c82658d0657..6c81ca7db61 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -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 diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 2559e56b90a..8ac96629025 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index c0ccfe4b2cf..349586edead 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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 diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 9ff256451fa..7d08da5af64 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -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 -- ----------------------------