This patch implements the new Valid_Scalars attribute (that tests all
scalar parts of an object including discriminabnts and subcomponents,
to ensure they are valid. All cases are handled (including multi-
dimensional arrays) except for variant records which will be
implemented in a separate step.
The following shows warnings that are generated (compiled with -gnatc,
-gnatld7 -gnatj60)
1. package ValidScalarsW is
2. type Ptr is access Integer;
3.
4. type Rec is tagged record
5. A, B : Ptr;
6. end record;
7.
8. type RecN is new Rec with record
9. X : Integer;
10. end record;
11.
12. type Arr is array (1 .. 10) of Ptr;
13.
14. V1 : Ptr;
15. V2 : Rec;
16. V3 : Rec'Class := V2;
17. V4 : Arr;
18.
19. M1 : Boolean := V1'Valid_Scalars;
|
>>> warning: attribute "Valid_Scalars" always True,
no scalars to check
20. M2 : Boolean := V2'Valid_Scalars;
|
>>> warning: attribute "Valid_Scalars" always True,
no scalars to check
21. M3 : Boolean := V3'Valid_Scalars;
|
>>> warning: attribute "Valid_Scalars" always True,
no scalars to check
22. M4 : Boolean := V4'Valid_Scalars;
|
>>> warning: attribute "Valid_Scalars" always True,
no scalars to check
23. end ValidScalarsW;
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-04-02 Robert Dewar <de...@adacore.com>
* einfo.adb (First_Component_Or_Discriminant) Now applies to
all types with discriminants, not just records.
* exp_attr.adb (Expand_N_Attribute): Add Scalar_Values handling
for arrays, scalars and non-variant records.
* sem_attr.adb (Analyze_Attribute): Handle Valid_Scalars
* sem_attr.ads (Valid_Scalars): Update description
* sem_util.ads, sem_util.adb (No_Scalar_Parts): New function.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 186067)
+++ exp_attr.adb (working copy)
@@ -76,6 +76,14 @@
-- Local Subprograms --
-----------------------
+ 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.
+
procedure Compile_Stream_Body_In_Scope
(N : Node_Id;
Decl : Node_Id;
@@ -174,6 +182,149 @@
-- expansion. Typically used for rounding and truncation attributes that
-- appear directly inside a conversion to integer.
+ -------------------------
+ -- Build_Array_VS_Func --
+ -------------------------
+
+ function Build_Array_VS_Func
+ (A_Type : Entity_Id;
+ Nod : Node_Id) return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Nod);
+ Comp_Type : constant Entity_Id := Component_Type (A_Type);
+ Body_Stmts : List_Id;
+ Index_List : List_Id;
+ Func_Id : Entity_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.
+
+ --------------------
+ -- Test_Component --
+ --------------------
+
+ function Test_Component return List_Id is
+ Comp : Node_Id;
+ Anam : 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;
+ else
+ Anam := Name_Valid_Scalars;
+ end if;
+
+ return New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Anam,
+ Prefix => Comp)),
+ Then_Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_False, Loc)))));
+ end Test_Component;
+
+ ------------------------
+ -- Test_One_Dimension --
+ ------------------------
+
+ function Test_One_Dimension (N : Int) return List_Id is
+ Index : Entity_Id;
+
+ begin
+ -- If all dimensions dealt with, we simply test the component
+
+ if N > Number_Dimensions (A_Type) then
+ return Test_Component;
+
+ -- Here we generate the required loop
+
+ else
+ Index :=
+ Make_Defining_Identifier (Loc, New_External_Name ('J', N));
+
+ Append (New_Reference_To (Index, Loc), Index_List);
+
+ return New_List (
+ Make_Implicit_Loop_Statement (Nod,
+ Identifier => Empty,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Index,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_uA),
+ 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)));
+ end if;
+ end Test_One_Dimension;
+
+ -- Start of processing for Build_Array_VS_Func
+
+ begin
+ Index_List := New_List;
+ Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
+
+ Body_Stmts := Test_One_Dimension (1);
+
+ -- Parameter is always (A : A_Typ)
+
+ Formals := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
+ In_Present => True,
+ Out_Present => False,
+ Parameter_Type => New_Reference_To (A_Type, Loc)));
+
+ -- Build body
+
+ Set_Ekind (Func_Id, E_Function);
+ Set_Is_Internal (Func_Id);
+
+ Insert_Action (Nod,
+ 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)),
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Body_Stmts)));
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Func_Id);
+ end if;
+
+ return Func_Id;
+ end Build_Array_VS_Func;
+
----------------------------------
-- Compile_Stream_Body_In_Scope --
----------------------------------
@@ -5373,8 +5524,89 @@
-------------------
when Attribute_Valid_Scalars => Valid_Scalars : declare
+ Ftyp : Entity_Id;
+
begin
- raise Program_Error;
+ if Present (Underlying_Type (Ptyp)) then
+ Ftyp := Underlying_Type (Ptyp);
+ else
+ Ftyp := Ptyp;
+ end if;
+
+ -- For scalar types, Valid_Scalars is the same as Valid
+
+ if Is_Scalar_Type (Ftyp) then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Valid,
+ Prefix => Pref));
+ Analyze_And_Resolve (N, Standard_Boolean);
+
+ -- 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
+
+ elsif Is_Array_Type (Ftyp)
+ and then not No_Scalar_Parts (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)));
+
+ Analyze_And_Resolve (N, Standard_Boolean);
+
+ -- For record types, we build a big conditional expression, applying
+ -- Valid or Valid_Scalars as appropriate to all relevant components.
+
+ elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp))
+ and then not No_Scalar_Parts (Ptyp)
+ then
+ declare
+ C : Entity_Id;
+ X : Node_Id;
+ A : Name_Id;
+
+ begin
+ X := New_Occurrence_Of (Standard_True, Loc);
+ C := First_Component_Or_Discriminant (Ptyp);
+ while Present (C) loop
+ if No_Scalar_Parts (Etype (C)) then
+ goto Continue;
+ elsif Is_Scalar_Type (Etype (C)) then
+ A := Name_Valid;
+ else
+ A := Name_Valid_Scalars;
+ 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;
+
+ Rewrite (N, X);
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end;
+
+ -- For all other types, result is True (but not static)
+
+ else
+ Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
+ Analyze_And_Resolve (N, Standard_Boolean);
+ Set_Is_Static_Expression (N, False);
+ end if;
end Valid_Scalars;
-----------
Index: einfo.adb
===================================================================
--- einfo.adb (revision 186067)
+++ einfo.adb (working copy)
@@ -5880,7 +5880,9 @@
begin
pragma Assert
- (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id));
+ (Is_Record_Type (Id)
+ or else Is_Incomplete_Or_Private_Type (Id)
+ or else Has_Discriminants (Id));
Comp_Id := First_Entity (Id);
while Present (Comp_Id) loop
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 186067)
+++ sem_util.adb (working copy)
@@ -10499,6 +10499,34 @@
Actual_Id := Next_Actual (Actual_Id);
end Next_Actual;
+ ---------------------
+ -- No_Scalar_Parts --
+ ---------------------
+
+ function No_Scalar_Parts (T : Entity_Id) return Boolean is
+ C : Entity_Id;
+
+ begin
+ if Is_Scalar_Type (T) then
+ return False;
+
+ elsif Is_Array_Type (T) then
+ return No_Scalar_Parts (Component_Type (T));
+
+ elsif Is_Record_Type (T) or else Has_Discriminants (T) then
+ C := First_Component_Or_Discriminant (T);
+ while Present (C) loop
+ if not No_Scalar_Parts (Etype (C)) then
+ return False;
+ else
+ Next_Component_Or_Discriminant (C);
+ end if;
+ end loop;
+ end if;
+
+ return True;
+ end No_Scalar_Parts;
+
-----------------------
-- Normalize_Actuals --
-----------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 186067)
+++ sem_util.ads (working copy)
@@ -1221,6 +1221,11 @@
-- Note that the result produced is always an expression, not a parameter
-- association node, even if named notation was used.
+ function No_Scalar_Parts (T : Entity_Id) return Boolean;
+ -- Tests if type T can be determined at compile time to have no scalar
+ -- parts in the sense of the Valid_Scalars attribute. Returns True if
+ -- this is the case, meaning that the result of Valid_Scalars is True.
+
procedure Normalize_Actuals
(N : Node_Id;
S : Entity_Id;
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 186067)
+++ sem_attr.adb (working copy)
@@ -323,7 +323,7 @@
-- type or a private type for which no full view has been given.
procedure Check_Object_Reference (P : Node_Id);
- -- Check that P (the prefix of the attribute) is an object reference
+ -- Check that P is an object reference
procedure Check_Program_Unit;
-- Verify that prefix of attribute N is a program unit
@@ -5202,9 +5202,14 @@
when Attribute_Valid_Scalars =>
Check_E0;
- Check_Type;
- -- More stuff TBD ???
+ Check_Object_Reference (P);
+ if No_Scalar_Parts (P_Type) then
+ Error_Attr_P ("?attribute % always True, no scalars to check");
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
-----------
-- Value --
-----------
Index: sem_attr.ads
===================================================================
--- sem_attr.ads (revision 186067)
+++ sem_attr.ads (working copy)
@@ -560,13 +560,19 @@
-- For a scalar type, the result is the same as obj'Valid
--
-- For an array object, the result is True if the result of applying
- -- Valid_Scalars to every component is True.
+ -- Valid_Scalars to every component is True. For an empty array the
+ -- result is True.
--
-- For a record object, the result is True if the result of applying
-- Valid_Scalars to every component is True. For class-wide types,
-- only the components of the base type are checked. For variant
- -- records, only the components actually present are checked.
+ -- records, only the components actually present are checked. The
+ -- discriminants, if any, are also checked. If there are no components
+ -- or discriminants, the result is True.
--
+ -- For any other type that has discriminants, the result is True if
+ -- the result of applying Valid_Scalars to each discriminant is True.
+ --
-- For all other types, the result is always True
--
-- A warning is given for a trivially True result, when the attribute
@@ -574,7 +580,7 @@
-- type, or in the composite case if no scalar subcomponents exist. For
-- a variant record, the warning is given only if none of the variants
-- have scalar subcomponents. In addition, the warning is suppressed
- -- for private types, or generic types in an instance.
+ -- for private types, or generic formal types in an instance.
----------------
-- Value_Size --
