From b9eb3aa8a2f9c09ade591ed1a1edc12f0e73ed73 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 26 May 2015 09:20:53 +0000 Subject: [PATCH] exp_ch6.adb (Process_Contract_Cases_For): Update the call to Expand_Pragma_Contract_Cases. 2015-05-26 Hristian Kirtchev * exp_ch6.adb (Process_Contract_Cases_For): Update the call to Expand_Pragma_Contract_Cases. * exp_prag.ads, exp_prag.adb (Expand_Contract_Cases): Rename to Expand_Pragma_Contract_Cases. * sem_ch13.adb (Add_Invariants): Use the original aspect name when creating the arguments of pragma Check. This ensures that 'Class is properly recognized and handled. From-SVN: r223671 --- gcc/ada/ChangeLog | 10 + gcc/ada/exp_ch6.adb | 4 +- gcc/ada/exp_prag.adb | 1686 +++++++++++++++++++++--------------------- gcc/ada/exp_prag.ads | 4 +- gcc/ada/sem_ch13.adb | 9 +- 5 files changed, 859 insertions(+), 854 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 540e11e64ac..f1c76f6c329 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2015-05-26 Hristian Kirtchev + + * exp_ch6.adb (Process_Contract_Cases_For): Update the call to + Expand_Pragma_Contract_Cases. + * exp_prag.ads, exp_prag.adb (Expand_Contract_Cases): Rename to + Expand_Pragma_Contract_Cases. + * sem_ch13.adb (Add_Invariants): Use the original aspect name + when creating the arguments of pragma Check. This ensures that + 'Class is properly recognized and handled. + 2015-05-26 Arnaud Charlet * gnat1drv.adb: Minor adjustments. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 78bd94cdc86..016264162bd 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1856,7 +1856,7 @@ package body Exp_Ch6 is and then Nkind (Parent (Subp)) = N_Private_Extension_Declaration then - if Comes_From_Source (N) and then Is_Public_Subp then + if Comes_From_Source (N) and then Is_Public_Subp then Append_To (Post_Call, Make_Invariant_Call (Actual)); end if; @@ -7292,7 +7292,7 @@ package body Exp_Ch6 is Prag := Contract_Test_Cases (Items); while Present (Prag) loop if Pragma_Name (Prag) = Name_Contract_Cases then - Expand_Contract_Cases + Expand_Pragma_Contract_Cases (CCs => Prag, Subp_Id => Subp_Id, Decls => Declarations (N), diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 16096a412b7..2df57f48503 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -156,1081 +156,1081 @@ package body Exp_Prag is end if; end Arg3; - --------------------------- - -- Expand_Contract_Cases -- - --------------------------- - - -- Pragma Contract_Cases is expanded in the following manner: + --------------------- + -- Expand_N_Pragma -- + --------------------- - -- subprogram S is - -- Count : Natural := 0; - -- Flag_1 : Boolean := False; - -- . . . - -- Flag_N : Boolean := False; - -- Flag_N+1 : Boolean := False; -- when "others" present - -- Pref_1 : ...; - -- . . . - -- Pref_M : ...; + procedure Expand_N_Pragma (N : Node_Id) is + Pname : constant Name_Id := Pragma_Name (N); - -- + begin + -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that + -- the back end or the expander here does not get over-enthusiastic and + -- start processing such a pragma! - -- -- Evaluate all case guards + if Get_Name_Table_Boolean3 (Pname) then + Rewrite (N, Make_Null_Statement (Sloc (N))); + return; + end if; - -- if Case_Guard_1 then - -- Flag_1 := True; - -- Count := Count + 1; - -- end if; - -- . . . - -- if Case_Guard_N then - -- Flag_N := True; - -- Count := Count + 1; - -- end if; + -- Note: we may have a pragma whose Pragma_Identifier field is not a + -- recognized pragma, and we must ignore it at this stage. - -- -- Emit errors depending on the number of case guards that - -- -- evaluated to True. + if Is_Pragma_Name (Pname) then + case Get_Pragma_Id (Pname) is - -- if Count = 0 then - -- raise Assertion_Error with "xxx contract cases incomplete"; - -- - -- Flag_N+1 := True; -- when "others" present + -- Pragmas requiring special expander action - -- elsif Count > 1 then - -- declare - -- Str0 : constant String := - -- "contract cases overlap for subprogram ABC"; - -- Str1 : constant String := - -- (if Flag_1 then - -- Str0 & "case guard at xxx evaluates to True" - -- else Str0); - -- StrN : constant String := - -- (if Flag_N then - -- StrN-1 & "case guard at xxx evaluates to True" - -- else StrN-1); - -- begin - -- raise Assertion_Error with StrN; - -- end; - -- end if; + when Pragma_Abort_Defer => + Expand_Pragma_Abort_Defer (N); - -- -- Evaluate all attribute 'Old prefixes found in the selected - -- -- consequence. + when Pragma_Check => + Expand_Pragma_Check (N); - -- if Flag_1 then - -- Pref_1 := - -- . . . - -- elsif Flag_N then - -- Pref_M := - -- end if; + when Pragma_Common_Object => + Expand_Pragma_Common_Object (N); - -- procedure _Postconditions is - -- begin - -- + when Pragma_Import => + Expand_Pragma_Import_Or_Interface (N); - -- if Flag_1 and then not Consequence_1 then - -- raise Assertion_Error with "failed contract case at xxx"; - -- end if; - -- . . . - -- if Flag_N[+1] and then not Consequence_N[+1] then - -- raise Assertion_Error with "failed contract case at xxx"; - -- end if; - -- end _Postconditions; - -- begin - -- . . . - -- end S; + when Pragma_Inspection_Point => + Expand_Pragma_Inspection_Point (N); - procedure Expand_Contract_Cases - (CCs : Node_Id; - Subp_Id : Entity_Id; - Decls : List_Id; - Stmts : in out List_Id) - is - Loc : constant Source_Ptr := Sloc (CCs); + when Pragma_Interface => + Expand_Pragma_Import_Or_Interface (N); - procedure Case_Guard_Error - (Decls : List_Id; - Flag : Entity_Id; - Error_Loc : Source_Ptr; - Msg : in out Entity_Id); - -- Given a declarative list Decls, status flag Flag, the location of the - -- error and a string Msg, construct the following check: - -- Msg : constant String := - -- (if Flag then - -- Msg & "case guard at Error_Loc evaluates to True" - -- else Msg); - -- The resulting code is added to Decls + when Pragma_Interrupt_Priority => + Expand_Pragma_Interrupt_Priority (N); - procedure Consequence_Error - (Checks : in out Node_Id; - Flag : Entity_Id; - Conseq : Node_Id); - -- Given an if statement Checks, status flag Flag and a consequence - -- Conseq, construct the following check: - -- [els]if Flag and then not Conseq then - -- raise Assertion_Error - -- with "failed contract case at Sloc (Conseq)"; - -- [end if;] - -- The resulting code is added to Checks + when Pragma_Loop_Variant => + Expand_Pragma_Loop_Variant (N); - function Declaration_Of (Id : Entity_Id) return Node_Id; - -- Given the entity Id of a boolean flag, generate: - -- Id : Boolean := False; + when Pragma_Psect_Object => + Expand_Pragma_Psect_Object (N); - procedure Expand_Attributes_In_Consequence - (Decls : List_Id; - Evals : in out Node_Id; - Flag : Entity_Id; - Conseq : Node_Id); - -- Perform specialized expansion of all attribute 'Old references found - -- in consequence Conseq such that at runtime only prefixes coming from - -- the selected consequence are evaluated. Similarly expand attribute - -- 'Result references by replacing them with identifier _result which - -- resolves to the sole formal parameter of procedure _Postconditions. - -- Any temporaries generated in the process are added to declarations - -- Decls. Evals is a complex if statement tasked with the evaluation of - -- all prefixes coming from a single selected consequence. Flag is the - -- corresponding case guard flag. Conseq is the consequence expression. + when Pragma_Relative_Deadline => + Expand_Pragma_Relative_Deadline (N); - function Increment (Id : Entity_Id) return Node_Id; - -- Given the entity Id of a numerical variable, generate: - -- Id := Id + 1; + when Pragma_Suppress_Initialization => + Expand_Pragma_Suppress_Initialization (N); - function Set (Id : Entity_Id) return Node_Id; - -- Given the entity Id of a boolean variable, generate: - -- Id := True; + -- All other pragmas need no expander action - ---------------------- - -- Case_Guard_Error -- - ---------------------- + when others => null; + end case; + end if; - procedure Case_Guard_Error - (Decls : List_Id; - Flag : Entity_Id; - Error_Loc : Source_Ptr; - Msg : in out Entity_Id) - is - New_Line : constant Character := Character'Val (10); - New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); + end Expand_N_Pragma; - begin - Start_String; - Store_String_Char (New_Line); - Store_String_Chars (" case guard at "); - Store_String_Chars (Build_Location_String (Error_Loc)); - Store_String_Chars (" evaluates to True"); + ------------------------------- + -- Expand_Pragma_Abort_Defer -- + ------------------------------- - -- Generate: - -- New_Msg : constant String := - -- (if Flag then - -- Msg & "case guard at Error_Loc evaluates to True" - -- else Msg); + -- An Abort_Defer pragma appears as the first statement in a handled + -- statement sequence (right after the begin). It defers aborts for + -- the entire statement sequence, but not for any declarations or + -- handlers (if any) associated with this statement sequence. - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => New_Msg, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Standard_String, Loc), - Expression => - Make_If_Expression (Loc, - Expressions => New_List ( - New_Occurrence_Of (Flag, Loc), + -- The transformation is to transform - Make_Op_Concat (Loc, - Left_Opnd => New_Occurrence_Of (Msg, Loc), - Right_Opnd => Make_String_Literal (Loc, End_String)), + -- pragma Abort_Defer; + -- statements; - New_Occurrence_Of (Msg, Loc))))); + -- into - Msg := New_Msg; - end Case_Guard_Error; + -- begin + -- Abort_Defer.all; + -- statements + -- exception + -- when all others => + -- Abort_Undefer.all; + -- raise; + -- at end + -- Abort_Undefer_Direct; + -- end; - ----------------------- - -- Consequence_Error -- - ----------------------- + procedure Expand_Pragma_Abort_Defer (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stm : Node_Id; + Stms : List_Id; + HSS : Node_Id; + Blk : constant Entity_Id := + New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); + AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); - procedure Consequence_Error - (Checks : in out Node_Id; - Flag : Entity_Id; - Conseq : Node_Id) - is - Cond : Node_Id; - Error : Node_Id; + begin + Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); + loop + Stm := Remove_Next (N); + exit when No (Stm); + Append (Stm, Stms); + end loop; - begin - -- Generate: - -- Flag and then not Conseq + HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms, + At_End_Proc => New_Occurrence_Of (AUD, Loc)); - Cond := - Make_And_Then (Loc, - Left_Opnd => New_Occurrence_Of (Flag, Loc), - Right_Opnd => - Make_Op_Not (Loc, - Right_Opnd => Relocate_Node (Conseq))); + -- Present the Abort_Undefer_Direct function to the backend so that it + -- can inline the call to the function. - -- Generate: - -- raise Assertion_Error - -- with "failed contract case at Sloc (Conseq)"; + Add_Inlined_Body (AUD, N); - Start_String; - Store_String_Chars ("failed contract case at "); - Store_String_Chars (Build_Location_String (Sloc (Conseq))); + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => HSS)); - Error := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, End_String))); + Set_Scope (Blk, Current_Scope); + Set_Etype (Blk, Standard_Void_Type); + Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); + Expand_At_End_Handler (HSS, Blk); + Analyze (N); + end Expand_Pragma_Abort_Defer; - if No (Checks) then - Checks := - Make_Implicit_If_Statement (CCs, - Condition => Cond, - Then_Statements => New_List (Error)); + -------------------------- + -- Expand_Pragma_Check -- + -------------------------- - else - if No (Elsif_Parts (Checks)) then - Set_Elsif_Parts (Checks, New_List); - end if; + procedure Expand_Pragma_Check (N : Node_Id) is + Cond : constant Node_Id := Arg2 (N); + Nam : constant Name_Id := Chars (Arg1 (N)); + Msg : Node_Id; - Append_To (Elsif_Parts (Checks), - Make_Elsif_Part (Loc, - Condition => Cond, - Then_Statements => New_List (Error))); - end if; - end Consequence_Error; + Loc : constant Source_Ptr := Sloc (First_Node (Cond)); + -- Source location used in the case of a failed assertion: point to the + -- failing condition, not Loc. Note that the source location of the + -- expression is not usually the best choice here, because it points to + -- the location of the topmost tree node, which may be an operator in + -- the middle of the source text of the expression. For example, it gets + -- located on the last AND keyword in a chain of boolean expressiond + -- AND'ed together. It is best to put the message on the first character + -- of the condition, which is the effect of the First_Node call here. + -- This source location is used to build the default exception message, + -- and also as the sloc of the call to the runtime subprogram raising + -- Assert_Failure, so that coverage analysis tools can relate the + -- call to the failed check. - -------------------- - -- Declaration_Of -- - -------------------- + begin + -- Nothing to do if pragma is ignored - function Declaration_Of (Id : Entity_Id) return Node_Id is - begin - return - Make_Object_Declaration (Loc, - Defining_Identifier => Id, - Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), - Expression => New_Occurrence_Of (Standard_False, Loc)); - end Declaration_Of; + if Is_Ignored (N) then + return; + end if; - -------------------------------------- - -- Expand_Attributes_In_Consequence -- - -------------------------------------- + -- Since this check is active, we rewrite the pragma into a + -- corresponding if statement, and then analyze the statement - procedure Expand_Attributes_In_Consequence - (Decls : List_Id; - Evals : in out Node_Id; - Flag : Entity_Id; - Conseq : Node_Id) - is - Eval_Stmts : List_Id := No_List; - -- The evaluation sequence expressed as assignment statements of all - -- prefixes of attribute 'Old found in the current consequence. + -- The normal case expansion transforms: - function Expand_Attributes (N : Node_Id) return Traverse_Result; - -- Determine whether an arbitrary node denotes attribute 'Old or - -- 'Result and if it does, perform all expansion-related actions. + -- pragma Check (name, condition [,message]); - ----------------------- - -- Expand_Attributes -- - ----------------------- + -- into - function Expand_Attributes (N : Node_Id) return Traverse_Result is - Decl : Node_Id; - Pref : Node_Id; - Temp : Entity_Id; + -- if not condition then + -- System.Assertions.Raise_Assert_Failure (Str); + -- end if; - begin - -- Attribute 'Old + -- where Str is the message if one is present, or the default of + -- name failed at file:line if no message is given (the "name failed + -- at" is omitted for name = Assertion, since it is redundant, given + -- that the name of the exception is Assert_Failure.) - if Nkind (N) = N_Attribute_Reference - and then Attribute_Name (N) = Name_Old - then - Pref := Prefix (N); - Temp := Make_Temporary (Loc, 'T', Pref); - Set_Etype (Temp, Etype (Pref)); + -- Also, instead of "XXX failed at", we generate slightly + -- different messages for some of the contract assertions (see + -- code below for details). - -- Generate a temporary to capture the value of the prefix: - -- Temp : ; - -- Place that temporary at the beginning of declarations, to - -- prevent anomalies in the GNATprove flow-analysis pass in - -- the precondition procedure that follows. + -- An alternative expansion is used when the No_Exception_Propagation + -- restriction is active and there is a local Assert_Failure handler. + -- This is not a common combination of circumstances, but it occurs in + -- the context of Aunit and the zero footprint profile. In this case we + -- generate: - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Etype (Pref), Loc)); - Set_No_Initialization (Decl); + -- if not condition then + -- raise Assert_Failure; + -- end if; - Prepend_To (Decls, Decl); - Analyze (Decl); + -- This will then be transformed into a goto, and the local handler will + -- be able to handle the assert error (which would not be the case if a + -- call is made to the Raise_Assert_Failure procedure). - -- Evaluate the prefix, generate: - -- Temp := ; + -- We also generate the direct raise if the Suppress_Exception_Locations + -- is active, since we don't want to generate messages in this case. - if No (Eval_Stmts) then - Eval_Stmts := New_List; - end if; + -- Note that the reason we do not always generate a direct raise is that + -- the form in which the procedure is called allows for more efficient + -- breakpointing of assertion errors. - Append_To (Eval_Stmts, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp, Loc), - Expression => Pref)); + -- Generate the appropriate if statement. Note that we consider this to + -- be an explicit conditional in the source, not an implicit if, so we + -- do not call Make_Implicit_If_Statement. - -- Ensure that the prefix is valid + -- Case where we generate a direct raise - if Validity_Checks_On and then Validity_Check_Operands then - Ensure_Valid (Pref); - end if; + if ((Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation)) + and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) + or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) + then + Rewrite (N, + Make_If_Statement (Loc, + Condition => Make_Op_Not (Loc, Right_Opnd => Cond), + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc))))); - -- Replace the original attribute 'Old by a reference to the - -- generated temporary. + -- Case where we call the procedure - Rewrite (N, New_Occurrence_Of (Temp, Loc)); + else + -- If we have a message given, use it - -- Attribute 'Result + if Present (Arg3 (N)) then + Msg := Get_Pragma_Arg (Arg3 (N)); - elsif Is_Attribute_Result (N) then - Rewrite (N, Make_Identifier (Loc, Name_uResult)); - end if; + -- Here we have no string, so prepare one - return OK; - end Expand_Attributes; + else + declare + Loc_Str : constant String := Build_Location_String (Loc); - procedure Expand_Attributes_In is - new Traverse_Proc (Expand_Attributes); + begin + Name_Len := 0; - -- Start of processing for Expand_Attributes_In_Consequence + -- For Assert, we just use the location - begin - -- Inspect the consequence and expand any attribute 'Old and 'Result - -- references found within. + if Nam = Name_Assert then + null; - Expand_Attributes_In (Conseq); + -- For predicate, we generate the string "predicate failed at + -- yyy". We prefer all lower case for predicate. - -- The consequence does not contain any attribute 'Old references + elsif Nam = Name_Predicate then + Add_Str_To_Name_Buffer ("predicate failed at "); - if No (Eval_Stmts) then - return; - end if; + -- For special case of Precondition/Postcondition the string is + -- "failed xx from yy" where xx is precondition/postcondition + -- in all lower case. The reason for this different wording is + -- that the failure is not at the point of occurrence of the + -- pragma, unlike the other Check cases. - -- Augment the machinery to trigger the evaluation of all prefixes - -- found in the step above. If Eval is empty, then this is the first - -- consequence to yield expansion of 'Old. Generate: + elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then + Get_Name_String (Nam); + Insert_Str_In_Name_Buffer ("failed ", 1); + Add_Str_To_Name_Buffer (" from "); - -- if Flag then - -- - -- end if; + -- For special case of Invariant, the string is "failed + -- invariant from yy", to be consistent with the string that is + -- generated for the aspect case (the code later on checks for + -- this specific string to modify it in some cases, so this is + -- functionally important). - if No (Evals) then - Evals := - Make_Implicit_If_Statement (CCs, - Condition => New_Occurrence_Of (Flag, Loc), - Then_Statements => Eval_Stmts); + elsif Nam = Name_Invariant then + Add_Str_To_Name_Buffer ("failed invariant from "); - -- Otherwise generate: - -- elsif Flag then - -- - -- end if; + -- For all other checks, the string is "xxx failed at yyy" + -- where xxx is the check name with current source file casing. - else - if No (Elsif_Parts (Evals)) then - Set_Elsif_Parts (Evals, New_List); - end if; + else + Get_Name_String (Nam); + Set_Casing (Identifier_Casing (Current_Source_File)); + Add_Str_To_Name_Buffer (" failed at "); + end if; - Append_To (Elsif_Parts (Evals), - Make_Elsif_Part (Loc, - Condition => New_Occurrence_Of (Flag, Loc), - Then_Statements => Eval_Stmts)); - end if; - end Expand_Attributes_In_Consequence; + -- In all cases, add location string - --------------- - -- Increment -- - --------------- + Add_Str_To_Name_Buffer (Loc_Str); - function Increment (Id : Entity_Id) return Node_Id is - begin - return - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Id, Loc), - Expression => - Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - end Increment; + -- Build the message - --------- - -- Set -- - --------- + Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); + end; + end if; - function Set (Id : Entity_Id) return Node_Id is - begin - return - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Id, Loc), - Expression => New_Occurrence_Of (Standard_True, Loc)); - end Set; + -- Now rewrite as an if statement - -- Local variables + Rewrite (N, + Make_If_Statement (Loc, + Condition => Make_Op_Not (Loc, Right_Opnd => Cond), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List (Relocate_Node (Msg)))))); + end if; - Aggr : constant Node_Id := - Expression (First - (Pragma_Argument_Associations (CCs))); - Case_Guard : Node_Id; - CG_Checks : Node_Id; - CG_Stmts : List_Id; - Conseq : Node_Id; - Conseq_Checks : Node_Id := Empty; - Count : Entity_Id; - Count_Decl : Node_Id; - Error_Decls : List_Id; - Flag : Entity_Id; - Flag_Decl : Node_Id; - If_Stmt : Node_Id; - Msg_Str : Entity_Id; - Multiple_PCs : Boolean; - Old_Evals : Node_Id := Empty; - Others_Decl : Node_Id; - Others_Flag : Entity_Id := Empty; - Post_Case : Node_Id; + Analyze (N); - -- Start of processing for Expand_Contract_Cases + -- If new condition is always false, give a warning - begin - -- Do nothing if pragma is not enabled. If pragma is disabled, it has - -- already been rewritten as a Null statement. + if Warn_On_Assertion_Failure + and then Nkind (N) = N_Procedure_Call_Statement + and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) + then + -- If original condition was a Standard.False, we assume that this is + -- indeed intended to raise assert error and no warning is required. - if Is_Ignored (CCs) then - return; + if Is_Entity_Name (Original_Node (Cond)) + and then Entity (Original_Node (Cond)) = Standard_False + then + return; - -- Guard against malformed contract cases + elsif Nam = Name_Assert then + Error_Msg_N ("?A?assertion will fail at run time", N); + else - elsif Nkind (Aggr) /= N_Aggregate then - return; + Error_Msg_N ("?A?check will fail at run time", N); + end if; end if; + end Expand_Pragma_Check; - Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1; + --------------------------------- + -- Expand_Pragma_Common_Object -- + --------------------------------- - -- Create the counter which tracks the number of case guards that - -- evaluate to True. + -- Use a machine attribute to replicate semantic effect in DEC Ada - -- Count : Natural := 0; + -- pragma Machine_Attribute (intern_name, "common_object", extern_name); - Count := Make_Temporary (Loc, 'C'); - Count_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Count, - Object_Definition => New_Occurrence_Of (Standard_Natural, Loc), - Expression => Make_Integer_Literal (Loc, 0)); + -- For now we do nothing with the size attribute ??? - Prepend_To (Decls, Count_Decl); - Analyze (Count_Decl); + -- Note: Psect_Object shares this processing - -- Create the base error message for multiple overlapping case guards + procedure Expand_Pragma_Common_Object (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); - -- Msg_Str : constant String := - -- "contract cases overlap for subprogram Subp_Id"; + Internal : constant Node_Id := Arg1 (N); + External : constant Node_Id := Arg2 (N); - if Multiple_PCs then - Msg_Str := Make_Temporary (Loc, 'S'); + Psect : Node_Id; + -- Psect value upper cased as string literal - Start_String; - Store_String_Chars ("contract cases overlap for subprogram "); - Store_String_Chars (Get_Name_String (Chars (Subp_Id))); + Iloc : constant Source_Ptr := Sloc (Internal); + Eloc : constant Source_Ptr := Sloc (External); + Ploc : Source_Ptr; - Error_Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Msg_Str, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Standard_String, Loc), - Expression => Make_String_Literal (Loc, End_String))); - end if; + begin + -- Acquire Psect value and fold to upper case - -- Process individual post cases + if Present (External) then + if Nkind (External) = N_String_Literal then + String_To_Name_Buffer (Strval (External)); + else + Get_Name_String (Chars (External)); + end if; - Post_Case := First (Component_Associations (Aggr)); - while Present (Post_Case) loop - Case_Guard := First (Choices (Post_Case)); - Conseq := Expression (Post_Case); + Set_All_Upper_Case; - -- The "others" choice requires special processing + Psect := + Make_String_Literal (Eloc, Strval => String_From_Name_Buffer); - if Nkind (Case_Guard) = N_Others_Choice then - Others_Flag := Make_Temporary (Loc, 'F'); - Others_Decl := Declaration_Of (Others_Flag); + else + Get_Name_String (Chars (Internal)); + Set_All_Upper_Case; + Psect := + Make_String_Literal (Iloc, Strval => String_From_Name_Buffer); + end if; - Prepend_To (Decls, Others_Decl); - Analyze (Others_Decl); + Ploc := Sloc (Psect); - -- Check possible overlap between a case guard and "others" + -- Insert the pragma - if Multiple_PCs and Exception_Extra_Info then - Case_Guard_Error - (Decls => Error_Decls, - Flag => Others_Flag, - Error_Loc => Sloc (Case_Guard), - Msg => Msg_Str); - end if; + Insert_After_And_Analyze (N, + Make_Pragma (Loc, + Chars => Name_Machine_Attribute, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Iloc, + Expression => New_Copy_Tree (Internal)), + Make_Pragma_Argument_Association (Eloc, + Expression => + Make_String_Literal (Sloc => Ploc, Strval => "common_object")), + Make_Pragma_Argument_Association (Ploc, + Expression => New_Copy_Tree (Psect))))); + end Expand_Pragma_Common_Object; - -- Inspect the consequence and perform special expansion of any - -- attribute 'Old and 'Result references found within. + ---------------------------------- + -- Expand_Pragma_Contract_Cases -- + ---------------------------------- - Expand_Attributes_In_Consequence - (Decls => Decls, - Evals => Old_Evals, - Flag => Others_Flag, - Conseq => Conseq); + -- Pragma Contract_Cases is expanded in the following manner: - -- Check the corresponding consequence of "others" + -- subprogram S is + -- Count : Natural := 0; + -- Flag_1 : Boolean := False; + -- . . . + -- Flag_N : Boolean := False; + -- Flag_N+1 : Boolean := False; -- when "others" present + -- Pref_1 : ...; + -- . . . + -- Pref_M : ...; - Consequence_Error - (Checks => Conseq_Checks, - Flag => Others_Flag, - Conseq => Conseq); + -- - -- Regular post case + -- -- Evaluate all case guards - else - -- Create the flag which tracks the state of its associated case - -- guard. + -- if Case_Guard_1 then + -- Flag_1 := True; + -- Count := Count + 1; + -- end if; + -- . . . + -- if Case_Guard_N then + -- Flag_N := True; + -- Count := Count + 1; + -- end if; - Flag := Make_Temporary (Loc, 'F'); - Flag_Decl := Declaration_Of (Flag); + -- -- Emit errors depending on the number of case guards that + -- -- evaluated to True. - Prepend_To (Decls, Flag_Decl); - Analyze (Flag_Decl); + -- if Count = 0 then + -- raise Assertion_Error with "xxx contract cases incomplete"; + -- + -- Flag_N+1 := True; -- when "others" present - -- The flag is set when the case guard is evaluated to True - -- if Case_Guard then - -- Flag := True; - -- Count := Count + 1; - -- end if; + -- elsif Count > 1 then + -- declare + -- Str0 : constant String := + -- "contract cases overlap for subprogram ABC"; + -- Str1 : constant String := + -- (if Flag_1 then + -- Str0 & "case guard at xxx evaluates to True" + -- else Str0); + -- StrN : constant String := + -- (if Flag_N then + -- StrN-1 & "case guard at xxx evaluates to True" + -- else StrN-1); + -- begin + -- raise Assertion_Error with StrN; + -- end; + -- end if; - If_Stmt := - Make_Implicit_If_Statement (CCs, - Condition => Relocate_Node (Case_Guard), - Then_Statements => New_List ( - Set (Flag), - Increment (Count))); + -- -- Evaluate all attribute 'Old prefixes found in the selected + -- -- consequence. - Append_To (Decls, If_Stmt); - Analyze (If_Stmt); + -- if Flag_1 then + -- Pref_1 := + -- . . . + -- elsif Flag_N then + -- Pref_M := + -- end if; - -- Check whether this case guard overlaps with another one + -- procedure _Postconditions is + -- begin + -- - if Multiple_PCs and Exception_Extra_Info then - Case_Guard_Error - (Decls => Error_Decls, - Flag => Flag, - Error_Loc => Sloc (Case_Guard), - Msg => Msg_Str); - end if; + -- if Flag_1 and then not Consequence_1 then + -- raise Assertion_Error with "failed contract case at xxx"; + -- end if; + -- . . . + -- if Flag_N[+1] and then not Consequence_N[+1] then + -- raise Assertion_Error with "failed contract case at xxx"; + -- end if; + -- end _Postconditions; + -- begin + -- . . . + -- end S; - -- Inspect the consequence and perform special expansion of any - -- attribute 'Old and 'Result references found within. + procedure Expand_Pragma_Contract_Cases + (CCs : Node_Id; + Subp_Id : Entity_Id; + Decls : List_Id; + Stmts : in out List_Id) + is + Loc : constant Source_Ptr := Sloc (CCs); - Expand_Attributes_In_Consequence - (Decls => Decls, - Evals => Old_Evals, - Flag => Flag, - Conseq => Conseq); + procedure Case_Guard_Error + (Decls : List_Id; + Flag : Entity_Id; + Error_Loc : Source_Ptr; + Msg : in out Entity_Id); + -- Given a declarative list Decls, status flag Flag, the location of the + -- error and a string Msg, construct the following check: + -- Msg : constant String := + -- (if Flag then + -- Msg & "case guard at Error_Loc evaluates to True" + -- else Msg); + -- The resulting code is added to Decls - -- The corresponding consequence of the case guard which evaluated - -- to True must hold on exit from the subprogram. + procedure Consequence_Error + (Checks : in out Node_Id; + Flag : Entity_Id; + Conseq : Node_Id); + -- Given an if statement Checks, status flag Flag and a consequence + -- Conseq, construct the following check: + -- [els]if Flag and then not Conseq then + -- raise Assertion_Error + -- with "failed contract case at Sloc (Conseq)"; + -- [end if;] + -- The resulting code is added to Checks - Consequence_Error - (Checks => Conseq_Checks, - Flag => Flag, - Conseq => Conseq); - end if; + function Declaration_Of (Id : Entity_Id) return Node_Id; + -- Given the entity Id of a boolean flag, generate: + -- Id : Boolean := False; - Next (Post_Case); - end loop; + procedure Expand_Attributes_In_Consequence + (Decls : List_Id; + Evals : in out Node_Id; + Flag : Entity_Id; + Conseq : Node_Id); + -- Perform specialized expansion of all attribute 'Old references found + -- in consequence Conseq such that at runtime only prefixes coming from + -- the selected consequence are evaluated. Similarly expand attribute + -- 'Result references by replacing them with identifier _result which + -- resolves to the sole formal parameter of procedure _Postconditions. + -- Any temporaries generated in the process are added to declarations + -- Decls. Evals is a complex if statement tasked with the evaluation of + -- all prefixes coming from a single selected consequence. Flag is the + -- corresponding case guard flag. Conseq is the consequence expression. - -- Raise Assertion_Error when none of the case guards evaluate to True. - -- The only exception is when we have "others", in which case there is - -- no error because "others" acts as a default True. + function Increment (Id : Entity_Id) return Node_Id; + -- Given the entity Id of a numerical variable, generate: + -- Id := Id + 1; - -- Generate: - -- Flag := True; + function Set (Id : Entity_Id) return Node_Id; + -- Given the entity Id of a boolean variable, generate: + -- Id := True; - if Present (Others_Flag) then - CG_Stmts := New_List (Set (Others_Flag)); + ---------------------- + -- Case_Guard_Error -- + ---------------------- - -- Generate: - -- raise Assertion_Error with "xxx contract cases incomplete"; + procedure Case_Guard_Error + (Decls : List_Id; + Flag : Entity_Id; + Error_Loc : Source_Ptr; + Msg : in out Entity_Id) + is + New_Line : constant Character := Character'Val (10); + New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); - else + begin Start_String; - Store_String_Chars (Build_Location_String (Loc)); - Store_String_Chars (" contract cases incomplete"); - - CG_Stmts := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, End_String)))); - end if; + Store_String_Char (New_Line); + Store_String_Chars (" case guard at "); + Store_String_Chars (Build_Location_String (Error_Loc)); + Store_String_Chars (" evaluates to True"); - CG_Checks := - Make_Implicit_If_Statement (CCs, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (Count, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 0)), - Then_Statements => CG_Stmts); + -- Generate: + -- New_Msg : constant String := + -- (if Flag then + -- Msg & "case guard at Error_Loc evaluates to True" + -- else Msg); - -- Detect a possible failure due to several case guards evaluating to - -- True. + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => New_Msg, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_If_Expression (Loc, + Expressions => New_List ( + New_Occurrence_Of (Flag, Loc), - -- Generate: - -- elsif Count > 0 then - -- declare - -- - -- begin - -- raise Assertion_Error with ; - -- end if; + Make_Op_Concat (Loc, + Left_Opnd => New_Occurrence_Of (Msg, Loc), + Right_Opnd => Make_String_Literal (Loc, End_String)), - if Multiple_PCs then - Set_Elsif_Parts (CG_Checks, New_List ( - Make_Elsif_Part (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => New_Occurrence_Of (Count, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1)), + New_Occurrence_Of (Msg, Loc))))); - Then_Statements => New_List ( - Make_Block_Statement (Loc, - Declarations => Error_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Msg_Str, Loc)))))))))); - end if; + Msg := New_Msg; + end Case_Guard_Error; - Append_To (Decls, CG_Checks); - Analyze (CG_Checks); + ----------------------- + -- Consequence_Error -- + ----------------------- - -- Once all case guards are evaluated and checked, evaluate any prefixes - -- of attribute 'Old founds in the selected consequence. + procedure Consequence_Error + (Checks : in out Node_Id; + Flag : Entity_Id; + Conseq : Node_Id) + is + Cond : Node_Id; + Error : Node_Id; - if Present (Old_Evals) then - Append_To (Decls, Old_Evals); - Analyze (Old_Evals); - end if; + begin + -- Generate: + -- Flag and then not Conseq - -- Raise Assertion_Error when the corresponding consequence of a case - -- guard that evaluated to True fails. + Cond := + Make_And_Then (Loc, + Left_Opnd => New_Occurrence_Of (Flag, Loc), + Right_Opnd => + Make_Op_Not (Loc, + Right_Opnd => Relocate_Node (Conseq))); - if No (Stmts) then - Stmts := New_List; - end if; + -- Generate: + -- raise Assertion_Error + -- with "failed contract case at Sloc (Conseq)"; - Append_To (Stmts, Conseq_Checks); - end Expand_Contract_Cases; + Start_String; + Store_String_Chars ("failed contract case at "); + Store_String_Chars (Build_Location_String (Sloc (Conseq))); - --------------------- - -- Expand_N_Pragma -- - --------------------- + Error := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, End_String))); - procedure Expand_N_Pragma (N : Node_Id) is - Pname : constant Name_Id := Pragma_Name (N); + if No (Checks) then + Checks := + Make_Implicit_If_Statement (CCs, + Condition => Cond, + Then_Statements => New_List (Error)); - begin - -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that/ - -- back end or the expander here does not get over-enthusiastic and - -- start processing such a pragma! + else + if No (Elsif_Parts (Checks)) then + Set_Elsif_Parts (Checks, New_List); + end if; - if Get_Name_Table_Boolean3 (Pname) then - Rewrite (N, Make_Null_Statement (Sloc (N))); - return; - end if; + Append_To (Elsif_Parts (Checks), + Make_Elsif_Part (Loc, + Condition => Cond, + Then_Statements => New_List (Error))); + end if; + end Consequence_Error; - -- Note: we may have a pragma whose Pragma_Identifier field is not a - -- recognized pragma, and we must ignore it at this stage. + -------------------- + -- Declaration_Of -- + -------------------- - if Is_Pragma_Name (Pname) then - case Get_Pragma_Id (Pname) is + function Declaration_Of (Id : Entity_Id) return Node_Id is + begin + return + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_False, Loc)); + end Declaration_Of; - -- Pragmas requiring special expander action + -------------------------------------- + -- Expand_Attributes_In_Consequence -- + -------------------------------------- - when Pragma_Abort_Defer => - Expand_Pragma_Abort_Defer (N); + procedure Expand_Attributes_In_Consequence + (Decls : List_Id; + Evals : in out Node_Id; + Flag : Entity_Id; + Conseq : Node_Id) + is + Eval_Stmts : List_Id := No_List; + -- The evaluation sequence expressed as assignment statements of all + -- prefixes of attribute 'Old found in the current consequence. - when Pragma_Check => - Expand_Pragma_Check (N); + function Expand_Attributes (N : Node_Id) return Traverse_Result; + -- Determine whether an arbitrary node denotes attribute 'Old or + -- 'Result and if it does, perform all expansion-related actions. - when Pragma_Common_Object => - Expand_Pragma_Common_Object (N); + ----------------------- + -- Expand_Attributes -- + ----------------------- - when Pragma_Import => - Expand_Pragma_Import_Or_Interface (N); + function Expand_Attributes (N : Node_Id) return Traverse_Result is + Decl : Node_Id; + Pref : Node_Id; + Temp : Entity_Id; - when Pragma_Inspection_Point => - Expand_Pragma_Inspection_Point (N); + begin + -- Attribute 'Old - when Pragma_Interface => - Expand_Pragma_Import_Or_Interface (N); + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Old + then + Pref := Prefix (N); + Temp := Make_Temporary (Loc, 'T', Pref); + Set_Etype (Temp, Etype (Pref)); - when Pragma_Interrupt_Priority => - Expand_Pragma_Interrupt_Priority (N); + -- Generate a temporary to capture the value of the prefix: + -- Temp : ; + -- Place that temporary at the beginning of declarations, to + -- prevent anomalies in the GNATprove flow-analysis pass in + -- the precondition procedure that follows. - when Pragma_Loop_Variant => - Expand_Pragma_Loop_Variant (N); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Etype (Pref), Loc)); + Set_No_Initialization (Decl); - when Pragma_Psect_Object => - Expand_Pragma_Psect_Object (N); + Prepend_To (Decls, Decl); + Analyze (Decl); - when Pragma_Relative_Deadline => - Expand_Pragma_Relative_Deadline (N); + -- Evaluate the prefix, generate: + -- Temp := ; - when Pragma_Suppress_Initialization => - Expand_Pragma_Suppress_Initialization (N); + if No (Eval_Stmts) then + Eval_Stmts := New_List; + end if; - -- All other pragmas need no expander action + Append_To (Eval_Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp, Loc), + Expression => Pref)); - when others => null; - end case; - end if; + -- Ensure that the prefix is valid - end Expand_N_Pragma; + if Validity_Checks_On and then Validity_Check_Operands then + Ensure_Valid (Pref); + end if; - ------------------------------- - -- Expand_Pragma_Abort_Defer -- - ------------------------------- + -- Replace the original attribute 'Old by a reference to the + -- generated temporary. - -- An Abort_Defer pragma appears as the first statement in a handled - -- statement sequence (right after the begin). It defers aborts for - -- the entire statement sequence, but not for any declarations or - -- handlers (if any) associated with this statement sequence. + Rewrite (N, New_Occurrence_Of (Temp, Loc)); - -- The transformation is to transform + -- Attribute 'Result - -- pragma Abort_Defer; - -- statements; + elsif Is_Attribute_Result (N) then + Rewrite (N, Make_Identifier (Loc, Name_uResult)); + end if; - -- into + return OK; + end Expand_Attributes; - -- begin - -- Abort_Defer.all; - -- statements - -- exception - -- when all others => - -- Abort_Undefer.all; - -- raise; - -- at end - -- Abort_Undefer_Direct; - -- end; + procedure Expand_Attributes_In is + new Traverse_Proc (Expand_Attributes); - procedure Expand_Pragma_Abort_Defer (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Stm : Node_Id; - Stms : List_Id; - HSS : Node_Id; - Blk : constant Entity_Id := - New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); - AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); + -- Start of processing for Expand_Attributes_In_Consequence - begin - Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); - loop - Stm := Remove_Next (N); - exit when No (Stm); - Append (Stm, Stms); - end loop; + begin + -- Inspect the consequence and expand any attribute 'Old and 'Result + -- references found within. - HSS := - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stms, - At_End_Proc => New_Occurrence_Of (AUD, Loc)); + Expand_Attributes_In (Conseq); - -- Present the Abort_Undefer_Direct function to the backend so that it - -- can inline the call to the function. + -- The consequence does not contain any attribute 'Old references - Add_Inlined_Body (AUD, N); + if No (Eval_Stmts) then + return; + end if; - Rewrite (N, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => HSS)); + -- Augment the machinery to trigger the evaluation of all prefixes + -- found in the step above. If Eval is empty, then this is the first + -- consequence to yield expansion of 'Old. Generate: - Set_Scope (Blk, Current_Scope); - Set_Etype (Blk, Standard_Void_Type); - Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); - Expand_At_End_Handler (HSS, Blk); - Analyze (N); - end Expand_Pragma_Abort_Defer; + -- if Flag then + -- + -- end if; - -------------------------- - -- Expand_Pragma_Check -- - -------------------------- + if No (Evals) then + Evals := + Make_Implicit_If_Statement (CCs, + Condition => New_Occurrence_Of (Flag, Loc), + Then_Statements => Eval_Stmts); - procedure Expand_Pragma_Check (N : Node_Id) is - Cond : constant Node_Id := Arg2 (N); - Nam : constant Name_Id := Chars (Arg1 (N)); - Msg : Node_Id; + -- Otherwise generate: + -- elsif Flag then + -- + -- end if; - Loc : constant Source_Ptr := Sloc (First_Node (Cond)); - -- Source location used in the case of a failed assertion: point to the - -- failing condition, not Loc. Note that the source location of the - -- expression is not usually the best choice here, because it points to - -- the location of the topmost tree node, which may be an operator in - -- the middle of the source text of the expression. For example, it gets - -- located on the last AND keyword in a chain of boolean expressiond - -- AND'ed together. It is best to put the message on the first character - -- of the condition, which is the effect of the First_Node call here. - -- This source location is used to build the default exception message, - -- and also as the sloc of the call to the runtime subprogram raising - -- Assert_Failure, so that coverage analysis tools can relate the - -- call to the failed check. + else + if No (Elsif_Parts (Evals)) then + Set_Elsif_Parts (Evals, New_List); + end if; - begin - -- Nothing to do if pragma is ignored + Append_To (Elsif_Parts (Evals), + Make_Elsif_Part (Loc, + Condition => New_Occurrence_Of (Flag, Loc), + Then_Statements => Eval_Stmts)); + end if; + end Expand_Attributes_In_Consequence; - if Is_Ignored (N) then - return; - end if; + --------------- + -- Increment -- + --------------- - -- Since this check is active, we rewrite the pragma into a - -- corresponding if statement, and then analyze the statement + function Increment (Id : Entity_Id) return Node_Id is + begin + return + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + end Increment; - -- The normal case expansion transforms: + --------- + -- Set -- + --------- - -- pragma Check (name, condition [,message]); + function Set (Id : Entity_Id) return Node_Id is + begin + return + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Id, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc)); + end Set; - -- into + -- Local variables - -- if not condition then - -- System.Assertions.Raise_Assert_Failure (Str); - -- end if; + Aggr : constant Node_Id := + Expression (First + (Pragma_Argument_Associations (CCs))); + Case_Guard : Node_Id; + CG_Checks : Node_Id; + CG_Stmts : List_Id; + Conseq : Node_Id; + Conseq_Checks : Node_Id := Empty; + Count : Entity_Id; + Count_Decl : Node_Id; + Error_Decls : List_Id; + Flag : Entity_Id; + Flag_Decl : Node_Id; + If_Stmt : Node_Id; + Msg_Str : Entity_Id; + Multiple_PCs : Boolean; + Old_Evals : Node_Id := Empty; + Others_Decl : Node_Id; + Others_Flag : Entity_Id := Empty; + Post_Case : Node_Id; - -- where Str is the message if one is present, or the default of - -- name failed at file:line if no message is given (the "name failed - -- at" is omitted for name = Assertion, since it is redundant, given - -- that the name of the exception is Assert_Failure.) + -- Start of processing for Expand_Pragma_Contract_Cases - -- Also, instead of "XXX failed at", we generate slightly - -- different messages for some of the contract assertions (see - -- code below for details). + begin + -- Do nothing if pragma is not enabled. If pragma is disabled, it has + -- already been rewritten as a Null statement. - -- An alternative expansion is used when the No_Exception_Propagation - -- restriction is active and there is a local Assert_Failure handler. - -- This is not a common combination of circumstances, but it occurs in - -- the context of Aunit and the zero footprint profile. In this case we - -- generate: + if Is_Ignored (CCs) then + return; - -- if not condition then - -- raise Assert_Failure; - -- end if; + -- Guard against malformed contract cases - -- This will then be transformed into a goto, and the local handler will - -- be able to handle the assert error (which would not be the case if a - -- call is made to the Raise_Assert_Failure procedure). + elsif Nkind (Aggr) /= N_Aggregate then + return; + end if; - -- We also generate the direct raise if the Suppress_Exception_Locations - -- is active, since we don't want to generate messages in this case. + Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1; - -- Note that the reason we do not always generate a direct raise is that - -- the form in which the procedure is called allows for more efficient - -- breakpointing of assertion errors. + -- Create the counter which tracks the number of case guards that + -- evaluate to True. - -- Generate the appropriate if statement. Note that we consider this to - -- be an explicit conditional in the source, not an implicit if, so we - -- do not call Make_Implicit_If_Statement. + -- Count : Natural := 0; - -- Case where we generate a direct raise + Count := Make_Temporary (Loc, 'C'); + Count_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Count, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc), + Expression => Make_Integer_Literal (Loc, 0)); - if ((Debug_Flag_Dot_G - or else Restriction_Active (No_Exception_Propagation)) - and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) - or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) - then - Rewrite (N, - Make_If_Statement (Loc, - Condition => Make_Op_Not (Loc, Right_Opnd => Cond), - Then_Statements => New_List ( - Make_Raise_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc))))); + Prepend_To (Decls, Count_Decl); + Analyze (Count_Decl); - -- Case where we call the procedure + -- Create the base error message for multiple overlapping case guards - else - -- If we have a message given, use it + -- Msg_Str : constant String := + -- "contract cases overlap for subprogram Subp_Id"; - if Present (Arg3 (N)) then - Msg := Get_Pragma_Arg (Arg3 (N)); + if Multiple_PCs then + Msg_Str := Make_Temporary (Loc, 'S'); - -- Here we have no string, so prepare one + Start_String; + Store_String_Chars ("contract cases overlap for subprogram "); + Store_String_Chars (Get_Name_String (Chars (Subp_Id))); - else - declare - Loc_Str : constant String := Build_Location_String (Loc); + Error_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Msg_Str, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => Make_String_Literal (Loc, End_String))); + end if; - begin - Name_Len := 0; + -- Process individual post cases - -- For Assert, we just use the location + Post_Case := First (Component_Associations (Aggr)); + while Present (Post_Case) loop + Case_Guard := First (Choices (Post_Case)); + Conseq := Expression (Post_Case); - if Nam = Name_Assert then - null; + -- The "others" choice requires special processing - -- For predicate, we generate the string "predicate failed - -- at yyy". We prefer all lower case for predicate. + if Nkind (Case_Guard) = N_Others_Choice then + Others_Flag := Make_Temporary (Loc, 'F'); + Others_Decl := Declaration_Of (Others_Flag); - elsif Nam = Name_Predicate then - Add_Str_To_Name_Buffer ("predicate failed at "); + Prepend_To (Decls, Others_Decl); + Analyze (Others_Decl); - -- For special case of Precondition/Postcondition the string is - -- "failed xx from yy" where xx is precondition/postcondition - -- in all lower case. The reason for this different wording is - -- that the failure is not at the point of occurrence of the - -- pragma, unlike the other Check cases. + -- Check possible overlap between a case guard and "others" - elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then - Get_Name_String (Nam); - Insert_Str_In_Name_Buffer ("failed ", 1); - Add_Str_To_Name_Buffer (" from "); + if Multiple_PCs and Exception_Extra_Info then + Case_Guard_Error + (Decls => Error_Decls, + Flag => Others_Flag, + Error_Loc => Sloc (Case_Guard), + Msg => Msg_Str); + end if; - -- For special case of Invariant, the string is "failed - -- invariant from yy", to be consistent with the string that is - -- generated for the aspect case (the code later on checks for - -- this specific string to modify it in some cases, so this is - -- functionally important). + -- Inspect the consequence and perform special expansion of any + -- attribute 'Old and 'Result references found within. - elsif Nam = Name_Invariant then - Add_Str_To_Name_Buffer ("failed invariant from "); + Expand_Attributes_In_Consequence + (Decls => Decls, + Evals => Old_Evals, + Flag => Others_Flag, + Conseq => Conseq); - -- For all other checks, the string is "xxx failed at yyy" - -- where xxx is the check name with current source file casing. + -- Check the corresponding consequence of "others" - else - Get_Name_String (Nam); - Set_Casing (Identifier_Casing (Current_Source_File)); - Add_Str_To_Name_Buffer (" failed at "); - end if; + Consequence_Error + (Checks => Conseq_Checks, + Flag => Others_Flag, + Conseq => Conseq); - -- In all cases, add location string + -- Regular post case - Add_Str_To_Name_Buffer (Loc_Str); + else + -- Create the flag which tracks the state of its associated case + -- guard. - -- Build the message + Flag := Make_Temporary (Loc, 'F'); + Flag_Decl := Declaration_Of (Flag); - Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); - end; - end if; + Prepend_To (Decls, Flag_Decl); + Analyze (Flag_Decl); - -- Now rewrite as an if statement + -- The flag is set when the case guard is evaluated to True + -- if Case_Guard then + -- Flag := True; + -- Count := Count + 1; + -- end if; - Rewrite (N, - Make_If_Statement (Loc, - Condition => Make_Op_Not (Loc, Right_Opnd => Cond), - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List (Relocate_Node (Msg)))))); - end if; + If_Stmt := + Make_Implicit_If_Statement (CCs, + Condition => Relocate_Node (Case_Guard), + Then_Statements => New_List ( + Set (Flag), + Increment (Count))); - Analyze (N); + Append_To (Decls, If_Stmt); + Analyze (If_Stmt); - -- If new condition is always false, give a warning + -- Check whether this case guard overlaps with another one - if Warn_On_Assertion_Failure - and then Nkind (N) = N_Procedure_Call_Statement - and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) - then - -- If original condition was a Standard.False, we assume that this is - -- indeed intended to raise assert error and no warning is required. + if Multiple_PCs and Exception_Extra_Info then + Case_Guard_Error + (Decls => Error_Decls, + Flag => Flag, + Error_Loc => Sloc (Case_Guard), + Msg => Msg_Str); + end if; - if Is_Entity_Name (Original_Node (Cond)) - and then Entity (Original_Node (Cond)) = Standard_False - then - return; + -- Inspect the consequence and perform special expansion of any + -- attribute 'Old and 'Result references found within. - elsif Nam = Name_Assert then - Error_Msg_N ("?A?assertion will fail at run time", N); - else + Expand_Attributes_In_Consequence + (Decls => Decls, + Evals => Old_Evals, + Flag => Flag, + Conseq => Conseq); - Error_Msg_N ("?A?check will fail at run time", N); + -- The corresponding consequence of the case guard which evaluated + -- to True must hold on exit from the subprogram. + + Consequence_Error + (Checks => Conseq_Checks, + Flag => Flag, + Conseq => Conseq); end if; - end if; - end Expand_Pragma_Check; - --------------------------------- - -- Expand_Pragma_Common_Object -- - --------------------------------- + Next (Post_Case); + end loop; - -- Use a machine attribute to replicate semantic effect in DEC Ada + -- Raise Assertion_Error when none of the case guards evaluate to True. + -- The only exception is when we have "others", in which case there is + -- no error because "others" acts as a default True. - -- pragma Machine_Attribute (intern_name, "common_object", extern_name); + -- Generate: + -- Flag := True; - -- For now we do nothing with the size attribute ??? + if Present (Others_Flag) then + CG_Stmts := New_List (Set (Others_Flag)); - -- Note: Psect_Object shares this processing + -- Generate: + -- raise Assertion_Error with "xxx contract cases incomplete"; - procedure Expand_Pragma_Common_Object (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + else + Start_String; + Store_String_Chars (Build_Location_String (Loc)); + Store_String_Chars (" contract cases incomplete"); - Internal : constant Node_Id := Arg1 (N); - External : constant Node_Id := Arg2 (N); + CG_Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, End_String)))); + end if; - Psect : Node_Id; - -- Psect value upper cased as string literal + CG_Checks := + Make_Implicit_If_Statement (CCs, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Count, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Then_Statements => CG_Stmts); - Iloc : constant Source_Ptr := Sloc (Internal); - Eloc : constant Source_Ptr := Sloc (External); - Ploc : Source_Ptr; + -- Detect a possible failure due to several case guards evaluating to + -- True. - begin - -- Acquire Psect value and fold to upper case + -- Generate: + -- elsif Count > 0 then + -- declare + -- + -- begin + -- raise Assertion_Error with ; + -- end if; - if Present (External) then - if Nkind (External) = N_String_Literal then - String_To_Name_Buffer (Strval (External)); - else - Get_Name_String (Chars (External)); - end if; + if Multiple_PCs then + Set_Elsif_Parts (CG_Checks, New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => New_Occurrence_Of (Count, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)), - Set_All_Upper_Case; + Then_Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Error_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Msg_Str, Loc)))))))))); + end if; - Psect := - Make_String_Literal (Eloc, Strval => String_From_Name_Buffer); + Append_To (Decls, CG_Checks); + Analyze (CG_Checks); - else - Get_Name_String (Chars (Internal)); - Set_All_Upper_Case; - Psect := - Make_String_Literal (Iloc, Strval => String_From_Name_Buffer); + -- Once all case guards are evaluated and checked, evaluate any prefixes + -- of attribute 'Old founds in the selected consequence. + + if Present (Old_Evals) then + Append_To (Decls, Old_Evals); + Analyze (Old_Evals); end if; - Ploc := Sloc (Psect); + -- Raise Assertion_Error when the corresponding consequence of a case + -- guard that evaluated to True fails. - -- Insert the pragma + if No (Stmts) then + Stmts := New_List; + end if; - Insert_After_And_Analyze (N, - Make_Pragma (Loc, - Chars => Name_Machine_Attribute, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Iloc, - Expression => New_Copy_Tree (Internal)), - Make_Pragma_Argument_Association (Eloc, - Expression => - Make_String_Literal (Sloc => Ploc, Strval => "common_object")), - Make_Pragma_Argument_Association (Ploc, - Expression => New_Copy_Tree (Psect))))); - end Expand_Pragma_Common_Object; + Append_To (Stmts, Conseq_Checks); + end Expand_Pragma_Contract_Cases; --------------------------------------- -- Expand_Pragma_Import_Or_Interface -- --------------------------------------- procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is - Def_Id : Entity_Id; + Def_Id : Entity_Id; begin -- In Relaxed_RM_Semantics, support old Ada 83 style: @@ -1391,7 +1391,6 @@ package body Exp_Prag is Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_Initial_Condition)), - Make_Pragma_Argument_Association (Loc, Expression => New_Copy_Tree (Expr)))); @@ -1450,7 +1449,6 @@ package body Exp_Prag is -- Are there other pragmas that may require this ??? Assoc := First (Pragma_Argument_Associations (N)); - while Present (Assoc) loop Expand (Expression (Assoc)); Next (Assoc); @@ -1465,14 +1463,13 @@ package body Exp_Prag is procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - begin if No (Pragma_Argument_Associations (N)) then Set_Pragma_Argument_Associations (N, New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc), Attribute_Name => Name_Last)))); end if; @@ -1531,10 +1528,10 @@ package body Exp_Prag is Last_Var : constant Node_Id := Last (Pragma_Argument_Associations (N)); - Curr_Assign : List_Id := No_List; - Flag_Id : Entity_Id := Empty; - If_Stmt : Node_Id := Empty; - Old_Assign : List_Id := No_List; + Curr_Assign : List_Id := No_List; + Flag_Id : Entity_Id := Empty; + If_Stmt : Node_Id := Empty; + Old_Assign : List_Id := No_List; Loop_Scop : Entity_Id; Loop_Stmt : Node_Id; Variant : Node_Id; @@ -1857,8 +1854,9 @@ package body Exp_Prag is Left_Opnd => Make_Function_Call (Loc, New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), - New_List (Make_Function_Call (Loc, - New_Occurrence_Of (RTE (RE_Clock), Loc)))), + New_List + (Make_Function_Call + (Loc, New_Occurrence_Of (RTE (RE_Clock), Loc)))), Right_Opnd => Unchecked_Convert_To (Standard_Duration, Arg1 (N))))))); diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads index d1ddfea177e..48d1c2f6b54 100644 --- a/gcc/ada/exp_prag.ads +++ b/gcc/ada/exp_prag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -31,7 +31,7 @@ package Exp_Prag is procedure Expand_N_Pragma (N : Node_Id); - procedure Expand_Contract_Cases + procedure Expand_Pragma_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id; Decls : List_Id; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 29153d7a67b..f7dadef5701 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8045,13 +8045,10 @@ package body Sem_Ch13 is end; end if; - -- Get name to be used for Check pragma + -- Get name to be used for Check pragma. Using the original + -- name ensures that 'Class case is properly handled. - if not From_Aspect_Specification (Ritem) then - Nam := Name_Invariant; - else - Nam := Chars (Identifier (Corresponding_Aspect (Ritem))); - end if; + Nam := Original_Aspect_Pragma_Name (Ritem); -- Build first two arguments for Check pragma -- 2.30.2