From 99fc068ee807cc43779d775a3dda705f5f37c4f5 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Mon, 2 Apr 2012 09:14:47 +0000 Subject: [PATCH] 2012-04-02 Robert Dewar * 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. From-SVN: r186069 --- gcc/ada/ChangeLog | 10 +++ gcc/ada/einfo.adb | 4 +- gcc/ada/exp_attr.adb | 234 ++++++++++++++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_attr.adb | 11 ++- gcc/ada/sem_attr.ads | 12 ++- gcc/ada/sem_util.adb | 28 ++++++ gcc/ada/sem_util.ads | 5 ++ 7 files changed, 296 insertions(+), 8 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 39a5be5..b8155a1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2012-04-02 Robert Dewar + + * 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. + 2012-03-31 Eric Botcazou Revert diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 0fdc83c..0f597a1 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -5880,7 +5880,9 @@ package body Einfo is 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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b8058ae..3557701 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -76,6 +76,14 @@ package body Exp_Attr is -- 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 @@ package body Exp_Attr is -- 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 @@ package body Exp_Attr is ------------------- 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)))); + <> + 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; ----------- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 77db15e..10af9e2 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -323,7 +323,7 @@ package body Sem_Attr is -- 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,8 +5202,13 @@ package body Sem_Attr is 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 -- diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 45e1bc0..7258593 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -560,12 +560,18 @@ package Sem_Attr is -- 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 -- @@ -574,7 +580,7 @@ package Sem_Attr is -- 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 -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 50200e7..e07d5bb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10499,6 +10499,34 @@ package body Sem_Util is 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 -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 34d2fc0..607bd8e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1221,6 +1221,11 @@ package Sem_Util is -- 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; -- 2.7.4