From: Steve Baird Date: Fri, 15 Oct 2021 22:23:34 +0000 (-0700) Subject: [Ada] Relax INOX restrictions when casing on composite value. X-Git-Tag: basepoints/gcc-13~3631 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=1ddc39479b999841e0b0e994a47bf3cec8a4e54e;p=thirdparty%2Fgcc.git [Ada] Relax INOX restrictions when casing on composite value. gcc/ada/ * sem_case.adb (Composite_Case_Ops.Box_Value_Required): A new function which takes a component type and returns a Boolean. Returns True for the cases which were formerly forbidden as components (these checks were formerly performed in the now-deleted procedure Check_Composite_Case_Selector.Check_Component_Subtype). (Composite_Case_Ops.Normalized_Case_Expr_Type): Hoist this function out of the Array_Case_Ops package because it has been generalized to also do the analogous thing in the case of a discriminated type. (Composite_Case_Ops.Scalar_Part_Count): Return 0 if Box_Value_Required returns True for the given type/subtype. (Composite_Case_Ops.Choice_Analysis.Choice_Analysis.Component_Bounds_Info. Traverse_Discrete_Parts): Return without doing anything if Box_Value_Required returns True for the given type/subtype. (Composite_Case_Ops.Choice_Analysis.Parse_Choice.Traverse_Choice): If Box_Value_Required yields True for a given component type, then check that the value of that component in a choice expression is indeed a box (in which case the component is ignored). * doc/gnat_rm/implementation_defined_pragmas.rst: Update documentation. * gnat_rm.texi: Regenerate. --- diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 0375982be611..768dd668e57b 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2268,9 +2268,24 @@ 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 (but possibly discriminated) - record type, all of whose subcomponent subtypes are either static discrete - subtypes or record types that meet the same restrictions. + selector shall be an array or record type that is neither limited + class-wide. + + If a subcomponent's subtype does not meet certain restrictions, then + the only value that can be specified for that subcomponent in a case + choice expression is a "box" component association (which matches all + possible values for the subcomponent). This restriction applies if + + - the component subtype is not a record, array, or discrete type; or + + - the component subtype is subject to a non-static constraint or + has a predicate; or + + - the component type is an enumeration type that is subject to an + enumeration representation clause; or + + - the component type is a multidimensional array type or an + array type with a nonstatic index subtype. Support for casing on arrays (and on records that contain arrays) is currently subject to some restrictions. Non-positional diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 0a962ee8bdc2..129da895e09f 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Sep 28, 2021 +GNAT Reference Manual , Oct 25, 2021 AdaCore @@ -3707,9 +3707,32 @@ 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 (but possibly discriminated) -record type, all of whose subcomponent subtypes are either static discrete -subtypes or record types that meet the same restrictions. +selector shall be an array or record type that is neither limited +class-wide. + +If a subcomponent’s subtype does not meet certain restrictions, then +the only value that can be specified for that subcomponent in a case +choice expression is a “box” component association (which matches all +possible values for the subcomponent). This restriction applies if + + +@itemize - + +@item +the component subtype is not a record, array, or discrete type; or + +@item +the component subtype is subject to a non-static constraint or +has a predicate; or + +@item +the component type is an enumeration type that is subject to an +enumeration representation clause; or + +@item +the component type is a multidimensional array type or an +array type with a nonstatic index subtype. +@end itemize Support for casing on arrays (and on records that contain arrays) is currently subject to some restrictions. Non-positional diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 31f14d5353df..1bd267016d96 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -106,10 +106,26 @@ package body Sem_Case is package Composite_Case_Ops is + function Box_Value_Required (Subtyp : Entity_Id) return Boolean; + -- If result is True, then the only allowed value (in a choice + -- aggregate) for a component of this (sub)type is a box. This rule + -- means that such a component can be ignored in case alternative + -- selection. This in turn implies that it is ok if the component + -- type doesn't meet the usual restrictions, such as not being an + -- access/task/protected type, since nobody is going to look + -- at it. + function Choice_Count (Alternatives : List_Id) return Nat; -- The sum of the number of choices for each alternative in the given -- list. + 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 composite + -- subtype with a nonstatic constraint, returns the unconstrained + -- base type. + 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 @@ -119,13 +135,6 @@ package body Sem_Case 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, @@ -1164,6 +1173,54 @@ package body Sem_Case is return UI_To_Int (Len); end Static_Array_Length; + ------------------------ + -- Box_Value_Required -- + ------------------------ + + function Box_Value_Required (Subtyp : Entity_Id) return Boolean is + -- Some of these restrictions will be relaxed eventually, but best + -- to initially err in the direction of being too restrictive. + begin + if Has_Predicates (Subtyp) then + return True; + elsif Is_Discrete_Type (Subtyp) then + if not Is_Static_Subtype (Subtyp) then + return True; + elsif Is_Enumeration_Type (Subtyp) + and then Has_Enumeration_Rep_Clause (Subtyp) + -- Maybe enumeration rep clauses can be ignored here? + then + return True; + end if; + elsif Is_Array_Type (Subtyp) then + if Number_Dimensions (Subtyp) /= 1 then + return True; + elsif not Is_Constrained (Subtyp) then + if not Is_Static_Subtype (Etype (First_Index (Subtyp))) then + return True; + end if; + elsif not Is_OK_Static_Range (First_Index (Subtyp)) then + return True; + end if; + elsif Is_Record_Type (Subtyp) then + if Has_Discriminants (Subtyp) + and then Is_Constrained (Subtyp) + and then not Has_Static_Discriminant_Constraint (Subtyp) + then + -- Perhaps treat differently the case where Subtyp is the + -- subtype of the top-level selector expression, as opposed + -- to the subtype of some subcomponent thereof. + return True; + end if; + else + -- Return True for any type that is not a discrete type, + -- a record type, or an array type. + return True; + end if; + + return False; + end Box_Value_Required; + ------------------ -- Choice_Count -- ------------------ @@ -1179,13 +1236,45 @@ package body Sem_Case is return Result; end Choice_Count; + ------------------------------- + -- 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)); + + Is_Dynamically_Constrained_Array : constant Boolean := + Is_Array_Type (Unnormalized) + and then Is_Constrained (Unnormalized) + and then not Has_Static_Array_Bounds (Unnormalized); + + Is_Dynamically_Constrained_Record : constant Boolean := + Is_Record_Type (Unnormalized) + and then Has_Discriminants (Unnormalized) + and then Is_Constrained (Unnormalized) + and then not Has_Static_Discriminant_Constraint (Unnormalized); + begin + if Is_Dynamically_Constrained_Array + or Is_Dynamically_Constrained_Record + then + return Base_Type (Unnormalized); + else + return Unnormalized; + end if; + end Normalized_Case_Expr_Type; + ----------------------- -- Scalar_Part_Count -- ----------------------- function Scalar_Part_Count (Subtyp : Entity_Id) return Nat is begin - if Is_Scalar_Type (Subtyp) then + if Box_Value_Required (Subtyp) then + return 0; -- component does not participate in case selection + elsif Is_Scalar_Type (Subtyp) then return 1; elsif Is_Array_Type (Subtyp) then return Static_Array_Length (Subtyp) @@ -1203,8 +1292,8 @@ package body Sem_Case is return Result; end; else - pragma Assert (False); - raise Program_Error; + pragma Assert (Serious_Errors_Detected > 0); + return 0; end if; end Scalar_Part_Count; @@ -1255,29 +1344,9 @@ package body Sem_Case is 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 @@ -1374,6 +1443,10 @@ package body Sem_Case is procedure Traverse_Discrete_Parts (Subtyp : Entity_Id) is begin + if Box_Value_Required (Subtyp) then + return; + end if; + if Is_Discrete_Type (Subtyp) then Update_Result ((Low => Expr_Value (Type_Low_Bound (Subtyp)), @@ -1668,13 +1741,32 @@ package body Sem_Case is 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_Assoc)); - end if; + declare + Comp_Type : constant Entity_Id := + Etype (First (Choices (Comp_Assoc))); + begin + if Box_Value_Required (Comp_Type) then + -- This component is not allowed to + -- influence which alternative is + -- chosen; case choice must be box. + -- + -- For example, component might be + -- of a real type or of an access type + -- or of a non-static discrete subtype. + if not Box_Present (Comp_Assoc) then + Error_Msg_N + ("Non-box case choice component value" & + " of unsupported type/subtype", + Expression (Comp_Assoc)); + end if; + elsif Box_Present (Comp_Assoc) then + -- Box matches all values + Update_Result_For_Full_Coverage + (Etype (First (Choices (Comp_Assoc)))); + else + Traverse_Choice (Expression (Comp_Assoc)); + end if; + end; if Binding_Chars (Comp_Assoc) /= No_Name then @@ -1702,9 +1794,19 @@ package body Sem_Case is Next_Component_Or_Discriminant (Comp_From_Type); end loop; - pragma Assert - (Nat (Next_Part - Saved_Next_Part) - = Scalar_Part_Count (Etype (Expr))); + declare + Expr_Type : Entity_Id := Etype (Expr); + begin + if Has_Discriminants (Expr_Type) then + -- Avoid nonstatic choice expr types, + -- for which Scalar_Part_Count returns 0. + Expr_Type := Base_Type (Expr_Type); + end if; + + pragma Assert + (Nat (Next_Part - Saved_Next_Part) + = Scalar_Part_Count (Expr_Type)); + end; end; elsif Is_Array_Type (Etype (Expr)) then if Is_Non_Empty_List (Component_Associations (Expr)) then @@ -3256,108 +3358,14 @@ package body Sem_Case is ----------------------------------- procedure Check_Composite_Case_Selector is - -- Some of these restrictions will be relaxed eventually, but best - -- to initially err in the direction of being too restrictive. - - procedure Check_Component_Subtype (Subtyp : Entity_Id); - -- Recursively traverse subcomponent types to perform checks. - - ----------------------------- - -- Check_Component_Subtype -- - ----------------------------- - - procedure Check_Component_Subtype (Subtyp : Entity_Id) is - begin - if Has_Predicates (Subtyp) then - Error_Msg_N - ("subtype of case selector (or subcomponent thereof) " & - "has predicate", N); - elsif Is_Discrete_Type (Subtyp) then - if not Is_Static_Subtype (Subtyp) then - Error_Msg_N - ("discrete subtype of selector subcomponent is not " & - "a static subtype", N); - elsif Is_Enumeration_Type (Subtyp) - and then Has_Enumeration_Rep_Clause (Subtyp) - then - Error_Msg_N - ("enumeration type of selector subcomponent has " & - "an enumeration representation clause", N); - end if; - elsif Is_Array_Type (Subtyp) then - 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 " & - "subcomponent thereof) has nonstatic constraint", N); - end if; - Check_Component_Subtype (Component_Type (Subtyp)); - elsif Is_Record_Type (Subtyp) then - - 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 " & - "not a discrete type, a record type, or an array type", - N); - end if; - end Check_Component_Subtype; - begin if not Is_Composite_Type (Subtyp) then Error_Msg_N ("case selector type neither discrete nor composite", N); - elsif Is_Limited_Type (Subtyp) then Error_Msg_N ("case selector type is limited", N); - elsif Is_Class_Wide_Type (Subtyp) then Error_Msg_N ("case selector type is class-wide", N); - - elsif Needs_Finalization (Subtyp) then - Error_Msg_N ("case selector type requires finalization", N); - - else - Check_Component_Subtype (Subtyp); end if; end Check_Composite_Case_Selector;