diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-01-13 12:13:00 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-01-13 12:13:00 +0100 |
commit | 82e5c2434e6709118bdf4499cdcbd5dc2c535368 (patch) | |
tree | 2030dec0cbddd3c69d278b9de8fe974ade1856d2 | |
parent | f8981f1984a0e66f165440ecbc72fd3a58075193 (diff) | |
download | gcc-82e5c2434e6709118bdf4499cdcbd5dc2c535368.zip gcc-82e5c2434e6709118bdf4499cdcbd5dc2c535368.tar.gz gcc-82e5c2434e6709118bdf4499cdcbd5dc2c535368.tar.bz2 |
[multiple changes]
2017-01-13 Gary Dismukes <dismukes@adacore.com>
* checks.adb: Minor typo fix and reformatting.
2017-01-13 Javier Miranda <miranda@adacore.com>
* contracts.adb (Contract_Only_Subprograms): Remove formal.
(Copy_Original_Specification): Removed.
(Skip_Contract_Only_Subprogram): Move here checks previously
located in the caller of this routine (to leave the code more clean).
(Build_Contract_Only_Subprogram): Code cleanup.
* scil_ll.ads, scil_ll.adb (Get_Contract_Only_Body_Name): Removed.
(Get_Contract_Only_Missing_Body_Name): Removed.
From-SVN: r244424
-rw-r--r-- | gcc/ada/ChangeLog | 14 | ||||
-rw-r--r-- | gcc/ada/checks.adb | 23 | ||||
-rw-r--r-- | gcc/ada/contracts.adb | 1055 | ||||
-rw-r--r-- | gcc/ada/scil_ll.adb | 28 | ||||
-rw-r--r-- | gcc/ada/scil_ll.ads | 7 |
5 files changed, 515 insertions, 612 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0702a6d..5aa3877 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2017-01-13 Gary Dismukes <dismukes@adacore.com> + + * checks.adb: Minor typo fix and reformatting. + +2017-01-13 Javier Miranda <miranda@adacore.com> + + * contracts.adb (Contract_Only_Subprograms): Remove formal. + (Copy_Original_Specification): Removed. + (Skip_Contract_Only_Subprogram): Move here checks previously + located in the caller of this routine (to leave the code more clean). + (Build_Contract_Only_Subprogram): Code cleanup. + * scil_ll.ads, scil_ll.adb (Get_Contract_Only_Body_Name): Removed. + (Get_Contract_Only_Missing_Body_Name): Removed. + 2017-01-13 Javier Miranda <miranda@adacore.com> * sem_ch6.adb (Cloned_Expression): New subprogram. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index f67c44f..80b4b4b 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -3390,10 +3390,10 @@ package body Checks is In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK) and then not Float_To_Int then - -- A small optimization : the attribute 'Pos applied to an + -- A small optimization: the attribute 'Pos applied to an -- enumeration type has a known range, even though its type - -- is Universal_Integer. so in numeric conversions it is - -- usually within range of of the target integer type. Use the + -- is Universal_Integer. So in numeric conversions it is + -- usually within range of the target integer type. Use the -- static bounds of the base types to check. if Nkind (Expr) = N_Attribute_Reference @@ -3402,15 +3402,15 @@ package body Checks is and then Is_Integer_Type (Target_Type) then declare - Enum_T : constant Entity_Id := - Root_Type (Etype (Prefix (Expr))); - Int_T : constant Entity_Id := Base_Type (Target_Type); - Last_I : constant Uint := - Intval (High_Bound (Scalar_Range (Int_T))); - Last_E : Uint; + Enum_T : constant Entity_Id := + Root_Type (Etype (Prefix (Expr))); + Int_T : constant Entity_Id := Base_Type (Target_Type); + Last_I : constant Uint := + Intval (High_Bound (Scalar_Range (Int_T))); + Last_E : Uint; begin - -- Character types have no explicit literals, we use + -- Character types have no explicit literals, so we use -- the known number of characters in the type. if Root_Type (Enum_T) = Standard_Character then @@ -3422,7 +3422,8 @@ package body Checks is Last_E := UI_From_Int (65535); else - Last_E := Enumeration_Pos + Last_E := + Enumeration_Pos (Entity (High_Bound (Scalar_Range (Enum_T)))); end if; diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 862e85b..eb73d03 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -53,11 +53,6 @@ with Tbuild; use Tbuild; package body Contracts is - procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id); - -- (CodePeer): Subsidiary procedure to Analyze_Contracts which builds the - -- contract-only subprogram body of eligible subprograms found in L, adds - -- them to their corresponding list of declarations, and analyzes them. - procedure Analyze_Contracts (L : List_Id; Freeze_Nod : Node_Id; @@ -68,6 +63,11 @@ package body Contracts is -- is reached. Freeze_Id is the entity of some related context which caused -- freezing up to node Freeze_Nod. + procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id); + -- (CodePeer): Subsidiary procedure to Analyze_Contracts which builds the + -- contract-only subprogram body of eligible subprograms found in L, adds + -- them to their corresponding list of declarations, and analyzes them. + procedure Expand_Subprogram_Contract (Body_Id : Entity_Id); -- Expand the contracts of a subprogram body and its correspoding spec (if -- any). This routine processes all [refined] pre- and postconditions as @@ -1253,6 +1253,490 @@ package body Contracts is Restore_SPARK_Mode (Mode); end Analyze_Task_Contract; + ------------------------------------------------- + -- Build_And_Analyze_Contract_Only_Subprograms -- + ------------------------------------------------- + + procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id) is + procedure Analyze_Contract_Only_Subprograms; + -- Analyze the contract-only subprograms of L + + procedure Append_Contract_Only_Subprograms (Subp_List : List_Id); + -- Append the contract-only bodies of Subp_List to its declarations list + + function Build_Contract_Only_Subprogram (E : Entity_Id) return Node_Id; + -- If E is an entity for a non-imported subprogram specification with + -- pre/postconditions and we are compiling with CodePeer mode, then + -- this procedure will create a wrapper to help Gnat2scil process its + -- contracts. Return Empty if the wrapper cannot be built. + + function Build_Contract_Only_Subprograms (L : List_Id) return List_Id; + -- Build the contract-only subprograms of all eligible subprograms found + -- in list L. + + function Has_Private_Declarations (N : Node_Id) return Boolean; + -- Return True for package specs, task definitions, and protected type + -- definitions whose list of private declarations is not empty. + + --------------------------------------- + -- Analyze_Contract_Only_Subprograms -- + --------------------------------------- + + procedure Analyze_Contract_Only_Subprograms is + procedure Analyze_Contract_Only_Bodies; + -- Analyze all the contract-only bodies of L + + ---------------------------------- + -- Analyze_Contract_Only_Bodies -- + ---------------------------------- + + procedure Analyze_Contract_Only_Bodies is + Decl : Node_Id; + + begin + Decl := First (L); + while Present (Decl) loop + if Nkind (Decl) = N_Subprogram_Body + and then Is_Contract_Only_Body + (Defining_Unit_Name (Specification (Decl))) + then + Analyze (Decl); + end if; + + Next (Decl); + end loop; + end Analyze_Contract_Only_Bodies; + + -- Start of processing for Analyze_Contract_Only_Subprograms + + begin + if Ekind (Current_Scope) /= E_Package then + Analyze_Contract_Only_Bodies; + + else + declare + Pkg_Spec : constant Node_Id := + Package_Specification (Current_Scope); + + begin + if not Has_Private_Declarations (Pkg_Spec) then + Analyze_Contract_Only_Bodies; + + -- For packages with private declarations, the contract-only + -- bodies of subprograms defined in the visible part of the + -- package are added to its private declarations (to ensure + -- that they do not cause premature freezing of types and also + -- that they are analyzed with proper visibility). Hence they + -- will be analyzed later. + + elsif Visible_Declarations (Pkg_Spec) = L then + null; + + elsif Private_Declarations (Pkg_Spec) = L then + Analyze_Contract_Only_Bodies; + end if; + end; + end if; + end Analyze_Contract_Only_Subprograms; + + -------------------------------------- + -- Append_Contract_Only_Subprograms -- + -------------------------------------- + + procedure Append_Contract_Only_Subprograms (Subp_List : List_Id) is + begin + if No (Subp_List) then + return; + end if; + + if Ekind (Current_Scope) /= E_Package then + Append_List (Subp_List, To => L); + + else + declare + Pkg_Spec : constant Node_Id := + Package_Specification (Current_Scope); + + begin + if not Has_Private_Declarations (Pkg_Spec) then + Append_List (Subp_List, To => L); + + -- If the package has private declarations then append them to + -- its private declarations; they will be analyzed when the + -- contracts of its private declarations are analyzed. + + else + Append_List + (List => Subp_List, + To => Private_Declarations (Pkg_Spec)); + end if; + end; + end if; + end Append_Contract_Only_Subprograms; + + ------------------------------------ + -- Build_Contract_Only_Subprogram -- + ------------------------------------ + + -- This procedure takes care of building a wrapper to generate better + -- analysis results in the case of a call to a subprogram whose body + -- is unavailable to CodePeer but whose specification includes Pre/Post + -- conditions. The body might be unavailable for any of a number or + -- reasons (it is imported, the .adb file is simply missing, or the + -- subprogram might be subject to an Annotate (CodePeer, Skip_Analysis) + -- pragma). The built subprogram has the following contents: + -- * check preconditions + -- * call the subprogram + -- * check postconditions + + function Build_Contract_Only_Subprogram (E : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (E); + + Missing_Body_Name : constant Name_Id := + New_External_Name (Chars (E), "__missing_body"); + + function Build_Missing_Body_Decls return List_Id; + -- Build the declaration of the missing body subprogram and its + -- corresponding pragma Import. + + function Build_Missing_Body_Subprogram_Call return Node_Id; + -- Build the call to the missing body subprogram + + function Skip_Contract_Only_Subprogram (E : Entity_Id) return Boolean; + -- Return True for cases where the wrapper is not needed or we cannot + -- build it. + + ------------------------------ + -- Build_Missing_Body_Decls -- + ------------------------------ + + function Build_Missing_Body_Decls return List_Id is + Spec : constant Node_Id := Declaration_Node (E); + Decl : Node_Id; + Prag : Node_Id; + + begin + Decl := + Make_Subprogram_Declaration (Loc, Copy_Subprogram_Spec (Spec)); + Set_Chars (Defining_Entity (Decl), Missing_Body_Name); + + Prag := + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Ada)), + + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Missing_Body_Name)))); + + return New_List (Decl, Prag); + end Build_Missing_Body_Decls; + + ---------------------------------------- + -- Build_Missing_Body_Subprogram_Call -- + ---------------------------------------- + + function Build_Missing_Body_Subprogram_Call return Node_Id is + Forml : Entity_Id; + Parms : List_Id; + + begin + Parms := New_List; + + -- Build parameter list that we need + + Forml := First_Formal (E); + while Present (Forml) loop + Append_To (Parms, Make_Identifier (Loc, Chars (Forml))); + Next_Formal (Forml); + end loop; + + -- Build the call to the missing body subprogram + + if Ekind_In (E, E_Function, E_Generic_Function) then + return + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, Missing_Body_Name), + Parameter_Associations => Parms)); + + else + return + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Missing_Body_Name), + Parameter_Associations => Parms); + end if; + end Build_Missing_Body_Subprogram_Call; + + ----------------------------------- + -- Skip_Contract_Only_Subprogram -- + ----------------------------------- + + function Skip_Contract_Only_Subprogram + (E : Entity_Id) return Boolean + is + function Depends_On_Enclosing_Private_Type return Boolean; + -- Return True if some formal of E (or its return type) are + -- private types defined in an enclosing package. + + function Some_Enclosing_Package_Has_Private_Decls return Boolean; + -- Return True if some enclosing package of the current scope has + -- private declarations. + + --------------------------------------- + -- Depends_On_Enclosing_Private_Type -- + --------------------------------------- + + function Depends_On_Enclosing_Private_Type return Boolean is + function Defined_In_Enclosing_Package + (Typ : Entity_Id) return Boolean; + -- Return True if Typ is an entity defined in an enclosing + -- package of the current scope. + + ---------------------------------- + -- Defined_In_Enclosing_Package -- + ---------------------------------- + + function Defined_In_Enclosing_Package + (Typ : Entity_Id) return Boolean + is + Scop : Entity_Id := Scope (Current_Scope); + + begin + while Scop /= Scope (Typ) + and then not Is_Compilation_Unit (Scop) + loop + Scop := Scope (Scop); + end loop; + + return Scop = Scope (Typ); + end Defined_In_Enclosing_Package; + + -- Local variables + + Param_E : Entity_Id; + Typ : Entity_Id; + + -- Start of processing for Depends_On_Enclosing_Private_Type + + begin + Param_E := First_Entity (E); + while Present (Param_E) loop + Typ := Etype (Param_E); + + if Is_Private_Type (Typ) + and then Defined_In_Enclosing_Package (Typ) + then + return True; + end if; + + Next_Entity (Param_E); + end loop; + + return + Ekind (E) = E_Function + and then Is_Private_Type (Etype (E)) + and then Defined_In_Enclosing_Package (Etype (E)); + end Depends_On_Enclosing_Private_Type; + + ---------------------------------------------- + -- Some_Enclosing_Package_Has_Private_Decls -- + ---------------------------------------------- + + function Some_Enclosing_Package_Has_Private_Decls return Boolean is + Scop : Entity_Id := Current_Scope; + Pkg_Spec : Node_Id := Package_Specification (Scop); + + begin + loop + if Ekind (Scop) = E_Package + and then Has_Private_Declarations + (Package_Specification (Scop)) + then + Pkg_Spec := Package_Specification (Scop); + end if; + + exit when Is_Compilation_Unit (Scop); + Scop := Scope (Scop); + end loop; + + return Pkg_Spec /= Package_Specification (Current_Scope); + end Some_Enclosing_Package_Has_Private_Decls; + + -- Start of processing for Skip_Contract_Only_Subprogram + + begin + if not CodePeer_Mode + or else Inside_A_Generic + or else not Is_Subprogram (E) + or else Is_Abstract_Subprogram (E) + or else Is_Imported (E) + or else No (Contract (E)) + or else No (Pre_Post_Conditions (Contract (E))) + or else Is_Contract_Only_Body (E) + or else Convention (E) = Convention_Protected + then + return True; + + -- We do not support building the contract-only subprogram if E + -- is a subprogram declared in a nested package that has some + -- formal or return type depending on a private type defined in + -- an enclosing package. + + elsif Ekind (Current_Scope) = E_Package + and then Some_Enclosing_Package_Has_Private_Decls + and then Depends_On_Enclosing_Private_Type + then + if Debug_Flag_Dot_KK then + declare + Saved_Mode : constant Warning_Mode_Type := Warning_Mode; + + begin + -- Warnings are disabled by default under CodePeer_Mode + -- (see switch-c). Enable them temporarily. + + Warning_Mode := Normal; + Error_Msg_N + ("cannot generate contract-only subprogram?", E); + Warning_Mode := Saved_Mode; + end; + end if; + + return True; + end if; + + return False; + end Skip_Contract_Only_Subprogram; + + -- Start of processing for Build_Contract_Only_Subprogram + + begin + -- Test cases where the wrapper is not needed and cases where we + -- cannot build it. + + if Skip_Contract_Only_Subprogram (E) then + return Empty; + end if; + + -- Note on calls to Copy_Separate_Tree. The trees we are copying + -- here are fully analyzed, but we definitely want fully syntactic + -- unanalyzed trees in the body we construct, so that the analysis + -- generates the right visibility, and that is exactly what the + -- calls to Copy_Separate_Tree give us. + + declare + Name : constant Name_Id := + New_External_Name (Chars (E), "__contract_only"); + Id : Entity_Id; + Bod : Node_Id; + + begin + Bod := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Declaration_Node (E)), + Declarations => + Build_Missing_Body_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Build_Missing_Body_Subprogram_Call), + End_Label => Make_Identifier (Loc, Name))); + + Id := Defining_Unit_Name (Specification (Bod)); + + -- Copy only the pre/postconditions of the original contract + -- since it is what we need, but also because pragmas stored in + -- the other fields have N_Pragmas with N_Aspect_Specifications + -- that reference their associated pragma (thus causing an endless + -- loop when trying to copy the subtree). + + declare + New_Contract : constant Node_Id := Make_Contract (Sloc (E)); + + begin + Set_Pre_Post_Conditions (New_Contract, + Copy_Separate_Tree (Pre_Post_Conditions (Contract (E)))); + Set_Contract (Id, New_Contract); + end; + + -- Fix the name of this new subprogram and link the original + -- subprogram with its Contract_Only_Body subprogram. + + Set_Chars (Id, Name); + Set_Is_Contract_Only_Body (Id); + Set_Contract_Only_Body (E, Id); + + return Bod; + end; + end Build_Contract_Only_Subprogram; + + ------------------------------------- + -- Build_Contract_Only_Subprograms -- + ------------------------------------- + + function Build_Contract_Only_Subprograms (L : List_Id) return List_Id is + Decl : Node_Id; + New_Subp : Node_Id; + Result : List_Id := No_List; + Subp_Id : Entity_Id; + + begin + Decl := First (L); + while Present (Decl) loop + if Nkind (Decl) = N_Subprogram_Declaration then + Subp_Id := Defining_Unit_Name (Specification (Decl)); + New_Subp := Build_Contract_Only_Subprogram (Subp_Id); + + if Present (New_Subp) then + if No (Result) then + Result := New_List; + end if; + + Append_To (Result, New_Subp); + end if; + end if; + + Next (Decl); + end loop; + + return Result; + end Build_Contract_Only_Subprograms; + + ------------------------------ + -- Has_Private_Declarations -- + ------------------------------ + + function Has_Private_Declarations (N : Node_Id) return Boolean is + begin + if not Nkind_In (N, N_Package_Specification, + N_Protected_Definition, + N_Task_Definition) + then + return False; + else + return + Present (Private_Declarations (N)) + and then Is_Non_Empty_List (Private_Declarations (N)); + end if; + end Has_Private_Declarations; + + -- Local variables + + Subp_List : List_Id; + + -- Start of processing for Build_And_Analyze_Contract_Only_Subprograms + + begin + Subp_List := Build_Contract_Only_Subprograms (L); + Append_Contract_Only_Subprograms (Subp_List); + Analyze_Contract_Only_Subprograms; + end Build_And_Analyze_Contract_Only_Subprograms; + ----------------------------- -- Create_Generic_Contract -- ----------------------------- @@ -2679,565 +3163,4 @@ package body Contracts is Pop_Scope; end Save_Global_References_In_Contract; - ------------------------------------------------- - -- Build_And_Analyze_Contract_Only_Subprograms -- - ------------------------------------------------- - - procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id) is - procedure Analyze_Contract_Only_Subprograms (L : List_Id); - -- Analyze the contract-only subprograms of L - - procedure Append_Contract_Only_Subprograms (Subp_List : List_Id); - -- Append the contract-only bodies of Subp_List to its declarations list - - function Build_Contract_Only_Subprogram (E : Entity_Id) return Node_Id; - -- If E is an entity for a non-imported subprogram specification with - -- pre/postconditions and we are compiling with CodePeer mode, then this - -- procedure will create a wrapper to help Gnat2scil process its - -- contracts. Return Empty if the wrapper cannot be built. - - function Build_Contract_Only_Subprograms (L : List_Id) return List_Id; - -- Build the contract-only subprograms of all eligible subprograms found - -- in list L. - - function Has_Private_Declarations (N : Node_Id) return Boolean; - -- Return True for package specs, task definitions, and protected type - -- definitions whose list of private declarations is not empty. - - --------------------------------------- - -- Analyze_Contract_Only_Subprograms -- - --------------------------------------- - - procedure Analyze_Contract_Only_Subprograms (L : List_Id) is - procedure Analyze_Contract_Only_Bodies; - -- Analyze all the contract-only bodies of L - - ---------------------------------- - -- Analyze_Contract_Only_Bodies -- - ---------------------------------- - - procedure Analyze_Contract_Only_Bodies is - Decl : Node_Id; - - begin - Decl := First (L); - while Present (Decl) loop - if Nkind (Decl) = N_Subprogram_Body - and then Is_Contract_Only_Body - (Defining_Unit_Name (Specification (Decl))) - then - Analyze (Decl); - end if; - - Next (Decl); - end loop; - end Analyze_Contract_Only_Bodies; - - -- Start of processing for Analyze_Contract_Only_Subprograms - - begin - if Ekind (Current_Scope) /= E_Package then - Analyze_Contract_Only_Bodies; - - else - declare - Pkg_Spec : constant Node_Id := - Package_Specification (Current_Scope); - - begin - if not Has_Private_Declarations (Pkg_Spec) then - Analyze_Contract_Only_Bodies; - - -- For packages with private declarations, the contract-only - -- bodies of subprograms defined in the visible part of the - -- package are added to its private declarations (to ensure - -- that they do not cause premature freezing of types and also - -- that they are analyzed with proper visibility). Hence they - -- will be analyzed later. - - elsif Visible_Declarations (Pkg_Spec) = L then - null; - - elsif Private_Declarations (Pkg_Spec) = L then - Analyze_Contract_Only_Bodies; - end if; - end; - end if; - end Analyze_Contract_Only_Subprograms; - - -------------------------------------- - -- Append_Contract_Only_Subprograms -- - -------------------------------------- - - procedure Append_Contract_Only_Subprograms (Subp_List : List_Id) is - begin - if No (Subp_List) then - return; - end if; - - if Ekind (Current_Scope) /= E_Package then - Append_List (Subp_List, To => L); - - else - declare - Pkg_Spec : constant Node_Id := - Package_Specification (Current_Scope); - - begin - if not Has_Private_Declarations (Pkg_Spec) then - Append_List (Subp_List, To => L); - - -- If the package has private declarations then append them to - -- its private declarations; they will be analyzed when the - -- contracts of its private declarations are analyzed. - - else - Append_List - (List => Subp_List, - To => Private_Declarations (Pkg_Spec)); - end if; - end; - end if; - end Append_Contract_Only_Subprograms; - - ------------------------------------ - -- Build_Contract_Only_Subprogram -- - ------------------------------------ - - -- This procedure takes care of building a wrapper to generate better - -- analysis results in the case of a call to a subprogram whose body - -- is unavailable to CodePeer but whose specification includes Pre/Post - -- conditions. The body might be unavailable for any of a number or - -- reasons (it is imported, the .adb file is simply missing, or the - -- subprogram might be subject to an Annotate (CodePeer, Skip_Analysis) - -- pragma). The built subprogram has the following contents: - -- * check preconditions - -- * call the subprogram - -- * check postconditions - - function Build_Contract_Only_Subprogram (E : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (E); - - function Build_Missing_Body_Decls return List_Id; - -- Build the declaration of the missing body subprogram and its - -- corresponding pragma Import. - - function Build_Missing_Body_Subprogram_Call return Node_Id; - -- Build the call to the missing body subprogram - - function Copy_Original_Specification - (Loc : Source_Ptr; - Spec : Node_Id) return Node_Id; - -- Build a copy of the original specification of the given subprogram - -- specification. - - function Skip_Contract_Only_Subprogram (E : Entity_Id) return Boolean; - -- Return True if E is a subprogram declared in a nested package that - -- has some formal or return type depending on a private type defined - -- in an enclosing package. - - ------------------------------ - -- Build_Missing_Body_Decls -- - ------------------------------ - - function Build_Missing_Body_Decls return List_Id is - Name : constant Name_Id := Get_Contract_Only_Missing_Body_Name (E); - Spec : constant Node_Id := Declaration_Node (E); - Decl : Node_Id; - Prag : Node_Id; - - begin - Decl := Make_Subprogram_Declaration (Loc, - Copy_Original_Specification (Loc, Spec)); - Set_Chars (Defining_Unit_Name (Specification (Decl)), Name); - - Prag := - Make_Pragma (Loc, - Chars => Name_Import, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Ada)), - - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name)))); - - return New_List (Decl, Prag); - end Build_Missing_Body_Decls; - - ---------------------------------------- - -- Build_Missing_Body_Subprogram_Call -- - ---------------------------------------- - - function Build_Missing_Body_Subprogram_Call return Node_Id is - Forml : Entity_Id; - Parms : List_Id; - - begin - -- Build parameter list that we need - - Parms := New_List; - Forml := First_Formal (E); - while Present (Forml) loop - Append_To (Parms, Make_Identifier (Loc, Chars (Forml))); - Next_Formal (Forml); - end loop; - - -- Build the call to the missing body subprogram - - if Ekind_In (E, E_Function, E_Generic_Function) then - return - Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => Make_Identifier (Loc, - Get_Contract_Only_Missing_Body_Name (E)), - Parameter_Associations => Parms)); - - else - return - Make_Procedure_Call_Statement (Loc, - Name => Make_Identifier (Loc, - Get_Contract_Only_Missing_Body_Name (E)), - Parameter_Associations => Parms); - end if; - end Build_Missing_Body_Subprogram_Call; - - --------------------------------- - -- Copy_Original_Specification -- - --------------------------------- - - function Copy_Original_Specification - (Loc : Source_Ptr; - Spec : Node_Id) return Node_Id - is - function Copy_Original_Type (N : Node_Id) return Node_Id; - -- Duplicate the original type of a given formal or function - -- result type. - - function Copy_Original_Type (N : Node_Id) return Node_Id is - begin - -- For expanded names located in instantiations, copy them with - -- semantic information (avoids visibility problems). - - if In_Instance - and then Nkind (N) = N_Expanded_Name - then - return New_Copy_Tree (N); - else - return Copy_Separate_Tree (Original_Node (N)); - end if; - end Copy_Original_Type; - - -- Local variables - - Current_Parameter : Node_Id; - Current_Identifier : Entity_Id; - Current_Type : Node_Id; - New_Identifier : Entity_Id; - Parameters : List_Id := No_List; - - -- Start of processing for Copy_Original_Specification - - begin - if Present (Parameter_Specifications (Spec)) then - Parameters := New_List; - Current_Parameter := First (Parameter_Specifications (Spec)); - while Present (Current_Parameter) loop - Current_Identifier := - Defining_Identifier (Current_Parameter); - Current_Type := - Copy_Original_Type (Parameter_Type (Current_Parameter)); - - New_Identifier := Make_Defining_Identifier (Loc, - Chars (Current_Identifier)); - - Append_To (Parameters, - Make_Parameter_Specification (Loc, - Defining_Identifier => New_Identifier, - Parameter_Type => Current_Type, - In_Present => In_Present (Current_Parameter), - Out_Present => Out_Present (Current_Parameter), - Expression => - Copy_Separate_Tree (Expression (Current_Parameter)))); - - Next (Current_Parameter); - end loop; - end if; - - case Nkind (Spec) is - when N_Function_Specification => - return - Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Unit_Name (Spec))), - Parameter_Specifications => Parameters, - Result_Definition => - Copy_Original_Type (Result_Definition (Spec))); - - when N_Procedure_Specification => - return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Unit_Name (Spec))), - Parameter_Specifications => Parameters); - - when others => - raise Program_Error; - end case; - end Copy_Original_Specification; - - ----------------------------------- - -- Skip_Contract_Only_Subprogram -- - ----------------------------------- - - function Skip_Contract_Only_Subprogram (E : Entity_Id) return Boolean - is - function Depends_On_Enclosing_Private_Type return Boolean; - -- Return True if some formal of E (or its return type) are - -- private types defined in an enclosing package. - - function Some_Enclosing_Package_Has_Private_Decls return Boolean; - -- Return True if some enclosing package of the current scope has - -- private declarations. - - --------------------------------------- - -- Depends_On_Enclosing_Private_Type -- - --------------------------------------- - - function Depends_On_Enclosing_Private_Type return Boolean is - - function Defined_In_Enclosing_Package - (Typ : Entity_Id) return Boolean; - -- Return True if Typ is an entity defined in an enclosing - -- package of the current scope. - - ---------------------------------- - -- Defined_In_Enclosing_Package -- - ---------------------------------- - - function Defined_In_Enclosing_Package - (Typ : Entity_Id) return Boolean - is - Scop : Entity_Id := Scope (Current_Scope); - - begin - while Scop /= Scope (Typ) - and then not Is_Compilation_Unit (Scop) - loop - Scop := Scope (Scop); - end loop; - - return Scop = Scope (Typ); - end Defined_In_Enclosing_Package; - - -- Local variables - - Param_E : Entity_Id; - Typ : Entity_Id; - begin - Param_E := First_Entity (E); - while Present (Param_E) loop - Typ := Etype (Param_E); - - if Is_Private_Type (Typ) - and then Defined_In_Enclosing_Package (Typ) - then - return True; - end if; - - Next_Entity (Param_E); - end loop; - - return Ekind (E) = E_Function - and then Is_Private_Type (Etype (E)) - and then Defined_In_Enclosing_Package (Etype (E)); - end Depends_On_Enclosing_Private_Type; - - ---------------------------------------------- - -- Some_Enclosing_Package_Has_Private_Decls -- - ---------------------------------------------- - - function Some_Enclosing_Package_Has_Private_Decls return Boolean is - Scop : Entity_Id := Current_Scope; - Pkg_Spec : Node_Id := Package_Specification (Scop); - - begin - loop - if Ekind (Scop) = E_Package - and then - Has_Private_Declarations (Package_Specification (Scop)) - then - Pkg_Spec := Package_Specification (Scop); - end if; - - exit when Is_Compilation_Unit (Scop); - Scop := Scope (Scop); - end loop; - - return Pkg_Spec /= Package_Specification (Current_Scope); - end Some_Enclosing_Package_Has_Private_Decls; - - -- Start of processing for Skip_Contract_Only_Subprogram - - begin - if Ekind (Current_Scope) = E_Package - and then Some_Enclosing_Package_Has_Private_Decls - and then Depends_On_Enclosing_Private_Type - then - if Debug_Flag_Dot_KK then - declare - Saved_Mode : constant Warning_Mode_Type := Warning_Mode; - - begin - -- Warnings are disabled by default under CodePeer_Mode - -- (see switch-c). Enable them temporarily. - - Warning_Mode := Normal; - Error_Msg_N - ("cannot generate contract-only subprogram?", E); - Warning_Mode := Saved_Mode; - end; - end if; - - return True; - end if; - - return False; - end Skip_Contract_Only_Subprogram; - - -- Start of processing for Build_Contract_Only_Subprogram - - begin - -- Test cases where the wrapper is not needed and cases where we - -- cannot build the wrapper. - - if not CodePeer_Mode - or else Inside_A_Generic - or else not Is_Subprogram (E) - or else Is_Abstract_Subprogram (E) - or else Is_Imported (E) - or else No (Contract (E)) - or else No (Pre_Post_Conditions (Contract (E))) - or else Is_Contract_Only_Body (E) - or else Skip_Contract_Only_Subprogram (E) - or else Convention (E) = Convention_Protected - then - return Empty; - end if; - - -- Note on calls to Copy_Separate_Tree. The trees we are copying - -- here are fully analyzed, but we definitely want fully syntactic - -- unanalyzed trees in the body we construct, so that the analysis - -- generates the right visibility, and that is exactly what the - -- calls to Copy_Separate_Tree give us. - - declare - Name : constant Name_Id := Get_Contract_Only_Body_Name (E); - Id : Entity_Id; - Bod : Node_Id; - - begin - Bod := - Make_Subprogram_Body (Loc, - Specification => - Copy_Original_Specification (Loc, Declaration_Node (E)), - Declarations => - Build_Missing_Body_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Build_Missing_Body_Subprogram_Call), - End_Label => Make_Identifier (Loc, Name))); - - Id := Defining_Unit_Name (Specification (Bod)); - - -- Copy only the pre/postconditions of the original contract - -- since it is what we need, but also because pragmas stored in - -- the other fields have N_Pragmas with N_Aspect_Specifications - -- that reference their associated pragma (thus causing an endless - -- loop when trying to copy the subtree). - - declare - New_Contract : constant Node_Id := Make_Contract (Sloc (E)); - - begin - Set_Pre_Post_Conditions (New_Contract, - Copy_Separate_Tree (Pre_Post_Conditions (Contract (E)))); - Set_Contract (Id, New_Contract); - end; - - -- Fix the name of this new subprogram and link the original - -- subprogram with its Contract_Only_Body subprogram. - - Set_Chars (Id, Name); - Set_Is_Contract_Only_Body (Id); - Set_Contract_Only_Body (E, Id); - - return Bod; - end; - end Build_Contract_Only_Subprogram; - - ------------------------------------- - -- Build_Contract_Only_Subprograms -- - ------------------------------------- - - function Build_Contract_Only_Subprograms (L : List_Id) return List_Id is - Decl : Node_Id; - Subp_Id : Entity_Id; - New_Subp : Node_Id; - Result : List_Id := No_List; - - begin - Decl := First (L); - while Present (Decl) loop - if Nkind (Decl) = N_Subprogram_Declaration then - Subp_Id := Defining_Unit_Name (Specification (Decl)); - New_Subp := Build_Contract_Only_Subprogram (Subp_Id); - - if Present (New_Subp) then - if No (Result) then - Result := New_List; - end if; - - Append_To (Result, New_Subp); - end if; - end if; - - Next (Decl); - end loop; - - return Result; - end Build_Contract_Only_Subprograms; - - ------------------------------ - -- Has_Private_Declarations -- - ------------------------------ - - function Has_Private_Declarations (N : Node_Id) return Boolean is - begin - if not Nkind_In (N, N_Package_Specification, - N_Task_Definition, - N_Protected_Definition) - then - return False; - else - return Present (Private_Declarations (N)) - and then Is_Non_Empty_List (Private_Declarations (N)); - end if; - end Has_Private_Declarations; - - -- Local variables - - Subp_List : List_Id; - - -- Start of processing for Build_And_Analyze_Contract_Only_Subprograms - - begin - Subp_List := Build_Contract_Only_Subprograms (L); - Append_Contract_Only_Subprograms (Subp_List); - Analyze_Contract_Only_Subprograms (L); - end Build_And_Analyze_Contract_Only_Subprograms; - end Contracts; diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb index eed0d1a..bf9ded7 100644 --- a/gcc/ada/scil_ll.adb +++ b/gcc/ada/scil_ll.adb @@ -35,13 +35,6 @@ with Sinfo; use Sinfo; with System.HTable; use System.HTable; package body SCIL_LL is - Contract_Only_Body_Suffix : constant String := "__contract_only"; - -- Suffix of Contract_Only_Body subprograms internally built only under - -- CodePeer mode - - Contract_Only_Missing_Body_Suffix : constant String := "__missing_body"; - -- Suffix of Contract_Only_Missing_Body subprograms internally built only - -- under CodePeer mode procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id); -- Copy the SCIL field from Source to Target (it is used as the argument @@ -108,27 +101,6 @@ package body SCIL_LL is end if; end Get_Contract_Only_Body; - --------------------------------- - -- Get_Contract_Only_Body_Name -- - --------------------------------- - - function Get_Contract_Only_Body_Name (E : Entity_Id) return Name_Id is - begin - return Name_Find (Get_Name_String (Chars (E)) & - Contract_Only_Body_Suffix); - end Get_Contract_Only_Body_Name; - - ----------------------------------------- - -- Get_Contract_Only_Missing_Body_Name -- - ----------------------------------------- - - function Get_Contract_Only_Missing_Body_Name (E : Entity_Id) - return Name_Id is - begin - return Name_Find (Get_Name_String (Chars (E)) & - Contract_Only_Missing_Body_Suffix); - end Get_Contract_Only_Missing_Body_Name; - ------------------- -- Get_SCIL_Node -- ------------------- diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads index bfac1a0..bebe0e7 100644 --- a/gcc/ada/scil_ll.ads +++ b/gcc/ada/scil_ll.ads @@ -32,17 +32,10 @@ -- This package extends the tree nodes with fields that are used to reference -- the SCIL node and the Contract_Only_Body of a subprogram with aspects. -with Namet; use Namet; with Types; use Types; package SCIL_LL is - function Get_Contract_Only_Body_Name (E : Entity_Id) return Name_Id; - -- Return the name of the Contract_Only_Body subprogram of E - - function Get_Contract_Only_Missing_Body_Name (E : Entity_Id) return Name_Id; - -- Return the name of the Contract_Only_Missing_Body subprogram of E - function Get_Contract_Only_Body (N : Node_Id) return Node_Id; -- Read the value of attribute Contract_Only_Body |