Skip to content

R
riscv-gcc-1
Commit b9eb3aa8 by Hristian Kirtchev Committed by Arnaud Charlet
Options

exp_ch6.adb (Process_Contract_Cases_For): Update the call to Expand_Pragma_Contract_Cases. 

2015-05-26  Hristian Kirtchev  <kirtchev@adacore.com>

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