[gcc r12-6239] [Ada] Fix condition to build subtype for discriminated types

[gcc r12-6239] [Ada] Fix condition to build subtype for discriminated types

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:e2642e2b2c13b64d3d8453bc611fee20f73aa420

commit r12-6239-ge2642e2b2c13b64d3d8453bc611fee20f73aa420
Author: Etienne Servais <servais@adacore.com>
Date:   Mon Nov 15 17:32:40 2021 +0100

    [Ada] Fix condition to build subtype for discriminated types
    
    gcc/ada/
    
            * sem_ch3.adb (Analyze_Component_Declaration): Rework condition
            to build subtypes.
            (Analyze_Object_Declaration): Likewise.
            (Should_Build_Subtype): New.

Diff:
---
 gcc/ada/sem_ch3.adb | 105 +++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 88 insertions(+), 17 deletions(-)

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 6b25a6aee22..7fcde4dc87c 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -723,6 +723,16 @@ package body Sem_Ch3 is
    --  sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according
    --  to the setting of Opt.Default_SSO.
 
+   function Should_Build_Subtype (T : Entity_Id) return Boolean;
+   --  When analyzing components or object declarations, it is possible, in
+   --  some cases, to build subtypes for discriminated types. This is
+   --  worthwhile to avoid the backend allocating the maximum possible size for
+   --  objects of the type.
+   --  In particular, when T is limited, the discriminants and therefore the
+   --  size of an object of type T cannot change. Furthermore, if T is definite
+   --  with statically initialized defaulted discriminants, we are able and
+   --  want to build a constrained subtype of the right size.
+
    procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
    --  Create a new signed integer entity, and apply the constraint to obtain
    --  the required first named subtype of this type.
@@ -2203,17 +2213,9 @@ package body Sem_Ch3 is
          end if;
       end if;
 
-      --  If the component is an unconstrained task or protected type with
-      --  discriminants, the component and the enclosing record are limited
-      --  and the component is constrained by its default values. Compute
-      --  its actual subtype, else it may be allocated the maximum size by
-      --  the backend, and possibly overflow.
+      --  When possible, build the default subtype
 
-      if Is_Concurrent_Type (T)
-        and then not Is_Constrained (T)
-        and then Has_Discriminants (T)
-        and then not Has_Discriminants (Current_Scope)
-      then
+      if Should_Build_Subtype (T) then
          declare
             Act_T : constant Entity_Id := Build_Default_Subtype (T, N);
 
@@ -4799,14 +4801,9 @@ package body Sem_Ch3 is
             Apply_Length_Check (E, T);
          end if;
 
-      --  If the type is limited unconstrained with defaulted discriminants and
-      --  there is no expression, then the object is constrained by the
-      --  defaults, so it is worthwhile building the corresponding subtype.
+      --  When possible, build the default subtype
 
-      elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T))
-        and then not Is_Constrained (T)
-        and then Has_Discriminants (T)
-      then
+      elsif Should_Build_Subtype (T) then
          if No (E) then
             Act_T := Build_Default_Subtype (T, N);
          else
@@ -22879,6 +22876,80 @@ package body Sem_Ch3 is
       end if;
    end Set_Stored_Constraint_From_Discriminant_Constraint;
 
+   --------------------------
+   -- Should_Build_Subtype --
+   --------------------------
+
+   function Should_Build_Subtype (T : Entity_Id) return Boolean is
+
+      function Default_Discriminant_Values_Known_At_Compile_Time
+         (T : Entity_Id) return Boolean;
+         --  For an unconstrained type T, return False if the given type has a
+         --  discriminant with default value not known at compile time. Return
+         --  True otherwise.
+
+      ---------------------------------------------------------
+      -- Default_Discriminant_Values_Known_At_Compile_Time --
+      ---------------------------------------------------------
+
+      function Default_Discriminant_Values_Known_At_Compile_Time
+         (T : Entity_Id) return Boolean
+      is
+         Discr : Entity_Id;
+         DDV : Node_Id;
+
+      begin
+
+         --  If the type has no discriminant, we know them all at compile time
+
+         if not Has_Discriminants (T) then
+            return True;
+         end if;
+
+         --  The type has discriminants, check that none of them has a default
+         --  value not known at compile time.
+
+         Discr := First_Discriminant (T);
+
+         while Present (Discr) loop
+            DDV := Discriminant_Default_Value (Discr);
+
+            if Present (DDV) and then not Compile_Time_Known_Value (DDV) then
+               return False;
+            end if;
+
+            Next_Discriminant (Discr);
+         end loop;
+
+         return True;
+      end Default_Discriminant_Values_Known_At_Compile_Time;
+
+   --  Start of processing for Should_Build_Subtype
+
+   begin
+
+      if Is_Constrained (T) then
+
+         --  We won't build a new subtype if T is constrained
+
+         return False;
+      end if;
+
+      if not Default_Discriminant_Values_Known_At_Compile_Time (T) then
+
+         --  This is a special case of definite subtypes. To allocate a
+         --  specific size to the subtype, we need to know the value at compile
+         --  time. This might not be the case if the default value is the
+         --  result of a function. In that case, the object might be definite
+         --  and limited but the needed size might not be statically known or
+         --  too tricky to obtain. In that case, we will not build the subtype.
+
+         return False;
+      end if;
+
+      return Is_Definite_Subtype (T) and then Is_Limited_View (T);
+   end Should_Build_Subtype;
+
    -------------------------------------
    -- Signed_Integer_Type_Declaration --
    -------------------------------------