diff options
Diffstat (limited to 'gcc/ada/exp_attr.adb')
| -rw-r--r-- | gcc/ada/exp_attr.adb | 234 |
1 files changed, 233 insertions, 1 deletions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b8058ae2442..355770186db 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)))); + <<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; ----------- |