[Ada] Allow attribute 'Valid_Scalars on private types

This patch modifies the analysis and expansion of attribute 'Valid_Scalars. It
is now possible to specify the attribute on a prefix of an untagged private
type.

------------
-- Source --
------------

--  gnat.adc

pragma Initialize_Scalars;

--  pack1.ads

package Pack1 is
   type Acc_1  is private;
   type Acc_2  is private;
   type Arr_1  is private;
   type Arr_2  is private;
   type Bool_1 is private;
   type Cmpx_1 is private;
   type Cmpx_2 is private;
   type Enum_1 is private;
   type Enum_2 is private;
   type Fix_1  is private;
   type Fix_2  is private;
   type Flt_1  is private;
   type Flt_2  is private;
   type Modl_1 is private;
   type Prot_1 is limited private;
   type Prot_2 is limited private;
   type Prot_3 (Discr : Boolean) is limited private;
   type Rec_1  is private;
   type Rec_2  is private;
   type Rec_3  is private;
   type Rec_4 (Discr : Boolean) is private;
   type Rec_5 (Discr_1 : Boolean; Discr_2 : Boolean) is private;
   type Sign_1 is private;
   type Tag_1  is tagged private;
   type Task_1 is limited private;
   type Task_2 (Discr : Boolean) is limited private;

   type Prec_Arr_1 is private;
   type Prec_Arr_2 is private;
   type Prec_Arr_3 is private;
   type Prec_Arr_4 is private;
   type Prec_Arr_5 is private;

   type Prec_Rec_1 is private;
   type Prec_Rec_2 (Discr : Boolean) is private;
   type Prec_Rec_3 (Discr_1 : Boolean; Discr_2 : Boolean) is private;
   type Prec_Rec_4 is private;
   type Prec_Rec_5 is private;
   type Prec_Rec_6 is private;
   type Prec_Rec_7 is private;
   type Prec_Rec_8 is private;
   type Prec_Rec_9 is private;

private
   type Acc_1 is access Boolean;
   type Acc_2 is access procedure;
   type Arr_1  is array (1 .. 10) of Boolean;
   type Arr_2  is array (1 .. 3) of access Boolean;
   type Bool_1 is new Boolean;
   type Cmpx_1 is array (1 .. 5) of Rec_5 (True, True);
   type Cmpx_2 is record
      Comp_1 : Cmpx_1;
      Comp_2 : Rec_4 (True);
   end record;
   type Enum_1 is (One, Two, Three);
   type Enum_2 is ('f', 'o', 'u', 'r');
   type Fix_1  is delta 0.5 range 0.0 .. 10.0;
   type Fix_2  is delta 0.1 digits 15;
   type Flt_1  is digits 8;
   type Flt_2  is digits 10 range -1.0 .. 1.0;
   type Modl_1 is mod 8;
   protected type Prot_1 is
   end Prot_1;
   protected type Prot_2 is
   private
      Comp_1 : Boolean;
      Comp_2 : Boolean;
   end Prot_2;
   protected type Prot_3 (Discr : Boolean) is
   private
      Comp_1 : Boolean;
      Comp_2 : Rec_4 (Discr);
   end Prot_3;
   type Rec_1  is null record;
   type Rec_2  is record
      null;
   end record;
   type Rec_3  is record
      Comp_1 : Boolean;
      Comp_2 : Boolean;
   end record;
   type Rec_4 (Discr : Boolean) is record
      case Discr is
         when True =>
            Comp_1 : Boolean;
            Comp_2 : Boolean;
         when False =>
            Comp_3 : access Boolean;
      end case;
   end record;
   type Rec_5 (Discr_1 : Boolean; Discr_2 : Boolean) is record
      Comp_1 : Boolean;
      Comp_2 : Boolean;
      case Discr_1 is
         when True =>
            case Discr_2 is
               when True =>
                  Comp_3 : Boolean;
                  Comp_4 : Boolean;
               when False =>
                  null;
            end case;
         when False =>
            null;
      end case;
   end record;
   type Sign_1 is range 1 .. 10;
   type Tag_1 is tagged null record;
   task type Task_1;
   task type Task_2 (Discr : Boolean);

   type Prec_Arr_1 is array (1 .. 2) of Boolean;
   type Prec_Arr_2 is array (1 .. 2, 1 .. 2) of Boolean;
   type Prec_Arr_3 is array (1 .. 2) of Prec_Rec_1;
   type Prec_Arr_4 is array (1 .. 2) of Prec_Rec_2 (True);
   type Prec_Arr_5 is array (1 .. 2) of Prec_Rec_3 (True, True);

   type Prec_Rec_1 is record
      Comp_1 : Boolean;
   end record;

   type Prec_Rec_2 (Discr : Boolean) is record
      case Discr is
         when True =>
            Comp_1 : Boolean;
         when others =>
            Comp_2 : Boolean;
      end case;
   end record;

   type Prec_Rec_3 (Discr_1 : Boolean; Discr_2 : Boolean) is record
      case Discr_1 is
         when True =>
            case Discr_2 is
               when True =>
                  Comp_1 : Boolean;
               when others =>
                  Comp_2 : Boolean;
            end case;
         when False =>
            case Discr_2 is
               when True =>
                  Comp_3 : Boolean;
               when others =>
                  Comp_4 : Boolean;
            end case;
      end case;
   end record;

   type Prec_Rec_4 is record
      Comp : Prec_Arr_1;
   end record;

   type Prec_Rec_5 is record
      Comp : Prec_Arr_4;
   end record;

   type Prec_Rec_6 is record
      Comp : Prec_Arr_5;
   end record;

   type Prec_Rec_7 is record
      Comp : Prec_Rec_4;
   end record;

   type Prec_Rec_8 is record
      Comp : Prec_Rec_5;
   end record;

   type Prec_Rec_9 is record
      Comp : Prec_Rec_6;
   end record;
end Pack1;

--  pack1.adb

package body Pack1 is
   protected body Prot_1 is end Prot_1;
   protected body Prot_2 is end Prot_2;
   protected body Prot_3 is end Prot_3;

   task body Task_1 is begin null; end Task_1;
   task body Task_2 is begin null; end Task_2;
end Pack1;

--  pack2.ads

with Pack1; use Pack1;

package Pack2 is
   type Acc_3  is private;
   type Acc_4  is private;
   type Arr_3  is private;
   type Arr_4  is private;
   type Bool_2 is private;
   type Cmpx_3 is private;
   type Cmpx_4 is private;
   type Enum_3 is private;
   type Enum_4 is private;
   type Fix_3  is private;
   type Fix_4  is private;
   type Flt_3  is private;
   type Flt_4  is private;
   type Modl_2 is private;
   type Prot_4 is limited private;
   type Prot_5 is limited private;
   type Prot_6 is limited private;
   type Rec_6  is private;
   type Rec_7  is private;
   type Rec_8  is private;
   type Rec_9  (Discr : Boolean) is private;
   type Rec_10 (Discr : Boolean) is private;
   type Sign_2 is private;
   type Task_3 is limited private;

private
   type Acc_3  is new Acc_1;
   type Acc_4  is new Acc_2;
   type Arr_3  is new Arr_1;
   type Arr_4  is new Arr_2;
   type Bool_2 is new Bool_1;
   type Cmpx_3 is new Cmpx_1;
   type Cmpx_4 is new Cmpx_2;
   type Enum_3 is new Enum_1;
   type Enum_4 is new Enum_2;
   type Fix_3  is new Fix_1;
   type Fix_4  is new Fix_2;
   type Flt_3  is new Flt_1;
   type Flt_4  is new Flt_2;
   type Modl_2 is new Modl_1;
   type Prot_4 is new Prot_1;
   type Prot_5 is new Prot_2;
   type Prot_6 is new Prot_3 (True);
   type Rec_6  is new Rec_1;
   type Rec_7  is new Rec_2;
   type Rec_8  is new Rec_3;
   type Rec_9  (Discr : Boolean) is
     new Rec_4 (Discr => Discr);
   type Rec_10 (Discr : Boolean) is
     new Rec_5 (Discr_1 => Discr, Discr_2 => True);
   type Sign_2 is new Sign_1;
   type Task_3 is new Task_1;
end Pack2;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;

with Pack1; use Pack1;
with Pack2; use Pack2;

procedure Main is
   procedure Check
     (Actual : Boolean;
      Valid  : Boolean;
      Test   : String)
   is
   begin
      if Actual /= Valid then
         Put_Line ("ERROR " & Test);
         Put_Line ("  valid : " & Valid'Img);
         Put_Line ("  actual: " & Actual'Img);
      end if;
   end Check;

   Valid     : constant Boolean := True;
   Not_Valid : constant Boolean := not Valid;

   pragma Warnings (Off);
   Acc_1_Obj  : Acc_1;
   Acc_2_Obj  : Acc_2;
   Acc_3_Obj  : Acc_3;
   Acc_4_Obj  : Acc_4;
   Arr_1_Obj  : Arr_1;
   Arr_2_Obj  : Arr_2;
   Arr_3_Obj  : Arr_3;
   Arr_4_Obj  : Arr_4;
   Bool_1_Obj : Bool_1;
   Bool_2_Obj : Bool_2;
   Cmpx_1_Obj : Cmpx_1;
   Cmpx_2_Obj : Cmpx_2;
   Cmpx_3_Obj : Cmpx_3;
   Cmpx_4_Obj : Cmpx_4;
   Enum_1_Obj : Enum_1;
   Enum_2_Obj : Enum_2;
   Enum_3_Obj : Enum_3;
   Enum_4_Obj : Enum_4;
   Fix_1_Obj  : Fix_1;
   Fix_2_Obj  : Fix_2;
   Fix_3_Obj  : Fix_3;
   Fix_4_Obj  : Fix_4;
   Flt_1_Obj  : Flt_1;
   Flt_2_Obj  : Flt_2;
   Flt_3_Obj  : Flt_3;
   Flt_4_Obj  : Flt_4;
   Modl_1_Obj : Modl_1;
   Modl_2_Obj : Modl_2;
   Prot_1_Obj : Prot_1;
   Prot_2_Obj : Prot_2;
   Prot_3_Obj : Prot_3 (True);
   Prot_4_Obj : Prot_4;
   Prot_5_Obj : Prot_5;
   Rec_1_Obj  : Rec_1;
   Rec_2_Obj  : Rec_2;
   Rec_3_Obj  : Rec_3;
   Rec_4_Obj  : Rec_4 (True);
   Rec_5_Obj  : Rec_5 (True, True);
   Rec_6_Obj  : Rec_6;
   Rec_7_Obj  : Rec_7;
   Rec_8_Obj  : Rec_8;
   Rec_9_Obj  : Rec_9 (True);
   Sign_1_Obj : Sign_1;
   Sign_2_Obj : Sign_2;
   Tag_1_Obj  : Tag_1;
   Task_1_Obj : Task_1;
   Task_2_Obj : Task_2 (True);
   Task_3_Obj : Task_3;

   Prec_Arr_1_Obj : Prec_Arr_1;
   Prec_Arr_2_Obj : Prec_Arr_2;
   Prec_Arr_3_Obj : Prec_Arr_3;
   Prec_Arr_4_Obj : Prec_Arr_4;
   Prec_Arr_5_Obj : Prec_Arr_5;

   Prec_Rec_1_Obj : Prec_Rec_1;
   Prec_Rec_2_Obj : Prec_Rec_2 (True);
   Prec_Rec_3_Obj : Prec_Rec_3 (True, True);
   Prec_Rec_4_Obj : Prec_Rec_4;
   Prec_Rec_5_Obj : Prec_Rec_5;
   Prec_Rec_6_Obj : Prec_Rec_6;
   Prec_Rec_7_Obj : Prec_Rec_7;
   Prec_Rec_8_Obj : Prec_Rec_8;
   Prec_Rec_9_Obj : Prec_Rec_9;
   pragma Warnings (On);

begin
   Check (Acc_1_Obj'Valid_Scalars,  Valid,     "Acc_1_Obj");
   Check (Acc_2_Obj'Valid_Scalars,  Valid,     "Acc_2_Obj");
   Check (Acc_3_Obj'Valid_Scalars,  Valid,     "Acc_3_Obj");
   Check (Acc_4_Obj'Valid_Scalars,  Valid,     "Acc_4_Obj");
   Check (Arr_1_Obj'Valid_Scalars,  Not_Valid, "Arr_1_Obj");
   Check (Arr_2_Obj'Valid_Scalars,  Valid,     "Arr_2_Obj");
   Check (Arr_3_Obj'Valid_Scalars,  Not_Valid, "Arr_3_Obj");
   Check (Arr_4_Obj'Valid_Scalars,  Valid,     "Arr_4_Obj");
   Check (Bool_1_Obj'Valid_Scalars, Not_Valid, "Bool_1_Obj");
   Check (Bool_2_Obj'Valid_Scalars, Not_Valid, "Bool_2_Obj");
   Check (Cmpx_1_Obj'Valid_Scalars, Not_Valid, "Cmpx_1_Obj");
   Check (Cmpx_2_Obj'Valid_Scalars, Not_Valid, "Cmpx_2_Obj");
   Check (Cmpx_3_Obj'Valid_Scalars, Not_Valid, "Cmpx_3_Obj");
   Check (Cmpx_4_Obj'Valid_Scalars, Not_Valid, "Cmpx_4_Obj");
   Check (Enum_1_Obj'Valid_Scalars, Not_Valid, "Enum_1_Obj");
   Check (Enum_2_Obj'Valid_Scalars, Not_Valid, "Enum_2_Obj");
   Check (Enum_3_Obj'Valid_Scalars, Not_Valid, "Enum_3_Obj");
   Check (Enum_4_Obj'Valid_Scalars, Not_Valid, "Enum_4_Obj");
   Check (Fix_1_Obj'Valid_Scalars,  Not_Valid, "Fix_1_Obj");
   Check (Fix_2_Obj'Valid_Scalars,  Not_Valid, "Fix_2_Obj");
   Check (Fix_3_Obj'Valid_Scalars,  Not_Valid, "Fix_3_Obj");
   Check (Fix_4_Obj'Valid_Scalars,  Not_Valid, "Fix_4_Obj");
   Check (Flt_1_Obj'Valid_Scalars,  Not_Valid, "Flt_1_Obj");
   Check (Flt_2_Obj'Valid_Scalars,  Not_Valid, "Flt_2_Obj");
   Check (Flt_3_Obj'Valid_Scalars,  Not_Valid, "Flt_3_Obj");
   Check (Flt_4_Obj'Valid_Scalars,  Not_Valid, "Flt_4_Obj");
   Check (Modl_1_Obj'Valid_Scalars, Not_Valid, "Modl_1_Obj");
   Check (Modl_2_Obj'Valid_Scalars, Not_Valid, "Modl_2_Obj");
   Check (Prot_1_Obj'Valid_Scalars, Valid,     "Prot_1_Obj");
   Check (Prot_2_Obj'Valid_Scalars, Not_Valid, "Prot_2_Obj");
   Check (Prot_3_Obj'Valid_Scalars, Not_Valid, "Prot_3_Obj");
   Check (Prot_4_Obj'Valid_Scalars, Valid,     "Prot_4_Obj");
   Check (Prot_5_Obj'Valid_Scalars, Not_Valid, "Prot_5_Obj");
   Check (Rec_1_Obj'Valid_Scalars,  Valid,     "Rec_1_Obj");
   Check (Rec_2_Obj'Valid_Scalars,  Valid,     "Rec_2_Obj");
   Check (Rec_3_Obj'Valid_Scalars,  Not_Valid, "Rec_3_Obj");
   Check (Rec_4_Obj'Valid_Scalars,  Not_Valid, "Rec_4_Obj");
   Check (Rec_5_Obj'Valid_Scalars,  Not_Valid, "Rec_5_Obj");
   Check (Rec_6_Obj'Valid_Scalars,  Valid,     "Rec_6_Obj");
   Check (Rec_7_Obj'Valid_Scalars,  Valid,     "Rec_7_Obj");
   Check (Rec_8_Obj'Valid_Scalars,  Not_Valid, "Rec_8_Obj");
   Check (Rec_9_Obj'Valid_Scalars,  Not_Valid, "Rec_9_Obj");
   Check (Sign_1_Obj'Valid_Scalars, Not_Valid, "Sign_1_Obj");
   Check (Sign_2_Obj'Valid_Scalars, Not_Valid, "Sign_2_Obj");
   Check (Tag_1_Obj'Valid_Scalars,  Valid,     "Tag_1_Obj");
   Check (Task_1_Obj'Valid_Scalars, Valid,     "Task_1_Obj");
   Check (Task_2_Obj'Valid_Scalars, Valid,     "Task_2_Obj");
   Check (Task_3_Obj'Valid_Scalars, Valid,     "Task_3_Obj");

   Check (Prec_Arr_1_Obj'Valid_Scalars, Not_Valid, "Prec_Arr_1_Obj");
   Check (Prec_Arr_2_Obj'Valid_Scalars, Not_Valid, "Prec_Arr_2_Obj");
   Check (Prec_Arr_3_Obj'Valid_Scalars, Not_Valid, "Prec_Arr_3_Obj");
   Check (Prec_Arr_4_Obj'Valid_Scalars, Not_Valid, "Prec_Arr_4_Obj");
   Check (Prec_Arr_5_Obj'Valid_Scalars, Not_Valid, "Prec_Arr_5_Obj");

   Check (Prec_Rec_1_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_1_Obj");
   Check (Prec_Rec_2_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_2_Obj");
   Check (Prec_Rec_3_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_3_Obj");
   Check (Prec_Rec_4_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_4_Obj");
   Check (Prec_Rec_5_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_5_Obj");
   Check (Prec_Rec_6_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_6_Obj");
   Check (Prec_Rec_7_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_7_Obj");
   Check (Prec_Rec_8_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_8_Obj");
   Check (Prec_Rec_9_Obj'Valid_Scalars, Not_Valid, "Prec_Rec_9_Obj");
end Main;

-----------------
-- Compilation --
-----------------

$ gnatmake -q main.adb
$ ./main

2018-05-22  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_attr.adb (Build_Array_VS_Func): Reimplemented.
	(Build_Record_VS_Func): Reimplemented.
	(Expand_N_Attribute): Reimplement the handling of attribute
	'Valid_Scalars.
	* sem_attr.adb (Analyze_Attribute): Reimplement the handling of
	attribute 'Valid_Scalars.
	* sem_util.adb (Scalar_Part_Present): Reimplemented.
	(Validated_View): New routine.
	* sem_util.ads (Scalar_Part_Present): Update the parameter profile and
	comment on usage.
	(Validated_View): New routine.
	* doc/gnat_rm/implementation_defined_attributes.rst: Update the
	documentation of attribute 'Valid_Scalars.
	* gnat_rm.texi: Regenerate.

From-SVN: r260518

gcc/ada/ChangeLog

+2018-05-22  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_attr.adb (Build_Array_VS_Func): Reimplemented.
+	(Build_Record_VS_Func): Reimplemented.
+	(Expand_N_Attribute): Reimplement the handling of attribute
+	'Valid_Scalars.
+	* sem_attr.adb (Analyze_Attribute): Reimplement the handling of
+	attribute 'Valid_Scalars.
+	* sem_util.adb (Scalar_Part_Present): Reimplemented.
+	(Validated_View): New routine.
+	* sem_util.ads (Scalar_Part_Present): Update the parameter profile and
+	comment on usage.
+	(Validated_View): New routine.
+	* doc/gnat_rm/implementation_defined_attributes.rst: Update the
+	documentation of attribute 'Valid_Scalars.
+	* gnat_rm.texi: Regenerate.
+
 2018-05-22  Bob Duff  <duff@adacore.com>
 
 	* binde.adb: (Choose): Ignore a pragma Elaborate_Body that appears in

gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst

@@ -1534,32 +1534,31 @@ Attribute Valid_Scalars
 =======================
 .. index:: Valid_Scalars
 
-The ``'Valid_Scalars`` attribute is intended to make it easier to
-check the validity of scalar subcomponents of composite objects. It
-is defined for any prefix ``X`` that denotes an object.
-The value of this attribute is of the predefined type Boolean.
-``X'Valid_Scalars`` yields True if and only if evaluation of
-``P'Valid`` yields True for every scalar part P of X or if X has
-no scalar parts. It is not specified in what order the scalar parts
-are checked, nor whether any more are checked after any one of them
-is determined to be invalid. If the prefix ``X`` is of a class-wide
-type ``T'Class`` (where ``T`` is the associated specific type),
-or if the prefix ``X`` is of a specific tagged type ``T``, then
-only the scalar parts of components of ``T`` are traversed; in other
-words, components of extensions of ``T`` are not traversed even if
-``T'Class (X)'Tag /= T'Tag`` . The compiler will issue a warning if it can
-be determined at compile time that the prefix of the attribute has no
-scalar parts (e.g., if the prefix is of an access type, an interface type,
-an undiscriminated task type, or an undiscriminated protected type).
-
-For scalar types, ``Valid_Scalars`` is equivalent to ``Valid``. The use
-of this attribute is not permitted for ``Unchecked_Union`` types for which
-in general it is not possible to determine the values of the discriminants.
-
-Note: ``Valid_Scalars`` can generate a lot of code, especially in the case
-of a large variant record. If the attribute is called in many places in the
-same program applied to objects of the same type, it can reduce program size
-to write a function with a single use of the attribute, and then call that
+The ``'Valid_Scalars`` attribute is intended to make it easier to check the
+validity of scalar subcomponents of composite objects. The attribute is defined
+for any prefix ``P`` which denotes an object. Prefix ``P`` can be any type
+except for tagged private or ``Unchecked_Union`` types. The value of the
+attribute is of type ``Boolean``.
+
+``P'Valid_Scalars`` yields ``True`` if and only if the evaluation of
+``C'Valid`` yields ``True`` for every scalar subcomponent ``C`` of ``P``, or if
+``P`` has no scalar subcomponents. Attribute ``'Valid_Scalars`` is equivalent
+to attribute ``'Valid`` for scalar types.
+
+It is not specified in what order the subcomponents are checked, nor whether
+any more are checked after any one of them is determined to be invalid. If the
+prefix ``P`` is of a class-wide type ``T'Class`` (where ``T`` is the associated
+specific type), or if the prefix ``P`` is of a specific tagged type ``T``, then
+only the subcomponents of ``T`` are checked; in other words, components of
+extensions of ``T`` are not checked even if ``T'Class (P)'Tag /= T'Tag``.
+
+The compiler will issue a warning if it can be determined at compile time that
+the prefix of the attribute has no scalar subcomponents.
+
+Note: ``Valid_Scalars`` can generate a lot of code, especially in the case of
+a large variant record. If the attribute is called in many places in the same
+program applied to objects of the same type, it can reduce program size to
+write a function with a single use of the attribute, and then call that
 function from multiple places.
 
 Attribute VADS_Size

gcc/ada/gnat_rm.texi

@@ -11658,32 +11658,31 @@ which changes element (1,2) to 20 and (3,4) to 30.
 
 @geindex Valid_Scalars
 
-The @code{'Valid_Scalars} attribute is intended to make it easier to
-check the validity of scalar subcomponents of composite objects. It
-is defined for any prefix @code{X} that denotes an object.
-The value of this attribute is of the predefined type Boolean.
-@code{X'Valid_Scalars} yields True if and only if evaluation of
-@code{P'Valid} yields True for every scalar part P of X or if X has
-no scalar parts. It is not specified in what order the scalar parts
-are checked, nor whether any more are checked after any one of them
-is determined to be invalid. If the prefix @code{X} is of a class-wide
-type @code{T'Class} (where @code{T} is the associated specific type),
-or if the prefix @code{X} is of a specific tagged type @code{T}, then
-only the scalar parts of components of @code{T} are traversed; in other
-words, components of extensions of @code{T} are not traversed even if
-@code{T'Class (X)'Tag /= T'Tag} . The compiler will issue a warning if it can
-be determined at compile time that the prefix of the attribute has no
-scalar parts (e.g., if the prefix is of an access type, an interface type,
-an undiscriminated task type, or an undiscriminated protected type).
-
-For scalar types, @code{Valid_Scalars} is equivalent to @code{Valid}. The use
-of this attribute is not permitted for @code{Unchecked_Union} types for which
-in general it is not possible to determine the values of the discriminants.
-
-Note: @code{Valid_Scalars} can generate a lot of code, especially in the case
-of a large variant record. If the attribute is called in many places in the
-same program applied to objects of the same type, it can reduce program size
-to write a function with a single use of the attribute, and then call that
+The @code{'Valid_Scalars} attribute is intended to make it easier to check the
+validity of scalar subcomponents of composite objects. The attribute is defined
+for any prefix @code{P} which denotes an object. Prefix @code{P} can be any type
+except for tagged private or @code{Unchecked_Union} types. The value of the
+attribute is of type @code{Boolean}.
+
+@code{P'Valid_Scalars} yields @code{True} if and only if the evaluation of
+@code{C'Valid} yields @code{True} for every scalar subcomponent @code{C} of @code{P}, or if
+@code{P} has no scalar subcomponents. Attribute @code{'Valid_Scalars} is equivalent
+to attribute @code{'Valid} for scalar types.
+
+It is not specified in what order the subcomponents are checked, nor whether
+any more are checked after any one of them is determined to be invalid. If the
+prefix @code{P} is of a class-wide type @code{T'Class} (where @code{T} is the associated
+specific type), or if the prefix @code{P} is of a specific tagged type @code{T}, then
+only the subcomponents of @code{T} are checked; in other words, components of
+extensions of @code{T} are not checked even if @code{T'Class (P)'Tag /= T'Tag}.
+
+The compiler will issue a warning if it can be determined at compile time that
+the prefix of the attribute has no scalar subcomponents.
+
+Note: @code{Valid_Scalars} can generate a lot of code, especially in the case of
+a large variant record. If the attribute is called in many places in the same
+program applied to objects of the same type, it can reduce program size to
+write a function with a single use of the attribute, and then call that
 function from multiple places.
 
 @node Attribute VADS_Size,Attribute Value_Size,Attribute Valid_Scalars,Implementation Defined Attributes

gcc/ada/sem_attr.adb

@@ -2200,8 +2200,8 @@ package body Sem_Attr is
          Rtyp : Entity_Id;
 
       begin
-         --  If we need an object, and we have a prefix that is the name of
-         --  a function entity, convert it into a function call.
+         --  If we need an object, and we have a prefix that is the name of a
+         --  function entity, convert it into a function call.
 
          if Is_Entity_Name (P)
            and then Ekind (Entity (P)) = E_Function
@@ -2601,7 +2601,7 @@ package body Sem_Attr is
 
       procedure Error_Attr is
       begin
-         Set_Etype (N, Any_Type);
+         Set_Etype  (N, Any_Type);
          Set_Entity (N, Any_Type);
          raise Bad_Attribute;
       end Error_Attr;
@@ -6863,7 +6863,10 @@ package body Sem_Attr is
       -- Valid --
       -----------
 
-      when Attribute_Valid =>
+      when Attribute_Valid => Valid : declare
+         Pred_Func : constant Entity_Id := Predicate_Function (P_Type);
+
+      begin
          Check_E0;
 
          --  Ignore check for object if we have a 'Valid reference generated
@@ -6872,54 +6875,77 @@ package body Sem_Attr is
 
          if Comes_From_Source (N) then
             Check_Object_Reference (P);
-         end if;
-
-         if not Is_Scalar_Type (P_Type) then
-            Error_Attr_P ("object for % attribute must be of scalar type");
-         end if;
 
-         --  If the attribute appears within the subtype's own predicate
-         --  function, then issue a warning that this will cause infinite
-         --  recursion.
+            if not Is_Scalar_Type (P_Type) then
+               Error_Attr_P ("object for % attribute must be of scalar type");
+            end if;
 
-         declare
-            Pred_Func : constant Entity_Id := Predicate_Function (P_Type);
+            --  If the attribute appears within the subtype's own predicate
+            --  function, then issue a warning that this will cause infinite
+            --  recursion.
 
-         begin
             if Present (Pred_Func) and then Current_Scope = Pred_Func then
-               Error_Msg_N
-                 ("attribute Valid requires a predicate check??", N);
+               Error_Msg_N ("attribute Valid requires a predicate check??", N);
                Error_Msg_N ("\and will result in infinite recursion??", N);
             end if;
-         end;
+         end if;
 
          Set_Etype (N, Standard_Boolean);
+      end Valid;
 
       -------------------
       -- Valid_Scalars --
       -------------------
 
-      when Attribute_Valid_Scalars =>
+      when Attribute_Valid_Scalars => Valid_Scalars : declare
+      begin
          Check_E0;
-         Check_Object_Reference (P);
-         Set_Etype (N, Standard_Boolean);
-
-         --  Following checks are only for source types
 
          if Comes_From_Source (N) then
-            if not Scalar_Part_Present (P_Type) then
-               Error_Attr_P
-                 ("??attribute % always True, no scalars to check");
-            end if;
+            Check_Object_Reference (P);
 
-            --  Not allowed for unchecked union type
+            --  Do not emit any diagnostics related to private types to avoid
+            --  disclosing the structure of the type.
 
-            if Has_Unchecked_Union (P_Type) then
-               Error_Attr_P
-                 ("attribute % not allowed for Unchecked_Union type");
+            if Is_Private_Type (P_Type) then
+
+               --  Attribute 'Valid_Scalars is not supported on private tagged
+               --  types due to a code generation issue. Is_Visible_Component
+               --  does not allow for a component of a private tagged type to
+               --  be successfully retrieved.
+
+               --  Do not use Error_Attr_P because this bypasses any subsequent
+               --  processing and leaves the attribute with type Any_Type. This
+               --  in turn prevents the proper expansion of the attribute into
+               --  True.
+
+               if Is_Tagged_Type (P_Type) then
+                  Error_Msg_Name_1 := Aname;
+                  Error_Msg_N ("??effects of attribute % are ignored", N);
+               end if;
+
+            --  Otherwise the type is not private
+
+            else
+               if not Scalar_Part_Present (P_Type) then
+                  Error_Attr_P
+                    ("??attribute % always True, no scalars to check");
+               end if;
+
+               --  Attribute 'Valid_Scalars is illegal on unchecked union types
+               --  because it is not always guaranteed that the components are
+               --  retrievable based on whether the discriminants are inferable
+
+               if Has_Unchecked_Union (P_Type) then
+                  Error_Attr_P
+                    ("attribute % not allowed for Unchecked_Union type");
+               end if;
             end if;
          end if;
 
+         Set_Etype (N, Standard_Boolean);
+      end Valid_Scalars;
+
       -----------
       -- Value --
       -----------

gcc/ada/sem_util.adb

@@ -23312,24 +23312,25 @@ package body Sem_Util is
    -- Scalar_Part_Present --
    -------------------------
 
-   function Scalar_Part_Present (T : Entity_Id) return Boolean is
-      C : Entity_Id;
+   function Scalar_Part_Present (Typ : Entity_Id) return Boolean is
+      Val_Typ : constant Entity_Id := Validated_View (Typ);
+      Field   : Entity_Id;
 
    begin
-      if Is_Scalar_Type (T) then
+      if Is_Scalar_Type (Val_Typ) then
          return True;
 
-      elsif Is_Array_Type (T) then
-         return Scalar_Part_Present (Component_Type (T));
+      elsif Is_Array_Type (Val_Typ) then
+         return Scalar_Part_Present (Component_Type (Val_Typ));
 
-      elsif Is_Record_Type (T) or else Has_Discriminants (T) then
-         C := First_Component_Or_Discriminant (T);
-         while Present (C) loop
-            if Scalar_Part_Present (Etype (C)) then
+      elsif Is_Record_Type (Val_Typ) then
+         Field := First_Component_Or_Discriminant (Val_Typ);
+         while Present (Field) loop
+            if Scalar_Part_Present (Etype (Field)) then
                return True;
-            else
-               Next_Component_Or_Discriminant (C);
             end if;
+
+            Next_Component_Or_Discriminant (Field);
          end loop;
       end if;
 
@@ -24980,6 +24981,49 @@ package body Sem_Util is
       end if;
    end Unqual_Conv;
 
+   --------------------
+   -- Validated_View --
+   --------------------
+
+   function Validated_View (Typ : Entity_Id) return Entity_Id is
+      Continue : Boolean;
+      Val_Typ  : Entity_Id;
+
+   begin
+      Continue := True;
+      Val_Typ  := Base_Type (Typ);
+
+      --  Obtain the full view of the input type by stripping away concurrency,
+      --  derivations, and privacy.
+
+      while Continue loop
+         Continue := False;
+
+         if Is_Concurrent_Type (Val_Typ) then
+            if Present (Corresponding_Record_Type (Val_Typ)) then
+               Continue := True;
+               Val_Typ  := Corresponding_Record_Type (Val_Typ);
+            end if;
+
+         elsif Is_Derived_Type (Val_Typ) then
+            Continue := True;
+            Val_Typ  := Etype (Val_Typ);
+
+         elsif Is_Private_Type (Val_Typ) then
+            if Present (Underlying_Full_View (Val_Typ)) then
+               Continue := True;
+               Val_Typ  := Underlying_Full_View (Val_Typ);
+
+            elsif Present (Full_View (Val_Typ)) then
+               Continue := True;
+               Val_Typ  := Full_View (Val_Typ);
+            end if;
+         end if;
+      end loop;
+
+      return Val_Typ;
+   end Validated_View;
+
    -----------------------
    -- Visible_Ancestors --
    -----------------------

gcc/ada/sem_util.ads

@@ -2575,11 +2575,9 @@ package Sem_Util is
    --  A result of False does not necessarily mean they have different values,
    --  just that it is not possible to determine they have the same value.
 
-   function Scalar_Part_Present (T : Entity_Id) return Boolean;
-   --  Tests if type T can be determined at compile time to have at least one
-   --  scalar part in the sense of the Valid_Scalars attribute. Returns True if
-   --  this is the case, and False if no scalar parts are present (meaning that
-   --  the result of Valid_Scalars applied to T is always vacuously True).
+   function Scalar_Part_Present (Typ : Entity_Id) return Boolean;
+   --  Determine whether arbitrary type Typ is a scalar type, or contains at
+   --  least one scalar subcomponent.
 
    function Scope_Within
      (Inner : Entity_Id;
@@ -2790,6 +2788,12 @@ package Sem_Util is
    --  Similar to Unqualify, but removes qualified expressions, type
    --  conversions, and unchecked conversions.
 
+   function Validated_View (Typ : Entity_Id) return Entity_Id;
+   --  Obtain the "validated view" of arbitrary type Typ which is suitable
+   --  for verification by attributes 'Valid and 'Valid_Scalars. This view
+   --  is the type itself or its full view while stripping away concurrency,
+   --  derivations, and privacy.
+
    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id;
    --  [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors
    --  of a type extension or private extension declaration. If the full-view