From b8e6830b3446b34cb3aee27d94bca490546c7d07 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 29 Jul 2014 17:14:04 +0200 Subject: [PATCH] [multiple changes] 2014-07-29 Robert Dewar * sem_util.adb, sem_util.ads, sem_res.adb, exp_ch6.adb: Invert predicate No_Predicate_Test_On_Arguments, new name is Predicate_Tests_On_Arguments (with the opposite sense). 2014-07-29 Hristian Kirtchev * sem_attr.adb (Resolve_Attribute): Clean up the code for attribute 'Access. Do not generate an elaboration flag for a stand alone expression function. The expression of an expression function is now frozen when the expression function appears as the prefix of attribute 'Access. * sem_ch6.adb (Analyze_Expression_Function): Remove local variable New_Decl and update all references to it after the rewriting has taken place. Establish the linkages between the generated spec and body. From-SVN: r213212 --- gcc/ada/ChangeLog | 18 +++++++++ gcc/ada/exp_ch6.adb | 2 +- gcc/ada/sem_attr.adb | 90 +++++++++++++++++++++++++++++++------------- gcc/ada/sem_ch6.adb | 18 +++++---- gcc/ada/sem_res.adb | 6 +-- gcc/ada/sem_util.adb | 76 ++++++++++++++++++------------------- gcc/ada/sem_util.ads | 11 +++--- 7 files changed, 140 insertions(+), 81 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6a550999775..ed9c60866e6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2014-07-29 Robert Dewar + + * sem_util.adb, sem_util.ads, sem_res.adb, exp_ch6.adb: Invert + predicate No_Predicate_Test_On_Arguments, new name is + Predicate_Tests_On_Arguments (with the opposite sense). + +2014-07-29 Hristian Kirtchev + + * sem_attr.adb (Resolve_Attribute): Clean up the code for + attribute 'Access. Do not generate an elaboration flag for a + stand alone expression function. The expression of an expression + function is now frozen when the expression function appears as + the prefix of attribute 'Access. + * sem_ch6.adb (Analyze_Expression_Function): Remove local + variable New_Decl and update all references to it after the + rewriting has taken place. Establish the linkages between the + generated spec and body. + 2014-07-29 Robert Dewar * sem_prag.adb (ip, rv): Prevent from being optimized away. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 610aa170205..0688a3cc633 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1754,7 +1754,7 @@ package body Exp_Ch6 is -- Skip predicate checks for special cases - and then not No_Predicate_Test_On_Arguments (Subp) + and then Predicate_Tests_On_Arguments (Subp) then Append_To (Post_Call, Make_Predicate_Check (Atyp, Actual)); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bc75fed35a8..20395b40e45 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -86,7 +86,9 @@ package body Sem_Attr is -- used so that we can abandon the processing so we don't run into -- trouble with cascaded errors. - -- The following array is the list of attributes defined in the Ada 83 RM: + -- The following array is the list of attributes defined in the Ada 83 RM. + -- In Ada 83 mode, these are the only recognized attributes. In other Ada + -- modes all these attributes are recognized, even if removed in Ada 95. Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( Attribute_Address | @@ -10565,11 +10567,18 @@ package body Sem_Attr is Set_Address_Taken (Entity (P)); end if; - if Is_Entity_Name (P) then + -- Deal with possible elaboration check + + if Is_Entity_Name (P) and then Is_Subprogram (Entity (P)) then declare - E : constant Entity_Id := Entity (P); - Decl : Node_Id; - Flag : Entity_Id; + Subp_Id : constant Entity_Id := Entity (P); + Scop : constant Entity_Id := Scope (Subp_Id); + Subp_Decl : constant Node_Id := + Unit_Declaration_Node (Subp_Id); + + Flag_Id : Entity_Id; + HSS : Node_Id; + Stmt : Node_Id; -- If the access has been taken and the body of the subprogram -- has not been see yet, indirect calls must be protected with @@ -10578,40 +10587,67 @@ package body Sem_Attr is -- a subprogram the body will appear in the same declarative -- part, and we must insert a check in the eventual body itself -- using the elaboration flag that we generate now. The check - -- is then inserted when the body is expanded. + -- is then inserted when the body is expanded. This processing + -- is not needed for a stand alone expression function because + -- the internally generated spec and body are always inserted + -- as a pair in the same declarative list. begin - if Is_Subprogram (E) - and then Expander_Active - and then Comes_From_Source (E) + if Expander_Active + and then Comes_From_Source (Subp_Id) and then Comes_From_Source (N) - and then In_Open_Scopes (Scope (E)) - and then - Ekind_In (Scope (E), E_Block, E_Procedure, E_Function) - and then not Has_Completion (E) - and then No (Elaboration_Entity (E)) - and then Nkind (Unit_Declaration_Node (E)) = - N_Subprogram_Declaration + and then In_Open_Scopes (Scop) + and then Ekind_In (Scop, E_Block, E_Procedure, E_Function) + and then not Has_Completion (Subp_Id) + and then No (Elaboration_Entity (Subp_Id)) + and then Nkind (Subp_Decl) = N_Subprogram_Declaration + and then Nkind (Original_Node (Subp_Decl)) /= + N_Expression_Function then -- Create elaboration variable for it - Flag := Make_Temporary (Loc, 'E'); - Decl := + Flag_Id := Make_Temporary (Loc, 'E'); + Set_Elaboration_Entity (Subp_Id, Flag_Id); + Set_Is_Frozen (Flag_Id); + + -- Insert declaration for flag after subprogram + -- declaration. Note that attribute reference may + -- appear within a nested scope. + + Insert_After_And_Analyze (Subp_Decl, Make_Object_Declaration (Loc, - Defining_Identifier => Flag, + Defining_Identifier => Flag_Id, Object_Definition => New_Occurrence_Of (Standard_Short_Integer, Loc), Expression => - Make_Integer_Literal (Loc, Uint_0)); - Set_Elaboration_Entity (E, Flag); - Set_Is_Frozen (Flag); + Make_Integer_Literal (Loc, Uint_0))); + end if; - -- Insert declaration for flag after subprogram - -- declaration. Note that attribute reference may - -- appear within a nested scope. + -- Taking the 'Access of an expression function freezes its + -- expression (RM 13.14 10.3/3). This does not apply to an + -- expression function that acts as a completion because the + -- generated body is immediately analyzed and the expression + -- is automatically frozen. + + if Ekind (Subp_Id) = E_Function + and then Nkind (Subp_Decl) = N_Subprogram_Declaration + and then Nkind (Original_Node (Subp_Decl)) = + N_Expression_Function + and then Present (Corresponding_Body (Subp_Decl)) + and then not Analyzed (Corresponding_Body (Subp_Decl)) + then + HSS := + Handled_Statement_Sequence + (Unit_Declaration_Node + (Corresponding_Body (Subp_Decl))); + + if Present (HSS) then + Stmt := First (Statements (HSS)); - Insert_After (Unit_Declaration_Node (E), Decl); - Analyze (Decl); + if Nkind (Stmt) = N_Simple_Return_Statement then + Freeze_Expression (Expression (Stmt)); + end if; + end if; end if; end; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 727a3beb7d7..5a99a2c70d1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -266,7 +266,6 @@ package body Sem_Ch6 is -- declaration is completed. Def_Id is needed to analyze the spec. New_Body : Node_Id; - New_Decl : Node_Id; New_Spec : Node_Id; Ret : Node_Id; @@ -434,10 +433,7 @@ package body Sem_Ch6 is ("an expression function is not a legal protected operation", N); end if; - New_Decl := - Make_Subprogram_Declaration (Loc, Specification => Spec); - - Rewrite (N, New_Decl); + Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec)); -- Correct the parent pointer of the aspect specification list to -- reference the rewritten node. @@ -447,7 +443,15 @@ package body Sem_Ch6 is end if; Analyze (N); - Set_Is_Inlined (Defining_Entity (New_Decl)); + Set_Is_Inlined (Defining_Entity (N)); + + -- Establish the linkages between the spec and the body. These are + -- used when the expression function acts as the prefix of attribute + -- 'Access in order to freeze the original expression which has been + -- moved to the generated body. + + Set_Corresponding_Body (N, Defining_Entity (New_Body)); + Set_Corresponding_Spec (New_Body, Defining_Entity (N)); -- To prevent premature freeze action, insert the new body at the end -- of the current declarations, or at the end of the package spec. @@ -461,7 +465,7 @@ package body Sem_Ch6 is declare Decls : List_Id := List_Containing (N); Par : constant Node_Id := Parent (Decls); - Id : constant Entity_Id := Defining_Entity (New_Decl); + Id : constant Entity_Id := Defining_Entity (N); begin if Nkind (Par) = N_Package_Specification diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f559ec3b6d3..dab6c8f6748 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1974,7 +1974,7 @@ package body Sem_Res is if Nkind (Decl) = N_Subprogram_Body then Spec := Corresponding_Spec (Decl); - if not No (Spec) then + if Present (Spec) then Decl := Unit_Declaration_Node (Spec); end if; end if; @@ -4051,9 +4051,9 @@ package body Sem_Res is -- Apply predicate tests except in certain special cases. Note -- that it might be more consistent to apply these only when -- expansion is active (in Exp_Ch6.Expand_Actuals), as we do - -- for the outbound predicate tests. + -- for the outbound predicate tests ??? - if not No_Predicate_Test_On_Arguments (Nam) then + if Predicate_Tests_On_Arguments (Nam) then Apply_Predicate_Check (A, F_Typ); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e8131cb4031..4434d5b16d5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13785,44 +13785,6 @@ package body Sem_Util is Actual_Id := Next_Actual (Actual_Id); end Next_Actual; - ------------------------------------ - -- No_Predicate_Test_On_Arguments -- - ------------------------------------ - - function No_Predicate_Test_On_Arguments (Subp : Entity_Id) return Boolean is - begin - -- Do not test predicates on call to generated default Finalize, since - -- we are not interested in whether something we are finalizing (and - -- typically destroying) satisfies its predicates. - - if Chars (Subp) = Name_Finalize - and then not Comes_From_Source (Subp) - then - return True; - - -- Do not test predicates on call to Init_Proc, since if needed the - -- predicate test will occur at some other point. - - elsif Is_Init_Proc (Subp) then - return True; - - -- Do not test predicates on call to predicate function, since this - -- would cause infinite recursion. - - elsif Ekind (Subp) = E_Function - and then (Is_Predicate_Function (Subp) - or else - Is_Predicate_Function_M (Subp)) - then - return True; - - -- For now, no other cases - - else - return False; - end if; - end No_Predicate_Test_On_Arguments; - --------------------- -- No_Scalar_Parts -- --------------------- @@ -14755,6 +14717,44 @@ package body Sem_Util is end if; end Original_Corresponding_Operation; + ---------------------------------- + -- Predicate_Tests_On_Arguments -- + ---------------------------------- + + function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is + begin + -- Do not test predicates on call to generated default Finalize, since + -- we are not interested in whether something we are finalizing (and + -- typically destroying) satisfies its predicates. + + if Chars (Subp) = Name_Finalize + and then not Comes_From_Source (Subp) + then + return False; + + -- Do not test predicates on call to Init_Proc, since if needed the + -- predicate test will occur at some other point. + + elsif Is_Init_Proc (Subp) then + return False; + + -- Do not test predicates on call to predicate function, since this + -- would cause infinite recursion. + + elsif Ekind (Subp) = E_Function + and then (Is_Predicate_Function (Subp) + or else + Is_Predicate_Function_M (Subp)) + then + return False; + + -- For now, no other exceptions + + else + return True; + end if; + end Predicate_Tests_On_Arguments; + ----------------------- -- Private_Component -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 62d995e422d..970b2bafa77 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1582,11 +1582,6 @@ 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_Predicate_Test_On_Arguments (Subp : Entity_Id) return Boolean; - -- Subp is the entity for a subprogram call. This function returns True to - -- eliminate predicate tests on the input or output arguments in a call to - -- this subprogram. See body for exact cases currently covered. - 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 @@ -1634,6 +1629,12 @@ package Sem_Util is -- Name_uPre, Name_uPost, Name_uInvariant, or Name_uType_Invariant being -- returned to represent the corresponding aspects with x'Class names. + function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean; + -- Subp is the entity for a subprogram call. This function returns True if + -- predicate tests are required for the arguments in this call (this is the + -- normal case). It returns False for special cases where these predicate + -- tests should be skipped (see body for details). + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean; -- Returns True if the names of both entities correspond with matching -- primitives. This routine includes support for the case in which one -- 2.30.2