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