From f16cb8dfb93a424887b543015c1e0cfc73ec2fe3 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 22 May 2018 13:23:35 +0000 Subject: [PATCH] [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 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 | 17 + .../gnat_rm/implementation_defined_attributes.rst | 51 +- gcc/ada/exp_attr.adb | 921 ++++++++++++--------- gcc/ada/gnat_rm.texi | 51 +- gcc/ada/sem_attr.adb | 88 +- gcc/ada/sem_util.adb | 66 +- gcc/ada/sem_util.ads | 14 +- 7 files changed, 723 insertions(+), 485 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6f73f88..76000d2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2018-05-22 Hristian Kirtchev + + * 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 * binde.adb: (Choose): Ignore a pragma Elaborate_Body that appears in diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index 6f03223..0b4f780 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 9a00c4b..c29aa80 100644 --- a/gcc/ada/exp_attr.adb +++ b/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 -- + ----------------------------- - -- + 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 => on subcomponents - -- ... - -- when Vn => 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)))); - <> - 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; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b21f1da..387e2a0 100644 --- a/gcc/ada/gnat_rm.texi +++ b/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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 9cc3055..6e87453 100644 --- a/gcc/ada/sem_attr.adb +++ b/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 -- ----------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 8f0fcd3..9708430 100644 --- a/gcc/ada/sem_util.adb +++ b/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 -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 7266ffa..0283ad7 100644 --- a/gcc/ada/sem_util.ads +++ b/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 -- 2.7.4