Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/exp_attr.adb @ 131:84e7813d76e9
gcc-8.2
| author | mir3636 |
|---|---|
| date | Thu, 25 Oct 2018 07:37:49 +0900 |
| parents | 04ced10e8804 |
| children | 1830386684a0 |
line wrap: on
line diff
--- a/gcc/ada/exp_attr.adb Fri Oct 27 22:46:09 2017 +0900 +++ b/gcc/ada/exp_attr.adb Thu Oct 25 07:37:49 2018 +0900 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -75,23 +75,41 @@ ----------------------- 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 @@ ------------------------- 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. - - -------------------- - -- Test_Component -- - -------------------- - - function Test_Component return List_Id is - Comp : Node_Id; - Anam : Name_Id; + 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. + + ------------------------ + -- Validate_Component -- + ------------------------ + + 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 - - if N > Number_Dimensions (A_Type) then - return Test_Component; - - -- Here we generate the required loop + -- Validate the component once all dimensions have produced their + -- individual loops. + + if Dim > Number_Dimensions (Array_Typ) then + return Validate_Component (Obj_Id, Indexes); + + -- Process the current dimension else Index := - Make_Defining_Identifier (Loc, New_External_Name ('J', N)); - - Append (New_Occurrence_Of (Index, Loc), Index_List); - - return New_List ( - Make_Implicit_Loop_Statement (Nod, - Identifier => Empty, + Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)); + + Append_To (Indexes, New_Occurrence_Of (Index, Loc)); + + -- 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 + 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); - - -- 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_Occurrence_Of (A_Type, Loc))); - - -- Build body + Stmts := New_List (Validate_Dimension (Obj_Id, 1, Indexes)); + + -- Generate: + -- return True; + + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_True, Loc))); + + -- 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); - - Insert_Action (Nod, + 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 => 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))); - - if not Debug_Generated_Code then - Set_Debug_Info_Off (Func_Id); - end if; - - Set_Is_Pure (Func_Id); + Statements => Stmts))); + return Func_Id; end Build_Array_VS_Func; @@ -379,281 +435,425 @@ -- 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. - - ------------------ - -- Make_VS_Case -- - ------------------ - - -- <Make_VS_If on shared components> - - -- case X.D1 is - -- when V1 => <Make_VS_Case> on subcomponents - -- ... - -- when Vn => <Make_VS_Case> on subcomponents - -- end case; - - function Make_VS_Case - (E : Entity_Id; - CL : Node_Id; - Discrs : Elist_Id := New_Elmt_List) return List_Id + -- 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. + + ----------------------------- + -- Validate_Component_List -- + ----------------------------- + + procedure Validate_Component_List + (Obj_Id : Entity_Id; + Comp_List : Node_Id; + Stmts : in out List_Id) is - Loc : constant Source_Ptr := Sloc (E); - Result : constant List_Id := New_List; - Variant : Node_Id; - Alt_List : List_Id; + Var_Part : constant Node_Id := Variant_Part (Comp_List); + + 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 -- + -------------------- + + procedure Validate_Field + (Obj_Id : Entity_Id; + Field : Node_Id; + Cond : in out Node_Id) + is + 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))); - - if No (Variant_Part (CL)) - or else Is_Unchecked_Union (R_Type) + -- 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 Nam_In (Field_Nam, Name_uObject, + Name_uParent, + Name_uTag) then - return Result; + null; + + -- Do not process fields without any scalar components + + 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; + + 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; - - Variant := First_Non_Pragma (Variants (Variant_Part (CL))); - - if No (Variant) then - return Result; + end Validate_Field; + + --------------------- + -- Validate_Fields -- + --------------------- + + 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 + + Cond := Empty; + + -- Validate all fields + + Field := First_Non_Pragma (Fields); + while Present (Field) loop + Validate_Field + (Obj_Id => Obj_Id, + Field => Field, + Cond => Cond); + + Next_Non_Pragma (Field); + end loop; + + -- 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; + + 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; - - 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 Validate_Fields; + + ---------------------- + -- Validate_Variant -- + ---------------------- + + procedure Validate_Variant + (Obj_Id : Entity_Id; + Var : Node_Id; + Alts : in out List_Id) + is + Stmts : List_Id; + + begin + -- Assume that none of the components and variants are eligible for + -- verification. + + Stmts := No_List; + + -- Validate componants + + Validate_Component_List + (Obj_Id => Obj_Id, + Comp_List => Component_List (Var), + Stmts => Stmts); + + -- 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. + + if No (Stmts) then + Append_New_To (Stmts, Make_Null_Statement (Loc)); + end if; + + -- 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; + + begin + -- Assume that none of the variants are eligible for verification + + Alts := No_List; + + -- Validate variants + + Var := First_Non_Pragma (Vars); + while Present (Var) loop + Validate_Variant + (Obj_Id => Obj_Id, + Var => Var, + Alts => Alts); + + Next_Non_Pragma (Var); end loop; - Append_To (Result, + -- Even though individual variants may lack eligible components, the + -- alternatives must still be generated. + + pragma Assert (Present (Alts)); + + -- 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 => Make_Identifier (Loc, Name_X), - Selector_Name => New_Copy (Name (Variant_Part (CL)))), - Alternatives => Alt_List)); - - return Result; - end Make_VS_Case; - - ---------------- - -- Make_VS_If -- - ---------------- - - -- Generates: - - -- if - -- not X.C1'Valid_Scalars - -- or else - -- not X.C2'Valid_Scalars - -- ... - -- then - -- return False; - -- end if; - - -- or a null statement if the list L is empty - - 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; - - begin - if No (L) then - return Make_Null_Statement (Loc); - - else - Cond := Empty; - - C := First_Non_Pragma (L); - while Present (C) loop - Def_Id := Defining_Identifier (C); - Field_Name := Chars (Def_Id); - - -- The tags need not be checked since they will always be valid - - -- 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. - - -- Don't bother with abstract parent in interface case - - if Field_Name = Name_uParent - and then Is_Interface (Etype (Def_Id)) - then - null; - - -- Don't bother with tag, always valid, and not scalar anyway - - elsif Field_Name = Name_uTag then - null; - - elsif Ekind (Def_Id) = E_Discriminant - and then Is_Unchecked_Union (R_Type) - then - null; - - -- Don't bother with component with no scalar components - - elsif not Scalar_Part_Present (Etype (Def_Id)) then - null; - - -- Normal case, generate Valid_Scalars attribute reference - - 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 (C); - end loop; - - if No (Cond) then - return Make_Null_Statement (Loc); - - 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; + 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'); + Comps : Node_Id; + Stmts : List_Id; + Typ : Entity_Id; + Typ_Decl : Node_Id; + Typ_Def : Node_Id; + Typ_Ext : Node_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))); - - Append_To (Stmts, - Make_VS_If (R_Type, Discriminant_Specifications (Def))); - Append_List_To (Stmts, Make_VS_Case (R_Type, Comps)); - - Append_To (Stmts, + Typ := Rec_Typ; + + -- Use the root type when dealing with a class-wide type + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Typ_Decl := Declaration_Node (Typ); + Typ_Def := Type_Definition (Typ_Decl); + + -- The components of a derived type are located in the extension part + + if Nkind (Typ_Def) = N_Derived_Type_Definition then + Typ_Ext := Record_Extension_Part (Typ_Def); + + if Present (Typ_Ext) then + Comps := Component_List (Typ_Ext); + else + Comps := Empty; + end if; + + -- Otherwise the components are available in the definition + + else + Comps := Component_List (Typ_Def); + end if; + + -- 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; + + -- Assume that the record type lacks eligible components, discriminants, + -- and variant parts. + + Stmts := No_List; + + -- Validate the discriminants + + if not Is_Unchecked_Union (Rec_Typ) then + Validate_Fields + (Obj_Id => Obj_Id, + Fields => Discriminant_Specifications (Typ_Decl), + Stmts => Stmts); + end if; + + -- Validate the components and variant parts + + Validate_Component_List + (Obj_Id => Obj_Id, + Comp_List => Comps, + 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; @@ -1054,7 +1254,7 @@ Base_Typ : constant Entity_Id := Base_Type (Etype (Pref)); Exprs : constant List_Id := Expressions (N); Aux_Decl : Node_Id; - Blk : Node_Id; + Blk : Node_Id := Empty; Decls : List_Id; Installed : Boolean; Loc : Source_Ptr; @@ -1941,12 +2141,11 @@ Next_Formal (Old_Formal); exit when No (Old_Formal); - Set_Next_Entity (New_Formal, - New_Copy (Old_Formal)); - Next_Entity (New_Formal); + Link_Entities (New_Formal, New_Copy (Old_Formal)); + Next_Entity (New_Formal); end loop; - Set_Next_Entity (New_Formal, Empty); + Unlink_Next_Entity (New_Formal); Set_Last_Entity (Subp_Typ, Extra); end if; @@ -2881,6 +3080,16 @@ -- Protected case if Is_Protected_Type (Conctyp) then + + -- No need to transform 'Count into a function call if the current + -- scope has been eliminated. In this case such transformation is + -- also not viable because the enclosing protected object is not + -- available. + + if Is_Eliminated (Current_Scope) then + return; + end if; + case Corresponding_Runtime_Package (Conctyp) is when System_Tasking_Protected_Objects_Entries => Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc); @@ -3430,6 +3639,10 @@ -- not want this to go through the fixed-point conversion circuits. Note -- that the back end always treats fixed-point as equivalent to the -- corresponding integer type anyway. + -- However, in order to remove the handling of Do_Range_Check from the + -- backend, we force the generation of a check on the result by + -- setting the result type appropriately. Apply_Conversion_Checks + -- will generate the required expansion. when Attribute_Fixed_Value | Attribute_Integer_Value @@ -3438,15 +3651,59 @@ Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), Expression => Relocate_Node (First (Exprs)))); - Set_Etype (N, Entity (Pref)); + + -- Indicate that the result of the conversion may require a + -- range check (see below); + + Set_Etype (N, Base_Type (Entity (Pref))); Set_Analyzed (N); -- Note: it might appear that a properly analyzed unchecked -- conversion would be just fine here, but that's not the case, - -- since the full range checks performed by the following call + -- since the full range checks performed by the following code -- are critical. - - Apply_Type_Conversion_Checks (N); + -- Given that Fixed-point conversions are not further expanded + -- to prevent the involvement of real type operations we have to + -- construct two checks explicitly: one on the operand, and one + -- on the result. This used to be done in part in the back-end, + -- but for other targets (E.g. LLVM) it is preferable to create + -- the tests in full in the front-end. + + if Is_Fixed_Point_Type (Etype (N)) then + declare + Loc : constant Source_Ptr := Sloc (N); + Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Expr : constant Node_Id := Expression (N); + Fst : constant Entity_Id := Root_Type (Etype (N)); + Decl : Node_Id; + + begin + Decl := + Make_Full_Type_Declaration (Sloc (N), + Defining_Identifier => Equiv_T, + Type_Definition => + Make_Signed_Integer_Type_Definition (Loc, + Low_Bound => + Make_Integer_Literal (Loc, + Intval => + Corresponding_Integer_Value + (Type_Low_Bound (Fst))), + High_Bound => + Make_Integer_Literal (Loc, + Intval => + Corresponding_Integer_Value + (Type_High_Bound (Fst))))); + Insert_Action (N, Decl); + + -- Verify that the conversion is possible + + Generate_Range_Check (Expr, Equiv_T, CE_Overflow_Check_Failed); + + -- and verify that the result is in range + + Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed); + end; + end if; ----------- -- Floor -- @@ -6501,12 +6758,11 @@ 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 -- checking during process of 'Valid since this is one place - -- where we do not want the implicit validity checks to intefere + -- where we do not want the implicit validity checks to interfere -- with the explicit validity check that the programmer is doing. function Make_Range_Test return Node_Id; @@ -6565,6 +6821,10 @@ Attribute_Name => Name_Last)))); end Make_Range_Test; + -- Local variables + + Tst : Node_Id; + -- Start of processing for Attribute_Valid begin @@ -6893,105 +7153,82 @@ ------------------- 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; - - -- Replace by True if no scalar parts - - 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, + -- Assume that the prefix does not need validation + + Expr := Empty; + + -- Attribute 'Valid_Scalars is not supported on private tagged types + + if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then + null; + + -- Attribute 'Valid_Scalars evaluates to True when the type lacks + -- scalars. + + elsif not Scalar_Part_Present (Val_Typ) then + null; + + -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the + -- validated type is a scalar type. Generate: + + -- Val_Typ (Pref)'Valid + + elsif Is_Scalar_Type (Val_Typ) then + Expr := Make_Attribute_Reference (Loc, - Attribute_Name => Name_Valid, - Prefix => Pref)); - - -- 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 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))); - - -- For record types, we construct a function that determines if there - -- are any non-valid scalar subcomponents, and call the function. - - 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, + Prefix => + Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)), + Attribute_Name => Name_Valid); + + -- Validate the scalar components of an array by iterating over all + -- dimensions of the array while checking individual components. + + elsif Is_Array_Type (Val_Typ) then + Comp_Typ := Validated_View (Component_Type (Val_Typ)); + + 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; + + -- Validate the scalar components, discriminants of a record type by + -- examining the structure of a record type. + + elsif Is_Record_Type (Val_Typ) then + Expr := Make_Function_Call (Loc, Name => - New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc), - Parameter_Associations => New_List (Pref))); - - -- Other record types or types with discriminants - - elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then - - -- Build expression with list of equality tests - - 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 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; - - 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); - end; - - -- For all other types, result is True - - else - Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc)); + New_Occurrence_Of + (Build_Record_VS_Func + (Attr => N, + Formal_Typ => Ptyp, + Rec_Typ => Val_Typ), + Loc), + Parameter_Associations => New_List (Pref)); end if; - -- Result is always boolean, but never static - + -- Default the attribute to True when the type of the prefix does not + -- need validation. + + if No (Expr) then + Expr := New_Occurrence_Of (Standard_True, Loc); + end if; + + Rewrite (N, Expr); Analyze_And_Resolve (N, Standard_Boolean); Set_Is_Static_Expression (N, False); end Valid_Scalars; @@ -8274,7 +8511,7 @@ -- Start of processing for Is_Inline_Floating_Point_Attribute begin - -- Machine and Model can be expanded by the GCC and AAMP back ends only + -- Machine and Model can be expanded by the GCC back end only if Id = Attribute_Machine or else Id = Attribute_Model then return Is_GCC_Target;