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
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-22 Hristian Kirtchev <kirtc...@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.
--- gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
+++ 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/exp_attr.adb
+++ gcc/ada/exp_attr.adb
@@ -75,23 +75,41 @@ package body Exp_Attr is
-----------------------
function Build_Array_VS_Func
- (A_Type : Entity_Id;
- Nod : Node_Id) return Entity_Id;
- -- Build function to test Valid_Scalars for array type A_Type. Nod is the
- -- Valid_Scalars attribute node, used to insert the function body, and the
- -- value returned is the entity of the constructed function body. We do not
- -- bother to generate a separate spec for this subprogram.
+ (Attr : Node_Id;
+ Formal_Typ : Entity_Id;
+ Array_Typ : Entity_Id;
+ Comp_Typ : Entity_Id) return Entity_Id;
+ -- Validate the components of an array type by means of a function. Return
+ -- the entity of the validation function. The parameters are as follows:
+ --
+ -- * Attr - the 'Valid_Scalars attribute for which the function is
+ -- generated.
+ --
+ -- * Formal_Typ - the type of the generated function's only formal
+ -- parameter.
+ --
+ -- * Array_Typ - the array type whose components are to be validated
+ --
+ -- * Comp_Typ - the component type of the array
function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id;
-- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
function Build_Record_VS_Func
- (R_Type : Entity_Id;
- Nod : Node_Id) return Entity_Id;
- -- Build function to test Valid_Scalars for record type A_Type. Nod is the
- -- Valid_Scalars attribute node, used to insert the function body, and the
- -- value returned is the entity of the constructed function body. We do not
- -- bother to generate a separate spec for this subprogram.
+ (Attr : Node_Id;
+ Formal_Typ : Entity_Id;
+ Rec_Typ : Entity_Id) return Entity_Id;
+ -- Validate the components, discriminants, and variants of a record type by
+ -- means of a function. Return the entity of the validation function. The
+ -- parameters are as follows:
+ --
+ -- * Attr - the 'Valid_Scalars attribute for which the function is
+ -- generated.
+ --
+ -- * Formal_Typ - the type of the generated function's only formal
+ -- parameter.
+ --
+ -- * Rec_Typ - the record type whose internals are to be validated
procedure Compile_Stream_Body_In_Scope
(N : Node_Id;
@@ -219,140 +237,178 @@ package body Exp_Attr is
-------------------------
function Build_Array_VS_Func
- (A_Type : Entity_Id;
- Nod : Node_Id) return Entity_Id
+ (Attr : Node_Id;
+ Formal_Typ : Entity_Id;
+ Array_Typ : Entity_Id;
+ Comp_Typ : Entity_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Nod);
- Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
- Comp_Type : constant Entity_Id := Component_Type (A_Type);
- Body_Stmts : List_Id;
- Index_List : List_Id;
- Formals : List_Id;
-
- function Test_Component return List_Id;
- -- Create one statement to test validity of one component designated by
- -- a full set of indexes. Returns statement list containing test.
-
- function Test_One_Dimension (N : Int) return List_Id;
- -- Create loop to test one dimension of the array. The single statement
- -- in the loop body tests the inner dimensions if any, or else the
- -- single component. Note that this procedure is called recursively,
- -- with N being the dimension to be initialized. A call with N greater
- -- than the number of dimensions simply generates the component test,
- -- terminating the recursion. Returns statement list containing tests.
+ Loc : constant Source_Ptr := Sloc (Attr);
+
+ function Validate_Component
+ (Obj_Id : Entity_Id;
+ Indexes : List_Id) return Node_Id;
+ -- Process a single component denoted by indexes Indexes. Obj_Id denotes
+ -- the entity of the validation parameter. Return the check associated
+ -- with the component.
+
+ function Validate_Dimension
+ (Obj_Id : Entity_Id;
+ Dim : Int;
+ Indexes : List_Id) return Node_Id;
+ -- Process dimension Dim of the array type. Obj_Id denotes the entity
+ -- of the validation parameter. Indexes is a list where each dimension
+ -- deposits its loop variable, which will later identify a component.
+ -- Return the loop associated with the current dimension.
- --------------------
- -- Test_Component --
- --------------------
+ ------------------------
+ -- Validate_Component --
+ ------------------------
- function Test_Component return List_Id is
- Comp : Node_Id;
- Anam : Name_Id;
+ function Validate_Component
+ (Obj_Id : Entity_Id;
+ Indexes : List_Id) return Node_Id
+ is
+ Attr_Nam : Name_Id;
begin
- Comp :=
- Make_Indexed_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uA),
- Expressions => Index_List);
-
- if Is_Scalar_Type (Comp_Type) then
- Anam := Name_Valid;
+ if Is_Scalar_Type (Comp_Typ) then
+ Attr_Nam := Name_Valid;
else
- Anam := Name_Valid_Scalars;
+ Attr_Nam := Name_Valid_Scalars;
end if;
- return New_List (
+ -- Generate:
+ -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
+ -- return False;
+ -- end if;
+
+ return
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Attribute_Reference (Loc,
- Attribute_Name => Anam,
- Prefix => Comp)),
+ Prefix =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Array_Typ,
+ New_Occurrence_Of (Obj_Id, Loc)),
+ Expressions => Indexes),
+ Attribute_Name => Attr_Nam)),
+
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Standard_False, Loc)))));
- end Test_Component;
+ Expression => New_Occurrence_Of (Standard_False, Loc))));
+ end Validate_Component;
------------------------
- -- Test_One_Dimension --
+ -- Validate_Dimension --
------------------------
- function Test_One_Dimension (N : Int) return List_Id is
+ function Validate_Dimension
+ (Obj_Id : Entity_Id;
+ Dim : Int;
+ Indexes : List_Id) return Node_Id
+ is
Index : Entity_Id;
begin
- -- If all dimensions dealt with, we simply test the component
+ -- Validate the component once all dimensions have produced their
+ -- individual loops.
- if N > Number_Dimensions (A_Type) then
- return Test_Component;
+ if Dim > Number_Dimensions (Array_Typ) then
+ return Validate_Component (Obj_Id, Indexes);
- -- Here we generate the required loop
+ -- Process the current dimension
else
Index :=
- Make_Defining_Identifier (Loc, New_External_Name ('J', N));
+ Make_Defining_Identifier (Loc, New_External_Name ('J', Dim));
+
+ Append_To (Indexes, New_Occurrence_Of (Index, Loc));
- Append (New_Occurrence_Of (Index, Loc), Index_List);
+ -- Generate:
+ -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
+ -- for JN in Array_Typ (Obj_Id)'Range (N) loop
+ -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
+ -- end loop;
+ -- end loop;
- return New_List (
- Make_Implicit_Loop_Statement (Nod,
- Identifier => Empty,
+ return
+ Make_Implicit_Loop_Statement (Attr,
+ Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Index,
+ Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uA),
+ Prefix =>
+ Unchecked_Convert_To (Array_Typ,
+ New_Occurrence_Of (Obj_Id, Loc)),
Attribute_Name => Name_Range,
Expressions => New_List (
- Make_Integer_Literal (Loc, N))))),
- Statements => Test_One_Dimension (N + 1)),
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Standard_True, Loc)));
+ Make_Integer_Literal (Loc, Dim))))),
+ Statements => New_List (
+ Validate_Dimension (Obj_Id, Dim + 1, Indexes)));
end if;
- end Test_One_Dimension;
+ end Validate_Dimension;
+
+ -- Local variables
+
+ Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
+ Indexes : constant List_Id := New_List;
+ Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
+ Stmts : List_Id;
-- Start of processing for Build_Array_VS_Func
begin
- Index_List := New_List;
- Body_Stmts := Test_One_Dimension (1);
+ Stmts := New_List (Validate_Dimension (Obj_Id, 1, Indexes));
- -- Parameter is always (A : A_Typ)
+ -- Generate:
+ -- return True;
- Formals := New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
- In_Present => True,
- Out_Present => False,
- Parameter_Type => New_Occurrence_Of (A_Type, Loc)));
+ Append_To (Stmts,
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_True, Loc)));
- -- Build body
+ -- Generate:
+ -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
+ -- begin
+ -- Stmts
+ -- end Func_Id;
Set_Ekind (Func_Id, E_Function);
Set_Is_Internal (Func_Id);
+ Set_Is_Pure (Func_Id);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Func_Id);
+ end if;
- Insert_Action (Nod,
+ Insert_Action (Attr,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
- Parameter_Specifications => Formals,
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)),
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Obj_Id,
+ In_Present => True,
+ Out_Present => False,
+ Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Body_Stmts)));
+ Statements => Stmts)));
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (Func_Id);
- end if;
-
- Set_Is_Pure (Func_Id);
return Func_Id;
end Build_Array_VS_Func;
@@ -379,281 +435,394 @@ package body Exp_Attr is
-- Build_Record_VS_Func --
--------------------------
- -- Generates:
-
- -- function _Valid_Scalars (X : T) return Boolean is
- -- begin
- -- -- Check discriminants
-
- -- if not X.D1'Valid_Scalars or else
- -- not X.D2'Valid_Scalars or else
- -- ...
- -- then
- -- return False;
- -- end if;
-
- -- -- Check components
-
- -- if not X.C1'Valid_Scalars or else
- -- not X.C2'Valid_Scalars or else
- -- ...
- -- then
- -- return False;
- -- end if;
-
- -- -- Check variant part
-
- -- case X.D1 is
- -- when V1 =>
- -- if not X.C2'Valid_Scalars or else
- -- not X.C3'Valid_Scalars or else
- -- ...
- -- then
- -- return False;
- -- end if;
- -- ...
- -- when Vn =>
- -- if not X.Cn'Valid_Scalars or else
- -- ...
- -- then
- -- return False;
- -- end if;
- -- end case;
-
- -- return True;
- -- end _Valid_Scalars;
-
- -- If the record type is an unchecked union, we can only check components
- -- in the invariant part, given that there are no discriminant values to
- -- select a variant.
-
function Build_Record_VS_Func
- (R_Type : Entity_Id;
- Nod : Node_Id) return Entity_Id
+ (Attr : Node_Id;
+ Formal_Typ : Entity_Id;
+ Rec_Typ : Entity_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (R_Type);
- Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
- X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
-
- function Make_VS_Case
- (E : Entity_Id;
- CL : Node_Id;
- Discrs : Elist_Id := New_Elmt_List) return List_Id;
- -- Building block for variant valid scalars. Given a Component_List node
- -- CL, it generates an 'if' followed by a 'case' statement that compares
- -- all components of local temporaries named X and Y (that are declared
- -- as formals at some upper level). E provides the Sloc to be used for
- -- the generated code.
-
- function Make_VS_If
- (E : Entity_Id;
- L : List_Id) return Node_Id;
- -- Building block for variant validate scalars. Given the list, L, of
- -- components (or discriminants) L, it generates a return statement that
- -- compares all components of local temporaries named X and Y (that are
- -- declared as formals at some upper level). E provides the Sloc to be
- -- used for the generated code.
+ -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
+ -- It generates code only when there are components, discriminants,
+ -- or variant parts to validate.
+
+ -- NOTE: The routines within Build_Record_VS_Func are intentionally
+ -- unnested to avoid deep indentation of code.
+
+ Loc : constant Source_Ptr := Sloc (Attr);
+
+ procedure Validate_Component_List
+ (Obj_Id : Entity_Id;
+ Comp_List : Node_Id;
+ Stmts : in out List_Id);
+ -- Process all components and variant parts of component list Comp_List.
+ -- Obj_Id denotes the entity of the validation parameter. All new code
+ -- is added to list Stmts.
+
+ procedure Validate_Field
+ (Obj_Id : Entity_Id;
+ Field : Node_Id;
+ Cond : in out Node_Id);
+ -- Process component declaration or discriminant specification Field.
+ -- Obj_Id denotes the entity of the validation parameter. Cond denotes
+ -- an "or else" conditional expression which contains the new code (if
+ -- any).
+
+ procedure Validate_Fields
+ (Obj_Id : Entity_Id;
+ Fields : List_Id;
+ Stmts : in out List_Id);
+ -- Process component declarations or discriminant specifications in list
+ -- Fields. Obj_Id denotes the entity of the validation parameter. All
+ -- new code is added to list Stmts.
+
+ procedure Validate_Variant
+ (Obj_Id : Entity_Id;
+ Var : Node_Id;
+ Alts : in out List_Id);
+ -- Process variant Var. Obj_Id denotes the entity of the validation
+ -- parameter. Alts denotes a list of case statement alternatives which
+ -- contains the new code (if any).
+
+ procedure Validate_Variant_Part
+ (Obj_Id : Entity_Id;
+ Var_Part : Node_Id;
+ Stmts : in out List_Id);
+ -- Process variant part Var_Part. Obj_Id denotes the entity of the
+ -- validation parameter. All new code is added to list Stmts.
- ------------------
- -- Make_VS_Case --
- ------------------
+ -----------------------------
+ -- Validate_Component_List --
+ -----------------------------
- -- <Make_VS_If on shared components>
+ procedure Validate_Component_List
+ (Obj_Id : Entity_Id;
+ Comp_List : Node_Id;
+ Stmts : in out List_Id)
+ is
+ Var_Part : constant Node_Id := Variant_Part (Comp_List);
- -- case X.D1 is
- -- when V1 => <Make_VS_Case> on subcomponents
- -- ...
- -- when Vn => <Make_VS_Case> on subcomponents
- -- end case;
+ begin
+ -- Validate all components
+
+ Validate_Fields
+ (Obj_Id => Obj_Id,
+ Fields => Component_Items (Comp_List),
+ Stmts => Stmts);
+
+ -- Validate the variant part
+
+ if Present (Var_Part) then
+ Validate_Variant_Part
+ (Obj_Id => Obj_Id,
+ Var_Part => Var_Part,
+ Stmts => Stmts);
+ end if;
+ end Validate_Component_List;
+
+ --------------------
+ -- Validate_Field --
+ --------------------
- function Make_VS_Case
- (E : Entity_Id;
- CL : Node_Id;
- Discrs : Elist_Id := New_Elmt_List) return List_Id
+ procedure Validate_Field
+ (Obj_Id : Entity_Id;
+ Field : Node_Id;
+ Cond : in out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (E);
- Result : constant List_Id := New_List;
- Variant : Node_Id;
- Alt_List : List_Id;
+ Field_Id : constant Entity_Id := Defining_Entity (Field);
+ Field_Nam : constant Name_Id := Chars (Field_Id);
+ Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
+ Attr_Nam : Name_Id;
begin
- Append_To (Result, Make_VS_If (E, Component_Items (CL)));
+ -- Do not process internally-generated fields. Note that checking for
+ -- Comes_From_Source is not correct because this will eliminate the
+ -- components within the corresponding record of a protected type.
- if No (Variant_Part (CL))
- or else Is_Unchecked_Union (R_Type)
+ if Nam_In (Field_Nam, Name_uObject,
+ Name_uParent,
+ Name_uTag)
then
- return Result;
- end if;
+ null;
+
+ -- Do not process fields without any scalar components
- Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
+ elsif not Scalar_Part_Present (Field_Typ) then
+ null;
+
+ -- Otherwise the field needs to be validated. Use Make_Identifier
+ -- rather than New_Occurrence_Of to identify the field because the
+ -- wrong entity may be picked up when private types are involved.
+
+ -- Generate:
+ -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
+
+ else
+ if Is_Scalar_Type (Field_Typ) then
+ Attr_Nam := Name_Valid;
+ else
+ Attr_Nam := Name_Valid_Scalars;
+ end if;
- if No (Variant) then
- return Result;
+ Evolve_Or_Else (Cond,
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Rec_Typ,
+ New_Occurrence_Of (Obj_Id, Loc)),
+ Selector_Name => Make_Identifier (Loc, Field_Nam)),
+ Attribute_Name => Attr_Nam)));
end if;
+ end Validate_Field;
- Alt_List := New_List;
- while Present (Variant) loop
- Append_To (Alt_List,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
- Statements =>
- Make_VS_Case (E, Component_List (Variant), Discrs)));
- Next_Non_Pragma (Variant);
- end loop;
+ ---------------------
+ -- Validate_Fields --
+ ---------------------
- Append_To (Result,
- Make_Case_Statement (Loc,
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_X),
- Selector_Name => New_Copy (Name (Variant_Part (CL)))),
- Alternatives => Alt_List));
+ procedure Validate_Fields
+ (Obj_Id : Entity_Id;
+ Fields : List_Id;
+ Stmts : in out List_Id)
+ is
+ Cond : Node_Id;
+ Field : Node_Id;
+
+ begin
+ -- Assume that none of the fields are eligible for verification
- return Result;
- end Make_VS_Case;
+ Cond := Empty;
- ----------------
- -- Make_VS_If --
- ----------------
+ -- Validate all fields
- -- Generates:
+ Field := First_Non_Pragma (Fields);
+ while Present (Field) loop
+ Validate_Field
+ (Obj_Id => Obj_Id,
+ Field => Field,
+ Cond => Cond);
- -- if
- -- not X.C1'Valid_Scalars
- -- or else
- -- not X.C2'Valid_Scalars
- -- ...
- -- then
- -- return False;
- -- end if;
+ Next_Non_Pragma (Field);
+ end loop;
- -- or a null statement if the list L is empty
+ -- Generate:
+ -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
+ -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
- function Make_VS_If
- (E : Entity_Id;
- L : List_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (E);
- C : Node_Id;
- Def_Id : Entity_Id;
- Field_Name : Name_Id;
- Cond : Node_Id;
+ if Present (Cond) then
+ Append_New_To (Stmts,
+ Make_Implicit_If_Statement (Attr,
+ Condition => Cond,
+ Then_Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_False, Loc)))));
+ end if;
+ end Validate_Fields;
- begin
- if No (L) then
- return Make_Null_Statement (Loc);
+ ----------------------
+ -- Validate_Variant --
+ ----------------------
- else
- Cond := Empty;
+ procedure Validate_Variant
+ (Obj_Id : Entity_Id;
+ Var : Node_Id;
+ Alts : in out List_Id)
+ is
+ Stmts : List_Id;
- C := First_Non_Pragma (L);
- while Present (C) loop
- Def_Id := Defining_Identifier (C);
- Field_Name := Chars (Def_Id);
+ begin
+ -- Assume that none of the components and variants are eligible for
+ -- verification.
- -- The tags need not be checked since they will always be valid
+ Stmts := No_List;
- -- Note also that in the following, we use Make_Identifier for
- -- the component names. Use of New_Occurrence_Of to identify
- -- the components would be incorrect because wrong entities for
- -- discriminants could be picked up in the private type case.
+ -- Validate componants
- -- Don't bother with abstract parent in interface case
+ Validate_Component_List
+ (Obj_Id => Obj_Id,
+ Comp_List => Component_List (Var),
+ Stmts => Stmts);
- if Field_Name = Name_uParent
- and then Is_Interface (Etype (Def_Id))
- then
- null;
+ -- Generate a null statement in case none of the components were
+ -- verified because this will otherwise eliminate an alternative
+ -- from the variant case statement and render the generated code
+ -- illegal.
- -- Don't bother with tag, always valid, and not scalar anyway
+ if No (Stmts) then
+ Append_New_To (Stmts, Make_Null_Statement (Loc));
+ end if;
- elsif Field_Name = Name_uTag then
- null;
+ -- Generate:
+ -- when Discrete_Choices =>
+ -- Stmts
+
+ Append_New_To (Alts,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_Copy_List_Tree (Discrete_Choices (Var)),
+ Statements => Stmts));
+ end Validate_Variant;
+
+ ---------------------------
+ -- Validate_Variant_Part --
+ ---------------------------
+
+ procedure Validate_Variant_Part
+ (Obj_Id : Entity_Id;
+ Var_Part : Node_Id;
+ Stmts : in out List_Id)
+ is
+ Vars : constant List_Id := Variants (Var_Part);
+ Alts : List_Id;
+ Var : Node_Id;
- elsif Ekind (Def_Id) = E_Discriminant
- and then Is_Unchecked_Union (R_Type)
- then
- null;
+ begin
+ -- Assume that none of the variants are eligible for verification
- -- Don't bother with component with no scalar components
+ Alts := No_List;
- elsif not Scalar_Part_Present (Etype (Def_Id)) then
- null;
+ -- Validate variants
- -- Normal case, generate Valid_Scalars attribute reference
+ Var := First_Non_Pragma (Vars);
+ while Present (Var) loop
+ Validate_Variant
+ (Obj_Id => Obj_Id,
+ Var => Var,
+ Alts => Alts);
- else
- Evolve_Or_Else (Cond,
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_X),
- Selector_Name =>
- Make_Identifier (Loc, Field_Name)),
- Attribute_Name => Name_Valid_Scalars)));
- end if;
+ Next_Non_Pragma (Var);
+ end loop;
- Next_Non_Pragma (C);
- end loop;
+ -- Even though individual variants may lack eligible components, the
+ -- alternatives must still be generated.
- if No (Cond) then
- return Make_Null_Statement (Loc);
+ pragma Assert (Present (Alts));
- else
- return
- Make_Implicit_If_Statement (E,
- Condition => Cond,
- Then_Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression =>
- New_Occurrence_Of (Standard_False, Loc))));
- end if;
- end if;
- end Make_VS_If;
+ -- Generate:
+ -- case Rec_Typ (Obj_Id).Discriminant is
+ -- when Discrete_Choices_1 =>
+ -- Stmts_1
+ -- when Discrete_Choices_N =>
+ -- Stmts_N
+ -- end case;
+
+ Append_New_To (Stmts,
+ Make_Case_Statement (Loc,
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Rec_Typ,
+ New_Occurrence_Of (Obj_Id, Loc)),
+ Selector_Name => New_Copy_Tree (Name (Var_Part))),
+ Alternatives => Alts));
+ end Validate_Variant_Part;
-- Local variables
- Def : constant Node_Id := Parent (R_Type);
- Comps : constant Node_Id := Component_List (Type_Definition (Def));
- Stmts : constant List_Id := New_List;
- Pspecs : constant List_Id := New_List;
+ Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
+ Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
+ Rec_Decl : constant Node_Id := Declaration_Node (Rec_Typ);
+ Rec_Def : constant Node_Id := Type_Definition (Rec_Decl);
+ Stmts : List_Id;
-- Start of processing for Build_Record_VS_Func
begin
- Append_To (Pspecs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => X,
- Parameter_Type => New_Occurrence_Of (R_Type, Loc)));
+ -- The code generated by this routine is as follows:
+ --
+ -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
+ -- begin
+ -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
+ -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
+ --
+ -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
+ -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
+ --
+ -- case Discriminant_1 is
+ -- when Choice_1 =>
+ -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
+ -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
+ --
+ -- case Discriminant_N is
+ -- ...
+ -- when Choice_N =>
+ -- ...
+ -- end case;
+ --
+ -- return True;
+ -- end Func_Id;
- Append_To (Stmts,
- Make_VS_If (R_Type, Discriminant_Specifications (Def)));
- Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
+ -- Assume that the record type lacks eligible components, discriminants,
+ -- and variant parts.
- Append_To (Stmts,
+ Stmts := No_List;
+
+ -- Validate the discriminants
+
+ if not Is_Unchecked_Union (Rec_Typ) then
+ Validate_Fields
+ (Obj_Id => Obj_Id,
+ Fields => Discriminant_Specifications (Rec_Decl),
+ Stmts => Stmts);
+ end if;
+
+ -- Validate the components and variant parts
+
+ Validate_Component_List
+ (Obj_Id => Obj_Id,
+ Comp_List => Component_List (Rec_Def),
+ Stmts => Stmts);
+
+ -- Generate:
+ -- return True;
+
+ Append_New_To (Stmts,
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)));
- Insert_Action (Nod,
+ -- Generate:
+ -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
+ -- begin
+ -- Stmts
+ -- end Func_Id;
+
+ Set_Ekind (Func_Id, E_Function);
+ Set_Is_Internal (Func_Id);
+ Set_Is_Pure (Func_Id);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Func_Id);
+ end if;
+
+ Insert_Action (Attr,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
- Parameter_Specifications => Pspecs,
- Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Obj_Id,
+ Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)),
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts)),
Suppress => Discriminant_Check);
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (Func_Id);
- end if;
-
- Set_Is_Pure (Func_Id);
return Func_Id;
end Build_Record_VS_Func;
@@ -6501,7 +6670,6 @@ package body Exp_Attr is
when Attribute_Valid => Valid : declare
Btyp : Entity_Id := Base_Type (Ptyp);
- Tst : Node_Id;
Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
-- Save the validity checking mode. We always turn off validity
@@ -6565,6 +6733,10 @@ package body Exp_Attr is
Attribute_Name => Name_Last))));
end Make_Range_Test;
+ -- Local variables
+
+ Tst : Node_Id;
+
-- Start of processing for Attribute_Valid
begin
@@ -6893,105 +7065,82 @@ package body Exp_Attr is
-------------------
when Attribute_Valid_Scalars => Valid_Scalars : declare
- Ftyp : Entity_Id;
+ Val_Typ : constant Entity_Id := Validated_View (Ptyp);
+ Comp_Typ : Entity_Id;
+ Expr : Node_Id;
begin
- if Present (Underlying_Type (Ptyp)) then
- Ftyp := Underlying_Type (Ptyp);
- else
- Ftyp := Ptyp;
- end if;
+ -- Assume that the prefix does not need validation
- -- Replace by True if no scalar parts
+ Expr := Empty;
- if not Scalar_Part_Present (Ftyp) then
- Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
-
- -- For scalar types, Valid_Scalars is the same as Valid
-
- elsif Is_Scalar_Type (Ftyp) then
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Valid,
- Prefix => Pref));
+ -- Attribute 'Valid_Scalars is not supported on private tagged types
- -- For array types, we construct a function that determines if there
- -- are any non-valid scalar subcomponents, and call the function.
- -- We only do this for arrays whose component type needs checking
+ if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then
+ null;
- elsif Is_Array_Type (Ftyp)
- and then Scalar_Part_Present (Component_Type (Ftyp))
- then
- Rewrite (N,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
- Parameter_Associations => New_List (Pref)));
+ -- Attribute 'Valid_Scalars evaluates to True when the type lacks
+ -- scalars.
- -- For record types, we construct a function that determines if there
- -- are any non-valid scalar subcomponents, and call the function.
+ elsif not Scalar_Part_Present (Val_Typ) then
+ null;
- elsif Is_Record_Type (Ftyp)
- and then Present (Declaration_Node (Ftyp))
- and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
- N_Record_Definition
- then
- Rewrite (N,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
- Parameter_Associations => New_List (Pref)));
+ -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
+ -- validated type is a scalar type. Generate:
- -- Other record types or types with discriminants
+ -- Val_Typ (Pref)'Valid
- elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
+ elsif Is_Scalar_Type (Val_Typ) then
+ Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)),
+ Attribute_Name => Name_Valid);
- -- Build expression with list of equality tests
+ -- Validate the scalar components of an array by iterating over all
+ -- dimensions of the array while checking individual components.
- declare
- C : Entity_Id;
- X : Node_Id;
- A : Name_Id;
+ elsif Is_Array_Type (Val_Typ) then
+ Comp_Typ := Validated_View (Component_Type (Val_Typ));
- begin
- X := New_Occurrence_Of (Standard_True, Loc);
- C := First_Component_Or_Discriminant (Ptyp);
- while Present (C) loop
- if not Scalar_Part_Present (Etype (C)) then
- goto Continue;
- elsif Is_Scalar_Type (Etype (C)) then
- A := Name_Valid;
- else
- A := Name_Valid_Scalars;
- end if;
+ if Scalar_Part_Present (Comp_Typ) then
+ Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Build_Array_VS_Func
+ (Attr => N,
+ Formal_Typ => Ptyp,
+ Array_Typ => Val_Typ,
+ Comp_Typ => Comp_Typ),
+ Loc),
+ Parameter_Associations => New_List (Pref));
+ end if;
- X :=
- Make_And_Then (Loc,
- Left_Opnd => X,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => A,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr (Pref, Name_Req => True),
- Selector_Name =>
- New_Occurrence_Of (C, Loc))));
- <<Continue>>
- Next_Component_Or_Discriminant (C);
- end loop;
+ -- Validate the scalar components, discriminants of a record type by
+ -- examining the structure of a record type.
- Rewrite (N, X);
- end;
+ elsif Is_Record_Type (Val_Typ) then
+ Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Build_Record_VS_Func
+ (Attr => N,
+ Formal_Typ => Ptyp,
+ Rec_Typ => Val_Typ),
+ Loc),
+ Parameter_Associations => New_List (Pref));
+ end if;
- -- For all other types, result is True
+ -- Default the attribute to True when the type of the prefix does not
+ -- need validation.
- else
- Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
+ if No (Expr) then
+ Expr := New_Occurrence_Of (Standard_True, Loc);
end if;
- -- Result is always boolean, but never static
-
+ Rewrite (N, Expr);
Analyze_And_Resolve (N, Standard_Boolean);
Set_Is_Static_Expression (N, False);
end Valid_Scalars;
--- gcc/ada/gnat_rm.texi
+++ 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
+++ 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
+++ 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
+++ 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