From 8e1e62e3de4fd41f8c8b813657b638d0c8695dbf Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 6 Feb 2014 11:04:39 +0100 Subject: [PATCH] [multiple changes] 2014-02-06 Hristian Kirtchev * sem_prag.adb (Analyze_Depends_In_Decl_Part): Add local variable Expr. Flag clauses with extra parenthesis as this is not allowed by the syntax of the pragma. Code reformatting. 2014-02-06 Hristian Kirtchev * exp_attr.adb (Expand_N_Attribute_Reference): Alphabetize variables. Rename variabme Tnn to Temp. Do not create a temporary if assertions are disabled. Find enclosing routine _Postconditions and insert the temporary that captures the value of the prefix before the routine. * exp_ch6.adb (Build_Postconditions_Procedure): Insert the generated _Postconditions routine before the first source declaration of the related subprogram. (Insert_After_Last_Declaration): Removed. (Insert_Before_First_Source_Declaration): New routine. 2014-02-06 Ed Schonberg * exp_util.adb, exp_util.ads (Within_Internal_Subprogram): Utility to determine whether current expansion is for the body of a predefined primitive operation. (Make_Predicate_Check): Use Within_Internal_Subpgram * checks.adb (Apply_Predicate_Check): Use Within_Internal_Subprogram * sem_ch13.adb (Freeze_Entity_Checks): Ditto. 2014-02-06 Pascal Obry * prj.ads, prj-util.adb: Minor reformatting. From-SVN: r207537 --- gcc/ada/ChangeLog | 34 +++++++++++ gcc/ada/checks.adb | 44 ++++++++------ gcc/ada/exp_attr.adb | 55 +++++++++-------- gcc/ada/exp_ch6.adb | 54 +++++++++++------ gcc/ada/exp_util.adb | 25 ++++++++ gcc/ada/exp_util.ads | 5 ++ gcc/ada/prj-util.adb | 4 +- gcc/ada/prj.ads | 2 +- gcc/ada/sem_ch13.adb | 10 +++- gcc/ada/sem_prag.adb | 139 +++++++++++++++++++++++++++++-------------- 10 files changed, 261 insertions(+), 111 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3a866ca8035..2b58fce30eb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2014-02-06 Hristian Kirtchev + + * sem_prag.adb (Analyze_Depends_In_Decl_Part): Add + local variable Expr. Flag clauses with extra parenthesis as this + is not allowed by the syntax of the pragma. Code reformatting. + +2014-02-06 Hristian Kirtchev + + * exp_attr.adb (Expand_N_Attribute_Reference): Alphabetize + variables. Rename variabme Tnn to Temp. Do not create a temporary + if assertions are disabled. Find enclosing routine _Postconditions + and insert the temporary that captures the value of the prefix + before the routine. + * exp_ch6.adb (Build_Postconditions_Procedure): + Insert the generated _Postconditions routine + before the first source declaration of the related + subprogram. + (Insert_After_Last_Declaration): Removed. + (Insert_Before_First_Source_Declaration): New routine. + +2014-02-06 Ed Schonberg + + * exp_util.adb, exp_util.ads (Within_Internal_Subprogram): + Utility to determine whether current expansion is for the body + of a predefined primitive operation. + (Make_Predicate_Check): Use Within_Internal_Subpgram + * checks.adb (Apply_Predicate_Check): Use + Within_Internal_Subprogram + * sem_ch13.adb (Freeze_Entity_Checks): Ditto. + +2014-02-06 Pascal Obry + + * prj.ads, prj-util.adb: Minor reformatting. + 2014-02-06 Ed Schonberg * exp_ch6.adb (Expand_Subprogram_Contract, Append_Enabled_Item): diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 7fd8bc576d7..71960ce87c2 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -32,7 +32,6 @@ with Exp_Ch2; use Exp_Ch2; with Exp_Ch4; use Exp_Ch4; with Exp_Ch11; use Exp_Ch11; with Exp_Pakd; use Exp_Pakd; -with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Elists; use Elists; with Expander; use Expander; @@ -2574,15 +2573,15 @@ package body Checks is begin if Present (Predicate_Function (Typ)) then - -- A predicate check does not apply within internally generated - -- subprograms, such as TSS functions. - S := Current_Scope; while Present (S) and then not Is_Subprogram (S) loop S := Scope (S); end loop; - if Present (S) and then Get_TSS_Name (S) /= TSS_Null then + -- A predicate check does not apply within internally generated + -- subprograms, such as TSS functions. + + if Within_Internal_Subprogram then return; -- If the check appears within the predicate function itself, it @@ -2590,7 +2589,7 @@ package body Checks is -- predicated subtype itself, rather than some covering type. This -- is likely to be a common error, and thus deserves a warning. - elsif S = Predicate_Function (Typ) then + elsif Present (S) and then S = Predicate_Function (Typ) then Error_Msg_N ("predicate check includes a function call that " & "requires a predicate check??", Parent (N)); @@ -3208,6 +3207,13 @@ package body Checks is elsif Serious_Errors_Detected > 0 then return; + -- Never generate discriminant checks for Unchecked_Union types + + elsif Present (Expr_Type) + and then Is_Unchecked_Union (Expr_Type) + then + return; + -- Scalar type conversions of the form Target_Type (Expr) require a -- range check if we cannot be sure that Expr is in the base type of -- Target_Typ and also that Expr is in the range of Target_Typ. These @@ -3218,8 +3224,8 @@ package body Checks is declare Conv_OK : constant Boolean := Conversion_OK (N); -- If the Conversion_OK flag on the type conversion is set and no - -- floating point type is involved in the type conversion then - -- fixed point values must be read as integral values. + -- floating-point type is involved in the type conversion then + -- fixed-point values must be read as integral values. Float_To_Int : constant Boolean := Is_Floating_Point_Type (Expr_Type) @@ -3245,9 +3251,9 @@ package body Checks is (Expr, Target_Type, Fixed_Int => Conv_OK); -- If the target type has predicates, we need to indicate - -- the need for a check, even if Determine_Range finds - -- that the value is within bounds. This may be the case - -- e.g for a division with a constant denominator. + -- the need for a check, even if Determine_Range finds that + -- the value is within bounds. This may be the case e.g for + -- a division with a constant denominator. if Has_Predicates (Target_Type) then Enable_Range_Check (Expr); @@ -3267,9 +3273,9 @@ package body Checks is -- An unconstrained derived type may have inherited discriminant. -- Build an actual discriminant constraint list using the stored -- constraint, to verify that the expression of the parent type - -- satisfies the constraints imposed by the (unconstrained) - -- derived type. This applies to value conversions, not to view - -- conversions of tagged types. + -- satisfies the constraints imposed by the (unconstrained) derived + -- type. This applies to value conversions, not to view conversions + -- of tagged types. declare Loc : constant Source_Ptr := Sloc (N); @@ -3794,11 +3800,11 @@ package body Checks is begin pragma Assert - (K = N_Component_Declaration - or else K = N_Discriminant_Specification - or else K = N_Function_Specification - or else K = N_Object_Declaration - or else K = N_Parameter_Specification); + (Nkind_In (K, N_Component_Declaration, + N_Discriminant_Specification, + N_Function_Specification, + N_Object_Declaration, + N_Parameter_Specification)); if K = N_Function_Specification then Typ := Etype (Defining_Entity (N)); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a52342cf409..624661ca753 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3806,9 +3806,9 @@ package body Exp_Attr is --------- when Attribute_Old => Old : declare - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', Pref); - Subp : Node_Id; Asn_Stm : Node_Id; + Subp : Node_Id; + Temp : Entity_Id; begin -- If assertions are disabled, no need to create the declaration @@ -3818,41 +3818,46 @@ package body Exp_Attr is return; end if; - -- Find the nearest subprogram body, ignoring _Preconditions + Temp := Make_Temporary (Loc, 'T', Pref); + + -- Climb the parent chain looking for subprogram _Postconditions Subp := N; - loop - Subp := Parent (Subp); + while Present (Subp) loop exit when Nkind (Subp) = N_Subprogram_Body - and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions; + and then Chars (Defining_Entity (Subp)) = Name_uPostconditions; + + Subp := Parent (Subp); end loop; - -- Insert the initialized object declaration at the start of the - -- subprogram's declarations. + -- 'Old can only appear in a postcondition, the generated body of + -- _Postconditions must be in the tree. + + pragma Assert (Present (Subp)); + + -- Generate: + -- Temp : constant := ; Asn_Stm := Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, + Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Occurrence_Of (Etype (N), Loc), Expression => Pref); - -- Push the subprogram's scope, so that the object will be analyzed - -- in that context (rather than the context of the Precondition - -- subprogram) and will have its Scope set properly. + -- Push the scope of the related subprogram where _Postcondition + -- resides as this ensures that the object will be analyzed in the + -- proper context. - if Present (Corresponding_Spec (Subp)) then - Push_Scope (Corresponding_Spec (Subp)); - else - Push_Scope (Defining_Entity (Subp)); - end if; + Push_Scope (Scope (Defining_Entity (Subp))); - if Is_Empty_List (Declarations (Subp)) then - Set_Declarations (Subp, New_List (Asn_Stm)); - Analyze (Asn_Stm); - else - Insert_Action (First (Declarations (Subp)), Asn_Stm); - end if; + -- The object declaration is inserted before the body of subprogram + -- _Postconditions. This ensures that any precondition-like actions + -- are still executed before any parameter values are captured and + -- the multiple 'Old occurrences appear in order of declaration. + + Insert_Before_And_Analyze (Subp, Asn_Stm); + Pop_Scope; -- Ensure that the prefix of attribute 'Old is valid. The check must -- be inserted after the expansion of the attribute has taken place @@ -3862,9 +3867,7 @@ package body Exp_Attr is Ensure_Valid (Pref); end if; - Pop_Scope; - - Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); end Old; ---------------------- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 52cc9c8d1ee..7ee0115ef9c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -8911,26 +8911,46 @@ package body Exp_Ch6 is Stmts : List_Id; Result : Entity_Id) is - procedure Insert_After_Last_Declaration (Stmt : Node_Id); - -- Insert node Stmt after the last declaration of the subprogram body + procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id); + -- Insert node Stmt before the first source declaration of the + -- related subprogram's body. If no such declaration exists, Stmt + -- becomes the last declaration. - ----------------------------------- - -- Insert_After_Last_Declaration -- - ----------------------------------- + -------------------------------------------- + -- Insert_Before_First_Source_Declaration -- + -------------------------------------------- - procedure Insert_After_Last_Declaration (Stmt : Node_Id) is - Decls : List_Id := Declarations (N); + procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id) is + Decls : constant List_Id := Declarations (N); + Decl : Node_Id; begin + -- Inspect the declarations of the related subprogram body looking + -- for the first source declaration. + + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) loop + if Comes_From_Source (Decl) then + Insert_Before (Decl, Stmt); + return; + end if; + + Next (Decl); + end loop; + + -- If we get there, then the subprogram body lacks any source + -- declarations. The body of _Postconditions now acts as the + -- last declaration. + + Append (Stmt, Decls); + -- Ensure that the body has a declaration list - if No (Decls) then - Decls := New_List; - Set_Declarations (N, Decls); + else + Set_Declarations (N, New_List (Stmt)); end if; - - Append_To (Decls, Stmt); - end Insert_After_Last_Declaration; + end Insert_Before_First_Source_Declaration; -- Local variables @@ -8965,9 +8985,9 @@ package body Exp_Ch6 is New_Reference_To (Etype (Result), Loc))); end if; - -- Insert _Postconditions after the last declaration of the body. - -- This ensures that the body will not cause any premature freezing - -- as it may mention types: + -- Insert _Postconditions before the first source declaration of the + -- body. This ensures that the body will not cause any premature + -- freezing as it may mention types: -- procedure Proc (Obj : Array_Typ) is -- procedure _postconditions is @@ -8983,7 +9003,7 @@ package body Exp_Ch6 is -- order reference. The body of _Postconditions must be placed after -- the declaration of Temp to preserve correct visibility. - Insert_After_Last_Declaration ( + Insert_Before_First_Source_Declaration ( Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 7c1c75c8bf3..dd5766b469e 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5752,6 +5752,13 @@ package body Exp_Util is return Make_Null_Statement (Loc); end if; + -- Do not generate a check within an internal subprogram (stream + -- functions and the like, including including predicate functions). + + if Within_Internal_Subprogram then + return Make_Null_Statement (Loc); + end if; + -- Compute proper name to use, we need to get this right so that the -- right set of check policies apply to the Check pragma we are making. @@ -8213,6 +8220,24 @@ package body Exp_Util is return False; end Within_Case_Or_If_Expression; + -------------------------------- + -- Within_Internal_Subprogram -- + -------------------------------- + + function Within_Internal_Subprogram return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) and then not Is_Subprogram (S) loop + S := Scope (S); + end loop; + + return Present (S) + and then Get_TSS_Name (S) /= TSS_Null + and then not Is_Predicate_Function (S); + end Within_Internal_Subprogram; + ---------------------------- -- Wrap_Cleanup_Procedure -- ---------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index bf72220f826..8fa66a9eae1 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -834,6 +834,11 @@ package Exp_Util is function Within_Case_Or_If_Expression (N : Node_Id) return Boolean; -- Determine whether arbitrary node N is within a case or an if expression + function Within_Internal_Subprogram return Boolean; + -- Indicates that some expansion is taking place within the body of a + -- predefined primitive operation. Some expansion activity (e.g. predicate + -- checks) is disabled in such. + procedure Wrap_Cleanup_Procedure (N : Node_Id); -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call -- at the start of the statement sequence, and an Abort_Undefer call at the diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index 2c70d1feeac..1cea3163d7f 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2013, 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- -- @@ -469,7 +469,7 @@ package body Prj.Util is if Sid.Kind = Spec and then not Sid.Locally_Removed and then (Project.Standalone_Library = No - or else Sid.Declared_In_Interfaces) + or else Sid.Declared_In_Interfaces) then Action (Sid); diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index bcfb6d01182..5607502a34c 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1353,7 +1353,7 @@ package Prj is -- Indicate that this is a Standalone Library Project File Lib_Interface_ALIs : String_List_Id := Nil_String; - -- For Standalone Library Project Files, list of Interface ALI files. + -- For Standalone Library Project Files, list of Interface ALI files Other_Interfaces : String_List_Id := Nil_String; -- List of non unit based sources in attribute Interfaces diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 10fc6da31a7..c6034193980 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6686,6 +6686,7 @@ package body Sem_Ch13 is -- Build function declaration Set_Ekind (SId, E_Function); + Set_Is_Internal (SId); Set_Is_Predicate_Function (SId); Set_Predicate_Function (Typ, SId); @@ -9429,9 +9430,14 @@ package body Sem_Ch13 is Inside_Freezing_Actions := Inside_Freezing_Actions - 1; -- If we have a type with predicates, build predicate function. This - -- is not needed in the generic casee + -- is not needed in the generic casee, and is not needed within TSS + -- subprograms and other predefined primitives. - if Non_Generic_Case and then Is_Type (E) and then Has_Predicates (E) then + if Non_Generic_Case + and then Is_Type (E) + and then Has_Predicates (E) + and then not Within_Internal_Subprogram + then Build_Predicate_Functions (E, N); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 98e674f5433..04759e70813 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1597,6 +1597,7 @@ package body Sem_Prag is Clause : Node_Id; Errors : Nat; + Expr : Node_Id; Last_Clause : Node_Id; Subp_Decl : Node_Id; @@ -1653,72 +1654,122 @@ package body Sem_Prag is -- Dependency clauses appear as component associations of an aggregate - elsif Nkind (Clause) = N_Aggregate - and then Present (Component_Associations (Clause)) - then - Last_Clause := Last (Component_Associations (Clause)); + elsif Nkind (Clause) = N_Aggregate then - -- Gather all states, variables and formal parameters that the - -- subprogram may depend on. These items are obtained from the - -- parameter profile or pragma [Refined_]Global (if available). + -- The aggregate should not have an expression list because a clause + -- is always interpreted as a component association. The only way an + -- expression list can sneak in is by adding extra parenthesis around + -- the individual clauses: - Collect_Subprogram_Inputs_Outputs - (Subp_Id => Subp_Id, - Subp_Inputs => Subp_Inputs, - Subp_Outputs => Subp_Outputs, - Global_Seen => Global_Seen); + -- Depends (Output => Input) -- proper form + -- Depends ((Output => Input)) -- extra parenthesis - -- Ensure that the formal parameters are visible when analyzing all - -- clauses. This falls out of the general rule of aspects pertaining - -- to subprogram declarations. Skip the installation for subprogram - -- bodies because the formals are already visible. + -- Since the extra parenthesis are not allowed by the syntax of the + -- pragma, flag them now to avoid emitting misleading errors down the + -- line. - if not In_Open_Scopes (Spec_Id) then - Restore_Scope := True; - Push_Scope (Spec_Id); - Install_Formals (Spec_Id); + if Present (Expressions (Clause)) then + Expr := First (Expressions (Clause)); + while Present (Expr) loop + + -- A dependency clause surrounded by extra parenthesis appears + -- as an aggregate of component associations with an optional + -- Paren_Count set. + + if Nkind (Expr) = N_Aggregate + and then Present (Component_Associations (Expr)) + then + Error_Msg_N + ("dependency clause contains extra parenthesis", Expr); + + -- Otherwise the expression is a malformed construct + + else + Error_Msg_N ("malformed dependency clause", Expr); + end if; + + Next (Expr); + end loop; + + -- Do not attempt to perform analysis of syntactically illegal + -- clauses as this will lead to misleading errors. + + return; end if; - Clause := First (Component_Associations (Clause)); - while Present (Clause) loop - Errors := Serious_Errors_Detected; + if Present (Component_Associations (Clause)) then + Last_Clause := Last (Component_Associations (Clause)); - -- Normalization may create extra clauses that contain replicated - -- input and output names. There is no need to reanalyze them. + -- Gather all states, variables and formal parameters that the + -- subprogram may depend on. These items are obtained from the + -- parameter profile or pragma [Refined_]Global (if available). - if not Analyzed (Clause) then - Set_Analyzed (Clause); + Collect_Subprogram_Inputs_Outputs + (Subp_Id => Subp_Id, + Subp_Inputs => Subp_Inputs, + Subp_Outputs => Subp_Outputs, + Global_Seen => Global_Seen); - Analyze_Dependency_Clause - (Clause => Clause, - Is_Last => Clause = Last_Clause); + -- Ensure that the formal parameters are visible when analyzing + -- all clauses. This falls out of the general rule of aspects + -- pertaining to subprogram declarations. Skip the installation + -- for subprogram bodies because the formals are already visible. + + if not In_Open_Scopes (Spec_Id) then + Restore_Scope := True; + Push_Scope (Spec_Id); + Install_Formals (Spec_Id); end if; - -- Do not normalize an erroneous clause because the inputs and/or - -- outputs may denote illegal items. + Clause := First (Component_Associations (Clause)); + while Present (Clause) loop + Errors := Serious_Errors_Detected; + + -- Normalization may create extra clauses that contain + -- replicated input and output names. There is no need to + -- reanalyze them. + + if not Analyzed (Clause) then + Set_Analyzed (Clause); + + Analyze_Dependency_Clause + (Clause => Clause, + Is_Last => Clause = Last_Clause); + end if; + + -- Do not normalize an erroneous clause because the inputs + -- and/or outputs may denote illegal items. + + if Serious_Errors_Detected = Errors then + Normalize_Clause (Clause); + end if; + + Next (Clause); + end loop; - if Serious_Errors_Detected = Errors then - Normalize_Clause (Clause); + if Restore_Scope then + End_Scope; end if; - Next (Clause); - end loop; + -- Verify that every input or output of the subprogram appear in a + -- dependency. - if Restore_Scope then - End_Scope; - end if; + Check_Usage (Subp_Inputs, All_Inputs_Seen, True); + Check_Usage (Subp_Outputs, All_Outputs_Seen, False); + Check_Function_Return; - -- Verify that every input or output of the subprogram appear in a - -- dependency. + -- The dependency list is malformed - Check_Usage (Subp_Inputs, All_Inputs_Seen, True); - Check_Usage (Subp_Outputs, All_Outputs_Seen, False); - Check_Function_Return; + else + Error_Msg_N ("malformed dependency relation", Clause); + return; + end if; -- The top level dependency relation is malformed else Error_Msg_N ("malformed dependency relation", Clause); + return; end if; -- Ensure that a state and a corresponding constituent do not appear -- 2.30.2