[Ada] Relax INOX restrictions when casing on composite value.

Message ID 20211025150925.GA346691@adacore.com
State Committed
Commit 1ddc39479b999841e0b0e994a47bf3cec8a4e54e
Headers
Series [Ada] Relax INOX restrictions when casing on composite value. |

Commit Message

Pierre-Marie de Rodat Oct. 25, 2021, 3:09 p.m. UTC
  When casing on a composite value, certain component types/subtypes were
previously disallowed. These included access types, real types,
nonstatic discrete subtypes, and others. This restriction is relaxed so
that such components are now allowed, but no non-box value may be
specified for such a component in a case choice.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.
  

Patch

diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
--- 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
--- 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
--- 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;