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 843 additions and 838 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
...@@ -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,1074 +156,1074 @@ package body Exp_Prag is ...@@ -156,1074 +156,1074 @@ 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: procedure Expand_N_Pragma (N : Node_Id) is
Pname : constant Name_Id := Pragma_Name (N);
-- subprogram S is begin
-- Count : Natural := 0; -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that
-- Flag_1 : Boolean := False; -- the back end or the expander here does not get over-enthusiastic and
-- . . . -- start processing such a pragma!
-- Flag_N : Boolean := False;
-- Flag_N+1 : Boolean := False; -- when "others" present
-- Pref_1 : ...;
-- . . .
-- Pref_M : ...;
-- <preconditions (if any)> if Get_Name_Table_Boolean3 (Pname) then
Rewrite (N, Make_Null_Statement (Sloc (N)));
return;
end if;
-- -- Evaluate all case guards -- Note: we may have a pragma whose Pragma_Identifier field is not a
-- recognized pragma, and we must ignore it at this stage.
-- if Case_Guard_1 then if Is_Pragma_Name (Pname) then
-- Flag_1 := True; case Get_Pragma_Id (Pname) is
-- 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 -- Pragmas requiring special expander action
-- -- evaluated to True.
-- if Count = 0 then when Pragma_Abort_Defer =>
-- raise Assertion_Error with "xxx contract cases incomplete"; Expand_Pragma_Abort_Defer (N);
-- <or>
-- Flag_N+1 := True; -- when "others" present
-- elsif Count > 1 then when Pragma_Check =>
-- declare Expand_Pragma_Check (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_Common_Object =>
-- -- consequence. Expand_Pragma_Common_Object (N);
-- if Flag_1 then when Pragma_Import =>
-- Pref_1 := <prefix of 'Old found in Consequence_1> Expand_Pragma_Import_Or_Interface (N);
-- . . .
-- elsif Flag_N then
-- Pref_M := <prefix of 'Old found in Consequence_N>
-- end if;
-- procedure _Postconditions is when Pragma_Inspection_Point =>
-- begin Expand_Pragma_Inspection_Point (N);
-- <postconditions (if any)>
-- if Flag_1 and then not Consequence_1 then when Pragma_Interface =>
-- raise Assertion_Error with "failed contract case at xxx"; Expand_Pragma_Import_Or_Interface (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_Interrupt_Priority =>
(CCs : Node_Id; Expand_Pragma_Interrupt_Priority (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_Loop_Variant =>
(Decls : List_Id; Expand_Pragma_Loop_Variant (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_Psect_Object =>
(Checks : in out Node_Id; Expand_Pragma_Psect_Object (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_Relative_Deadline =>
-- Given the entity Id of a boolean flag, generate: Expand_Pragma_Relative_Deadline (N);
-- Id : Boolean := False;
procedure Expand_Attributes_In_Consequence when Pragma_Suppress_Initialization =>
(Decls : List_Id; Expand_Pragma_Suppress_Initialization (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; -- All other pragmas need no expander action
-- Given the entity Id of a numerical variable, generate:
-- Id := Id + 1;
function Set (Id : Entity_Id) return Node_Id; when others => null;
-- Given the entity Id of a boolean variable, generate: end case;
-- Id := True; end if;
---------------------- end Expand_N_Pragma;
-- Case_Guard_Error --
----------------------
procedure Case_Guard_Error -------------------------------
(Decls : List_Id; -- Expand_Pragma_Abort_Defer --
Flag : Entity_Id; -------------------------------
Error_Loc : Source_Ptr;
Msg : in out Entity_Id) -- An Abort_Defer pragma appears as the first statement in a handled
is -- statement sequence (right after the begin). It defers aborts for
New_Line : constant Character := Character'Val (10); -- the entire statement sequence, but not for any declarations or
New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); -- handlers (if any) associated with this statement sequence.
-- The transformation is to transform
-- pragma Abort_Defer;
-- statements;
-- into
-- begin
-- 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
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
Start_String; Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
Store_String_Char (New_Line); loop
Store_String_Chars (" case guard at "); Stm := Remove_Next (N);
Store_String_Chars (Build_Location_String (Error_Loc)); exit when No (Stm);
Store_String_Chars (" evaluates to True"); Append (Stm, Stms);
end loop;
-- Generate: HSS :=
-- New_Msg : constant String := Make_Handled_Sequence_Of_Statements (Loc,
-- (if Flag then Statements => Stms,
-- Msg & "case guard at Error_Loc evaluates to True" At_End_Proc => New_Occurrence_Of (AUD, Loc));
-- else Msg);
Append_To (Decls, -- Present the Abort_Undefer_Direct function to the backend so that it
Make_Object_Declaration (Loc, -- can inline the call to the function.
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, Add_Inlined_Body (AUD, N);
Left_Opnd => New_Occurrence_Of (Msg, Loc),
Right_Opnd => Make_String_Literal (Loc, End_String)),
New_Occurrence_Of (Msg, Loc))))); Rewrite (N,
Make_Block_Statement (Loc,
Handled_Statement_Sequence => HSS));
Msg := New_Msg; Set_Scope (Blk, Current_Scope);
end Case_Guard_Error; 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;
----------------------- --------------------------
-- Consequence_Error -- -- Expand_Pragma_Check --
----------------------- --------------------------
procedure Consequence_Error procedure Expand_Pragma_Check (N : Node_Id) is
(Checks : in out Node_Id; Cond : constant Node_Id := Arg2 (N);
Flag : Entity_Id; Nam : constant Name_Id := Chars (Arg1 (N));
Conseq : Node_Id) Msg : Node_Id;
is
Cond : Node_Id; Loc : constant Source_Ptr := Sloc (First_Node (Cond));
Error : Node_Id; -- 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.
begin begin
-- Generate: -- Nothing to do if pragma is ignored
-- Flag and then not Conseq
Cond := if Is_Ignored (N) then
Make_And_Then (Loc, return;
Left_Opnd => New_Occurrence_Of (Flag, Loc), end if;
Right_Opnd =>
Make_Op_Not (Loc,
Right_Opnd => Relocate_Node (Conseq)));
-- Generate: -- Since this check is active, we rewrite the pragma into a
-- raise Assertion_Error -- corresponding if statement, and then analyze the statement
-- with "failed contract case at Sloc (Conseq)";
Start_String; -- The normal case expansion transforms:
Store_String_Chars ("failed contract case at ");
Store_String_Chars (Build_Location_String (Sloc (Conseq)));
Error := -- pragma Check (name, condition [,message]);
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)));
if No (Checks) then -- into
Checks :=
Make_Implicit_If_Statement (CCs,
Condition => Cond,
Then_Statements => New_List (Error));
else -- if not condition then
if No (Elsif_Parts (Checks)) then -- System.Assertions.Raise_Assert_Failure (Str);
Set_Elsif_Parts (Checks, New_List); -- end if;
end if;
Append_To (Elsif_Parts (Checks), -- where Str is the message if one is present, or the default of
Make_Elsif_Part (Loc, -- name failed at file:line if no message is given (the "name failed
Condition => Cond, -- at" is omitted for name = Assertion, since it is redundant, given
Then_Statements => New_List (Error))); -- that the name of the exception is Assert_Failure.)
end if;
end Consequence_Error; -- Also, instead of "XXX failed at", we generate slightly
-- different messages for some of the contract assertions (see
-- code below for details).
-- 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 not condition then
-- raise Assert_Failure;
-- end if;
-- 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).
-------------------- -- We also generate the direct raise if the Suppress_Exception_Locations
-- Declaration_Of -- -- is active, since we don't want to generate messages in this case.
--------------------
function Declaration_Of (Id : Entity_Id) return Node_Id is -- Note that the reason we do not always generate a direct raise is that
begin -- the form in which the procedure is called allows for more efficient
return -- breakpointing of assertion errors.
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;
-------------------------------------- -- Generate the appropriate if statement. Note that we consider this to
-- Expand_Attributes_In_Consequence -- -- be an explicit conditional in the source, not an implicit if, so we
-------------------------------------- -- do not call Make_Implicit_If_Statement.
procedure Expand_Attributes_In_Consequence -- Case where we generate a direct raise
(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; if ((Debug_Flag_Dot_G
-- Determine whether an arbitrary node denotes attribute 'Old or or else Restriction_Active (No_Exception_Propagation))
-- 'Result and if it does, perform all expansion-related actions. 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
-- Expand_Attributes --
-----------------------
function Expand_Attributes (N : Node_Id) return Traverse_Result is else
Decl : Node_Id; -- If we have a message given, use it
Pref : Node_Id;
Temp : Entity_Id;
begin if Present (Arg3 (N)) then
-- Attribute 'Old Msg := Get_Pragma_Arg (Arg3 (N));
if Nkind (N) = N_Attribute_Reference -- Here we have no string, so prepare one
and then Attribute_Name (N) = Name_Old
then
Pref := Prefix (N);
Temp := Make_Temporary (Loc, 'T', Pref);
Set_Etype (Temp, Etype (Pref));
-- Generate a temporary to capture the value of the prefix: else
-- Temp : <Pref type>; declare
-- Place that temporary at the beginning of declarations, to Loc_Str : constant String := Build_Location_String (Loc);
-- prevent anomalies in the GNATprove flow-analysis pass in
-- the precondition procedure that follows.
Decl := begin
Make_Object_Declaration (Loc, Name_Len := 0;
Defining_Identifier => Temp,
Object_Definition =>
New_Occurrence_Of (Etype (Pref), Loc));
Set_No_Initialization (Decl);
Prepend_To (Decls, Decl); -- For Assert, we just use the location
Analyze (Decl);
-- Evaluate the prefix, generate: if Nam = Name_Assert then
-- Temp := <Pref>; null;
if No (Eval_Stmts) then -- For predicate, we generate the string "predicate failed at
Eval_Stmts := New_List; -- yyy". We prefer all lower case for predicate.
end if;
Append_To (Eval_Stmts, elsif Nam = Name_Predicate then
Make_Assignment_Statement (Loc, Add_Str_To_Name_Buffer ("predicate failed at ");
Name => New_Occurrence_Of (Temp, Loc),
Expression => Pref));
-- Ensure that the prefix is valid -- 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.
if Validity_Checks_On and then Validity_Check_Operands then elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then
Ensure_Valid (Pref); Get_Name_String (Nam);
end if; Insert_Str_In_Name_Buffer ("failed ", 1);
Add_Str_To_Name_Buffer (" from ");
-- Replace the original attribute 'Old by a reference to the -- For special case of Invariant, the string is "failed
-- generated temporary. -- 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).
Rewrite (N, New_Occurrence_Of (Temp, Loc)); elsif Nam = Name_Invariant then
Add_Str_To_Name_Buffer ("failed invariant from ");
-- Attribute 'Result -- For all other checks, the string is "xxx failed at yyy"
-- where xxx is the check name with current source file casing.
elsif Is_Attribute_Result (N) then else
Rewrite (N, Make_Identifier (Loc, Name_uResult)); Get_Name_String (Nam);
Set_Casing (Identifier_Casing (Current_Source_File));
Add_Str_To_Name_Buffer (" failed at ");
end if; end if;
return OK; -- In all cases, add location string
end Expand_Attributes;
procedure Expand_Attributes_In is
new Traverse_Proc (Expand_Attributes);
-- Start of processing for Expand_Attributes_In_Consequence Add_Str_To_Name_Buffer (Loc_Str);
begin -- Build the message
-- Inspect the consequence and expand any attribute 'Old and 'Result
-- references found within.
Expand_Attributes_In (Conseq); Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
end;
end if;
-- The consequence does not contain any attribute 'Old references -- Now rewrite as an if statement
if No (Eval_Stmts) then Rewrite (N,
return; 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; end if;
-- Augment the machinery to trigger the evaluation of all prefixes Analyze (N);
-- found in the step above. If Eval is empty, then this is the first
-- consequence to yield expansion of 'Old. Generate:
-- if Flag then -- If new condition is always false, give a warning
-- <evaluation statements>
-- end if;
if No (Evals) then if Warn_On_Assertion_Failure
Evals := and then Nkind (N) = N_Procedure_Call_Statement
Make_Implicit_If_Statement (CCs, and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
Condition => New_Occurrence_Of (Flag, Loc), then
Then_Statements => Eval_Stmts); -- If original condition was a Standard.False, we assume that this is
-- indeed intended to raise assert error and no warning is required.
-- Otherwise generate: if Is_Entity_Name (Original_Node (Cond))
-- elsif Flag then and then Entity (Original_Node (Cond)) = Standard_False
-- <evaluation statements> then
-- end if; return;
elsif Nam = Name_Assert then
Error_Msg_N ("?A?assertion will fail at run time", N);
else else
if No (Elsif_Parts (Evals)) then
Set_Elsif_Parts (Evals, New_List);
end if;
Append_To (Elsif_Parts (Evals), Error_Msg_N ("?A?check will fail at run time", N);
Make_Elsif_Part (Loc,
Condition => New_Occurrence_Of (Flag, Loc),
Then_Statements => Eval_Stmts));
end if; end if;
end Expand_Attributes_In_Consequence; end if;
end Expand_Pragma_Check;
--------------- ---------------------------------
-- Increment -- -- Expand_Pragma_Common_Object --
--------------- ---------------------------------
function Increment (Id : Entity_Id) return Node_Id is -- Use a machine attribute to replicate semantic effect in DEC Ada
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;
--------- -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
-- Set --
---------
function Set (Id : Entity_Id) return Node_Id is -- For now we do nothing with the size attribute ???
begin
return
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Id, Loc),
Expression => New_Occurrence_Of (Standard_True, Loc));
end Set;
-- Local variables -- Note: Psect_Object shares this processing
Aggr : constant Node_Id := procedure Expand_Pragma_Common_Object (N : Node_Id) is
Expression (First Loc : constant Source_Ptr := Sloc (N);
(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 Internal : constant Node_Id := Arg1 (N);
External : constant Node_Id := Arg2 (N);
begin Psect : Node_Id;
-- Do nothing if pragma is not enabled. If pragma is disabled, it has -- Psect value upper cased as string literal
-- already been rewritten as a Null statement.
if Is_Ignored (CCs) then Iloc : constant Source_Ptr := Sloc (Internal);
return; Eloc : constant Source_Ptr := Sloc (External);
Ploc : Source_Ptr;
-- Guard against malformed contract cases begin
-- Acquire Psect value and fold to upper case
elsif Nkind (Aggr) /= N_Aggregate then if Present (External) then
return; if Nkind (External) = N_String_Literal then
String_To_Name_Buffer (Strval (External));
else
Get_Name_String (Chars (External));
end if; end if;
Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1; Set_All_Upper_Case;
-- Create the counter which tracks the number of case guards that Psect :=
-- evaluate to True. Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
-- Count : Natural := 0; else
Get_Name_String (Chars (Internal));
Set_All_Upper_Case;
Psect :=
Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
end if;
Count := Make_Temporary (Loc, 'C'); Ploc := Sloc (Psect);
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); -- Insert the pragma
Analyze (Count_Decl);
-- Create the base error message for multiple overlapping case guards 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;
-- Msg_Str : constant String := ----------------------------------
-- "contract cases overlap for subprogram Subp_Id"; -- Expand_Pragma_Contract_Cases --
----------------------------------
if Multiple_PCs then -- Pragma Contract_Cases is expanded in the following manner:
Msg_Str := Make_Temporary (Loc, 'S');
Start_String; -- subprogram S is
Store_String_Chars ("contract cases overlap for subprogram "); -- Count : Natural := 0;
Store_String_Chars (Get_Name_String (Chars (Subp_Id))); -- Flag_1 : Boolean := False;
-- . . .
-- Flag_N : Boolean := False;
-- Flag_N+1 : Boolean := False; -- when "others" present
-- Pref_1 : ...;
-- . . .
-- Pref_M : ...;
Error_Decls := New_List ( -- <preconditions (if any)>
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;
-- Process individual post cases -- -- Evaluate all case guards
Post_Case := First (Component_Associations (Aggr)); -- if Case_Guard_1 then
while Present (Post_Case) loop -- Flag_1 := True;
Case_Guard := First (Choices (Post_Case)); -- Count := Count + 1;
Conseq := Expression (Post_Case); -- end if;
-- . . .
-- if Case_Guard_N then
-- Flag_N := True;
-- Count := Count + 1;
-- end if;
-- The "others" choice requires special processing -- -- Emit errors depending on the number of case guards that
-- -- evaluated to True.
if Nkind (Case_Guard) = N_Others_Choice then -- if Count = 0 then
Others_Flag := Make_Temporary (Loc, 'F'); -- raise Assertion_Error with "xxx contract cases incomplete";
Others_Decl := Declaration_Of (Others_Flag); -- <or>
-- Flag_N+1 := True; -- when "others" present
Prepend_To (Decls, Others_Decl); -- elsif Count > 1 then
Analyze (Others_Decl); -- 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;
-- Check possible overlap between a case guard and "others" -- -- Evaluate all attribute 'Old prefixes found in the selected
-- -- consequence.
if Multiple_PCs and Exception_Extra_Info then -- if Flag_1 then
Case_Guard_Error -- Pref_1 := <prefix of 'Old found in Consequence_1>
(Decls => Error_Decls, -- . . .
Flag => Others_Flag, -- elsif Flag_N then
Error_Loc => Sloc (Case_Guard), -- Pref_M := <prefix of 'Old found in Consequence_N>
Msg => Msg_Str); -- end if;
end if;
-- Inspect the consequence and perform special expansion of any -- procedure _Postconditions is
-- attribute 'Old and 'Result references found within. -- begin
-- <postconditions (if any)>
Expand_Attributes_In_Consequence -- if Flag_1 and then not Consequence_1 then
(Decls => Decls, -- raise Assertion_Error with "failed contract case at xxx";
Evals => Old_Evals, -- end if;
Flag => Others_Flag, -- . . .
Conseq => Conseq); -- 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;
-- Check the corresponding consequence of "others" 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);
Consequence_Error procedure Case_Guard_Error
(Checks => Conseq_Checks, (Decls : List_Id;
Flag => Others_Flag, Flag : Entity_Id;
Conseq => Conseq); 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
-- Regular post case 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
else function Declaration_Of (Id : Entity_Id) return Node_Id;
-- Create the flag which tracks the state of its associated case -- Given the entity Id of a boolean flag, generate:
-- guard. -- Id : Boolean := False;
Flag := Make_Temporary (Loc, 'F'); procedure Expand_Attributes_In_Consequence
Flag_Decl := Declaration_Of (Flag); (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.
Prepend_To (Decls, Flag_Decl); function Increment (Id : Entity_Id) return Node_Id;
Analyze (Flag_Decl); -- Given the entity Id of a numerical variable, generate:
-- Id := Id + 1;
-- The flag is set when the case guard is evaluated to True function Set (Id : Entity_Id) return Node_Id;
-- if Case_Guard then -- Given the entity Id of a boolean variable, generate:
-- Flag := True; -- Id := True;
-- Count := Count + 1;
-- end if;
If_Stmt := ----------------------
Make_Implicit_If_Statement (CCs, -- Case_Guard_Error --
Condition => Relocate_Node (Case_Guard), ----------------------
Then_Statements => New_List (
Set (Flag),
Increment (Count)));
Append_To (Decls, If_Stmt); procedure Case_Guard_Error
Analyze (If_Stmt); (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');
-- Check whether this case guard overlaps with another one 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");
if Multiple_PCs and Exception_Extra_Info then -- Generate:
Case_Guard_Error -- New_Msg : constant String :=
(Decls => Error_Decls, -- (if Flag then
Flag => Flag, -- Msg & "case guard at Error_Loc evaluates to True"
Error_Loc => Sloc (Case_Guard), -- else Msg);
Msg => Msg_Str);
end if;
-- Inspect the consequence and perform special expansion of any Append_To (Decls,
-- attribute 'Old and 'Result references found within. 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),
Expand_Attributes_In_Consequence Make_Op_Concat (Loc,
(Decls => Decls, Left_Opnd => New_Occurrence_Of (Msg, Loc),
Evals => Old_Evals, Right_Opnd => Make_String_Literal (Loc, End_String)),
Flag => Flag,
Conseq => Conseq);
-- The corresponding consequence of the case guard which evaluated New_Occurrence_Of (Msg, Loc)))));
-- to True must hold on exit from the subprogram.
Consequence_Error Msg := New_Msg;
(Checks => Conseq_Checks, end Case_Guard_Error;
Flag => Flag,
Conseq => Conseq);
end if;
Next (Post_Case); -----------------------
end loop; -- Consequence_Error --
-----------------------
-- Raise Assertion_Error when none of the case guards evaluate to True. procedure Consequence_Error
-- The only exception is when we have "others", in which case there is (Checks : in out Node_Id;
-- no error because "others" acts as a default True. Flag : Entity_Id;
Conseq : Node_Id)
is
Cond : Node_Id;
Error : Node_Id;
begin
-- Generate: -- Generate:
-- Flag := True; -- Flag and then not Conseq
if Present (Others_Flag) then Cond :=
CG_Stmts := New_List (Set (Others_Flag)); Make_And_Then (Loc,
Left_Opnd => New_Occurrence_Of (Flag, Loc),
Right_Opnd =>
Make_Op_Not (Loc,
Right_Opnd => Relocate_Node (Conseq)));
-- Generate: -- Generate:
-- raise Assertion_Error with "xxx contract cases incomplete"; -- raise Assertion_Error
-- with "failed contract case at Sloc (Conseq)";
else
Start_String; Start_String;
Store_String_Chars (Build_Location_String (Loc)); Store_String_Chars ("failed contract case at ");
Store_String_Chars (" contract cases incomplete"); Store_String_Chars (Build_Location_String (Sloc (Conseq)));
CG_Stmts := New_List ( Error :=
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name =>
New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_String_Literal (Loc, End_String)))); Make_String_Literal (Loc, End_String)));
end if;
CG_Checks := if No (Checks) then
Checks :=
Make_Implicit_If_Statement (CCs, Make_Implicit_If_Statement (CCs,
Condition => Condition => Cond,
Make_Op_Eq (Loc, Then_Statements => New_List (Error));
Left_Opnd => New_Occurrence_Of (Count, Loc),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Then_Statements => CG_Stmts);
-- Detect a possible failure due to several case guards evaluating to
-- True.
-- Generate:
-- elsif Count > 0 then
-- declare
-- <Error_Decls>
-- begin
-- raise Assertion_Error with <Msg_Str>;
-- 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)),
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;
Append_To (Decls, CG_Checks);
Analyze (CG_Checks);
-- Once all case guards are evaluated and checked, evaluate any prefixes
-- of attribute 'Old founds in the selected consequence.
if Present (Old_Evals) then else
Append_To (Decls, Old_Evals); if No (Elsif_Parts (Checks)) then
Analyze (Old_Evals); Set_Elsif_Parts (Checks, New_List);
end if; end if;
-- Raise Assertion_Error when the corresponding consequence of a case Append_To (Elsif_Parts (Checks),
-- guard that evaluated to True fails. Make_Elsif_Part (Loc,
Condition => Cond,
if No (Stmts) then Then_Statements => New_List (Error)));
Stmts := New_List;
end if; end if;
end Consequence_Error;
Append_To (Stmts, Conseq_Checks); --------------------
end Expand_Contract_Cases; -- Declaration_Of --
--------------------
---------------------
-- Expand_N_Pragma --
---------------------
procedure Expand_N_Pragma (N : Node_Id) is
Pname : constant Name_Id := Pragma_Name (N);
function Declaration_Of (Id : Entity_Id) return Node_Id is
begin begin
-- Rewrite pragma ignored by Ignore_Pragma to null statement, so that/ return
-- back end or the expander here does not get over-enthusiastic and Make_Object_Declaration (Loc,
-- start processing such a pragma! Defining_Identifier => Id,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
if Get_Name_Table_Boolean3 (Pname) then Expression => New_Occurrence_Of (Standard_False, Loc));
Rewrite (N, Make_Null_Statement (Sloc (N))); end Declaration_Of;
return;
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.
if Is_Pragma_Name (Pname) then --------------------------------------
case Get_Pragma_Id (Pname) is -- Expand_Attributes_In_Consequence --
--------------------------------------
-- Pragmas requiring special expander action 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_Abort_Defer => function Expand_Attributes (N : Node_Id) return Traverse_Result;
Expand_Pragma_Abort_Defer (N); -- Determine whether an arbitrary node denotes attribute 'Old or
-- 'Result and if it does, perform all expansion-related actions.
when Pragma_Check => -----------------------
Expand_Pragma_Check (N); -- Expand_Attributes --
-----------------------
when Pragma_Common_Object => function Expand_Attributes (N : Node_Id) return Traverse_Result is
Expand_Pragma_Common_Object (N); Decl : Node_Id;
Pref : Node_Id;
Temp : Entity_Id;
when Pragma_Import => begin
Expand_Pragma_Import_Or_Interface (N); -- Attribute 'Old
when Pragma_Inspection_Point => if Nkind (N) = N_Attribute_Reference
Expand_Pragma_Inspection_Point (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_Interface => -- Generate a temporary to capture the value of the prefix:
Expand_Pragma_Import_Or_Interface (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_Interrupt_Priority => Decl :=
Expand_Pragma_Interrupt_Priority (N); Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition =>
New_Occurrence_Of (Etype (Pref), Loc));
Set_No_Initialization (Decl);
when Pragma_Loop_Variant => Prepend_To (Decls, Decl);
Expand_Pragma_Loop_Variant (N); Analyze (Decl);
when Pragma_Psect_Object => -- Evaluate the prefix, generate:
Expand_Pragma_Psect_Object (N); -- Temp := <Pref>;
when Pragma_Relative_Deadline => if No (Eval_Stmts) then
Expand_Pragma_Relative_Deadline (N); Eval_Stmts := New_List;
end if;
when Pragma_Suppress_Initialization => Append_To (Eval_Stmts,
Expand_Pragma_Suppress_Initialization (N); Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Temp, Loc),
Expression => Pref));
-- All other pragmas need no expander action -- Ensure that the prefix is valid
when others => null; if Validity_Checks_On and then Validity_Check_Operands then
end case; Ensure_Valid (Pref);
end if; end if;
end Expand_N_Pragma; -- Replace the original attribute 'Old by a reference to the
-- generated temporary.
-------------------------------
-- Expand_Pragma_Abort_Defer --
-------------------------------
-- 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 :=
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 Expand_Attributes_In (Conseq);
-- can inline the call to the function.
Add_Inlined_Body (AUD, N); -- The consequence does not contain any attribute 'Old references
Rewrite (N, if No (Eval_Stmts) then
Make_Block_Statement (Loc, return;
Handled_Statement_Sequence => HSS)); end if;
Set_Scope (Blk, Current_Scope); -- Augment the machinery to trigger the evaluation of all prefixes
Set_Etype (Blk, Standard_Void_Type); -- found in the step above. If Eval is empty, then this is the first
Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); -- consequence to yield expansion of 'Old. Generate:
Expand_At_End_Handler (HSS, Blk);
Analyze (N);
end Expand_Pragma_Abort_Defer;
-------------------------- -- if Flag then
-- Expand_Pragma_Check -- -- <evaluation statements>
-------------------------- -- end if;
procedure Expand_Pragma_Check (N : Node_Id) is if No (Evals) then
Cond : constant Node_Id := Arg2 (N); Evals :=
Nam : constant Name_Id := Chars (Arg1 (N)); Make_Implicit_If_Statement (CCs,
Msg : Node_Id; Condition => New_Occurrence_Of (Flag, Loc),
Then_Statements => Eval_Stmts);
Loc : constant Source_Ptr := Sloc (First_Node (Cond)); -- Otherwise generate:
-- Source location used in the case of a failed assertion: point to the -- elsif Flag then
-- failing condition, not Loc. Note that the source location of the -- <evaluation statements>
-- 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 else
-- Nothing to do if pragma is ignored if No (Elsif_Parts (Evals)) then
Set_Elsif_Parts (Evals, New_List);
end if;
if Is_Ignored (N) then Append_To (Elsif_Parts (Evals),
return; Make_Elsif_Part (Loc,
Condition => New_Occurrence_Of (Flag, Loc),
Then_Statements => Eval_Stmts));
end if; end if;
end Expand_Attributes_In_Consequence;
-- Since this check is active, we rewrite the pragma into a ---------------
-- corresponding if statement, and then analyze the statement -- Increment --
---------------
-- The normal case expansion transforms: 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;
-- pragma Check (name, condition [,message]); ---------
-- Set --
---------
-- into 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;
-- if not condition then -- Local variables
-- System.Assertions.Raise_Assert_Failure (Str);
-- end if;
-- where Str is the message if one is present, or the default of Aggr : constant Node_Id :=
-- name failed at file:line if no message is given (the "name failed Expression (First
-- at" is omitted for name = Assertion, since it is redundant, given (Pragma_Argument_Associations (CCs)));
-- that the name of the exception is Assert_Failure.) 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;
-- Also, instead of "XXX failed at", we generate slightly -- Start of processing for Expand_Pragma_Contract_Cases
-- different messages for some of the contract assertions (see
-- code below for details).
-- An alternative expansion is used when the No_Exception_Propagation begin
-- restriction is active and there is a local Assert_Failure handler. -- Do nothing if pragma is not enabled. If pragma is disabled, it has
-- This is not a common combination of circumstances, but it occurs in -- already been rewritten as a Null statement.
-- the context of Aunit and the zero footprint profile. In this case we
-- generate:
-- if not condition then if Is_Ignored (CCs) then
-- raise Assert_Failure; return;
-- end if;
-- This will then be transformed into a goto, and the local handler will -- Guard against malformed contract cases
-- be able to handle the assert error (which would not be the case if a
-- call is made to the Raise_Assert_Failure procedure).
-- We also generate the direct raise if the Suppress_Exception_Locations elsif Nkind (Aggr) /= N_Aggregate then
-- is active, since we don't want to generate messages in this case. return;
end if;
-- Note that the reason we do not always generate a direct raise is that Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1;
-- the form in which the procedure is called allows for more efficient
-- breakpointing of assertion errors.
-- Generate the appropriate if statement. Note that we consider this to -- Create the counter which tracks the number of case guards that
-- be an explicit conditional in the source, not an implicit if, so we -- evaluate to True.
-- do not call Make_Implicit_If_Statement.
-- Case where we generate a direct raise -- Count : Natural := 0;
if ((Debug_Flag_Dot_G Count := Make_Temporary (Loc, 'C');
or else Restriction_Active (No_Exception_Propagation)) Count_Decl :=
and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) Make_Object_Declaration (Loc,
or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) Defining_Identifier => Count,
then Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
Rewrite (N, Expression => Make_Integer_Literal (Loc, 0));
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 Prepend_To (Decls, Count_Decl);
Analyze (Count_Decl);
else -- Create the base error message for multiple overlapping case guards
-- If we have a message given, use it
if Present (Arg3 (N)) then -- Msg_Str : constant String :=
Msg := Get_Pragma_Arg (Arg3 (N)); -- "contract cases overlap for subprogram Subp_Id";
-- Here we have no string, so prepare one if Multiple_PCs then
Msg_Str := Make_Temporary (Loc, 'S');
else Start_String;
declare Store_String_Chars ("contract cases overlap for subprogram ");
Loc_Str : constant String := Build_Location_String (Loc); Store_String_Chars (Get_Name_String (Chars (Subp_Id)));
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 -- 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
end if; -- 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;
--------------------------------- 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,
Left_Opnd => New_Occurrence_Of (Count, Loc),
Right_Opnd => Make_Integer_Literal (Loc, 1)),
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; end if;
Set_All_Upper_Case; Append_To (Decls, CG_Checks);
Analyze (CG_Checks);
Psect := -- Once all case guards are evaluated and checked, evaluate any prefixes
Make_String_Literal (Eloc, Strval => String_From_Name_Buffer); -- of attribute 'Old founds in the selected consequence.
else if Present (Old_Evals) then
Get_Name_String (Chars (Internal)); Append_To (Decls, Old_Evals);
Set_All_Upper_Case; Analyze (Old_Evals);
Psect :=
Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
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 --
...@@ -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,7 +1463,6 @@ package body Exp_Prag is ...@@ -1465,7 +1463,6 @@ 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 (
...@@ -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