From: Piotr Trojanek <trojanek@adacore.com>
Date: Thu, 8 Apr 2021 07:42:28 +0000 (+0200)
Subject: [Ada] Accept arrays and scalars as type views that can be validated
X-Git-Tag: basepoints/gcc-13~6430
X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=7aaf662001871e1c3a87fdd9b662329c6a2e8d60;p=thirdparty%2Fgcc.git

[Ada] Accept arrays and scalars as type views that can be validated

gcc/ada/

	* exp_attr.adb (Build_Array_VS_Func): Restore uses of
	Validated_View.
	(Build_Record_VS_Func): Likewise.
	(Expand_N_Attribute_Reference): Likewise.
	* sem_util.adb (Validated_View): Behave as an identity function
	for arrays and scalars.
---

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index d19ae1fce2dc..2e1cb85d5dfa 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -248,7 +248,7 @@ package body Exp_Attr is
    is
       Loc      : constant Source_Ptr := Sloc (Attr);
       Comp_Typ : constant Entity_Id :=
-        Get_Fullest_View (Component_Type (Array_Typ));
+        Validated_View (Component_Type (Array_Typ));
 
       function Validate_Component
         (Obj_Id  : Entity_Id;
@@ -535,7 +535,7 @@ package body Exp_Attr is
       is
          Field_Id  : constant Entity_Id := Defining_Entity (Field);
          Field_Nam : constant Name_Id   := Chars (Field_Id);
-         Field_Typ : constant Entity_Id := Get_Fullest_View (Etype (Field_Id));
+         Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
          Attr_Nam  : Name_Id;
 
       begin
@@ -7396,7 +7396,7 @@ package body Exp_Attr is
       -------------------
 
       when Attribute_Valid_Scalars => Valid_Scalars : declare
-         Val_Typ : constant Entity_Id := Get_Fullest_View (Ptyp);
+         Val_Typ : constant Entity_Id := Validated_View (Ptyp);
          Expr    : Node_Id;
 
       begin
@@ -7460,7 +7460,7 @@ package body Exp_Attr is
                     (Build_Record_VS_Func
                       (Attr       => N,
                        Formal_Typ => Ptyp,
-                       Rec_Typ    => Validated_View (Ptyp)),
+                       Rec_Typ    => Val_Typ),
                     Loc),
                 Parameter_Associations => New_List (Pref));
          end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 8a4a98b51154..f723781fd78d 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -29473,34 +29473,53 @@ package body Sem_Util is
 
    function Validated_View (Typ : Entity_Id) return Entity_Id is
    begin
+      --  Scalar types can be always validated. In fast, switiching to the base
+      --  type would drop the range constraints and force validation to use a
+      --  larger type than necessary.
+
+      if Is_Scalar_Type (Typ) then
+         return Typ;
+
+      --  Array types can be validated even when they are derived, because
+      --  validation only requires their bounds and component types to be
+      --  accessible. In fact, switching to the parent type would pollute
+      --  expansion of attribute Valid_Scalars with unnecessary conversion
+      --  that might not be eliminated by the frontend.
+
+      elsif Is_Array_Type (Typ) then
+         return Typ;
+
+      --  For other types, in particular for record subtypes, we switch to the
+      --  base type.
+
+      elsif not Is_Base_Type (Typ) then
+         return Validated_View (Base_Type (Typ));
+
       --  Obtain the full view of the input type by stripping away concurrency,
       --  derivations, and privacy.
 
-      if Is_Base_Type (Typ) then
-         if Is_Concurrent_Type (Typ) then
-            if Present (Corresponding_Record_Type (Typ)) then
-               return Corresponding_Record_Type (Typ);
-            else
-               return Typ;
-            end if;
+      elsif Is_Concurrent_Type (Typ) then
+         if Present (Corresponding_Record_Type (Typ)) then
+            return Corresponding_Record_Type (Typ);
+         else
+            return Typ;
+         end if;
 
-         elsif Is_Derived_Type (Typ) then
-            return Validated_View (Etype (Typ));
+      elsif Is_Derived_Type (Typ) then
+         return Validated_View (Etype (Typ));
 
-         elsif Is_Private_Type (Typ) then
-            if Present (Underlying_Full_View (Typ)) then
-               return Validated_View (Underlying_Full_View (Typ));
+      elsif Is_Private_Type (Typ) then
+         if Present (Underlying_Full_View (Typ)) then
+            return Validated_View (Underlying_Full_View (Typ));
 
-            elsif Present (Full_View (Typ)) then
-               return Validated_View (Full_View (Typ));
-            else
-               return Typ;
-            end if;
+         elsif Present (Full_View (Typ)) then
+            return Validated_View (Full_View (Typ));
+         else
+            return Typ;
          end if;
 
-         return Typ;
       else
-         return Validated_View (Base_Type (Typ));
+         return Typ;
       end if;
    end Validated_View;