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
This commit is contained in:
parent
a12e42fc3d
commit
b9eb3aa8a2
|
@ -1,3 +1,13 @@
|
|||
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.
|
||||
|
|
|
@ -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),
|
||||
|
|
|
@ -156,9 +156,399 @@ package body Exp_Prag is
|
|||
end if;
|
||||
end Arg3;
|
||||
|
||||
---------------------------
|
||||
-- Expand_Contract_Cases --
|
||||
---------------------------
|
||||
---------------------
|
||||
-- Expand_N_Pragma --
|
||||
---------------------
|
||||
|
||||
procedure Expand_N_Pragma (N : Node_Id) is
|
||||
Pname : constant Name_Id := Pragma_Name (N);
|
||||
|
||||
begin
|
||||
-- Rewrite pragma ignored by Ignore_Pragma to null statement, so that
|
||||
-- the back end or the expander here does not get over-enthusiastic and
|
||||
-- start processing such a pragma!
|
||||
|
||||
if Get_Name_Table_Boolean3 (Pname) then
|
||||
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
||||
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
|
||||
|
||||
-- Pragmas requiring special expander action
|
||||
|
||||
when Pragma_Abort_Defer =>
|
||||
Expand_Pragma_Abort_Defer (N);
|
||||
|
||||
when Pragma_Check =>
|
||||
Expand_Pragma_Check (N);
|
||||
|
||||
when Pragma_Common_Object =>
|
||||
Expand_Pragma_Common_Object (N);
|
||||
|
||||
when Pragma_Import =>
|
||||
Expand_Pragma_Import_Or_Interface (N);
|
||||
|
||||
when Pragma_Inspection_Point =>
|
||||
Expand_Pragma_Inspection_Point (N);
|
||||
|
||||
when Pragma_Interface =>
|
||||
Expand_Pragma_Import_Or_Interface (N);
|
||||
|
||||
when Pragma_Interrupt_Priority =>
|
||||
Expand_Pragma_Interrupt_Priority (N);
|
||||
|
||||
when Pragma_Loop_Variant =>
|
||||
Expand_Pragma_Loop_Variant (N);
|
||||
|
||||
when Pragma_Psect_Object =>
|
||||
Expand_Pragma_Psect_Object (N);
|
||||
|
||||
when Pragma_Relative_Deadline =>
|
||||
Expand_Pragma_Relative_Deadline (N);
|
||||
|
||||
when Pragma_Suppress_Initialization =>
|
||||
Expand_Pragma_Suppress_Initialization (N);
|
||||
|
||||
-- All other pragmas need no expander action
|
||||
|
||||
when others => null;
|
||||
end case;
|
||||
end if;
|
||||
|
||||
end Expand_N_Pragma;
|
||||
|
||||
-------------------------------
|
||||
-- Expand_Pragma_Abort_Defer --
|
||||
-------------------------------
|
||||
|
||||
-- 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.
|
||||
|
||||
-- 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
|
||||
Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
|
||||
loop
|
||||
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
|
||||
-- can inline the call to the function.
|
||||
|
||||
Add_Inlined_Body (AUD, N);
|
||||
|
||||
Rewrite (N,
|
||||
Make_Block_Statement (Loc,
|
||||
Handled_Statement_Sequence => HSS));
|
||||
|
||||
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;
|
||||
|
||||
--------------------------
|
||||
-- Expand_Pragma_Check --
|
||||
--------------------------
|
||||
|
||||
procedure Expand_Pragma_Check (N : Node_Id) is
|
||||
Cond : constant Node_Id := Arg2 (N);
|
||||
Nam : constant Name_Id := Chars (Arg1 (N));
|
||||
Msg : Node_Id;
|
||||
|
||||
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.
|
||||
|
||||
begin
|
||||
-- Nothing to do if pragma is ignored
|
||||
|
||||
if Is_Ignored (N) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Since this check is active, we rewrite the pragma into a
|
||||
-- corresponding if statement, and then analyze the statement
|
||||
|
||||
-- The normal case expansion transforms:
|
||||
|
||||
-- pragma Check (name, condition [,message]);
|
||||
|
||||
-- into
|
||||
|
||||
-- if not condition then
|
||||
-- System.Assertions.Raise_Assert_Failure (Str);
|
||||
-- end if;
|
||||
|
||||
-- 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.)
|
||||
|
||||
-- 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
|
||||
-- is active, since we don't want to generate messages in this case.
|
||||
|
||||
-- Note that the reason we do not always generate a direct raise is that
|
||||
-- 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
|
||||
-- be an explicit conditional in the source, not an implicit if, so we
|
||||
-- do not call Make_Implicit_If_Statement.
|
||||
|
||||
-- Case where we generate a direct raise
|
||||
|
||||
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)))));
|
||||
|
||||
-- Case where we call the procedure
|
||||
|
||||
else
|
||||
-- If we have a message given, use it
|
||||
|
||||
if Present (Arg3 (N)) then
|
||||
Msg := Get_Pragma_Arg (Arg3 (N));
|
||||
|
||||
-- Here we have no string, so prepare one
|
||||
|
||||
else
|
||||
declare
|
||||
Loc_Str : constant String := Build_Location_String (Loc);
|
||||
|
||||
begin
|
||||
Name_Len := 0;
|
||||
|
||||
-- For Assert, we just use the location
|
||||
|
||||
if Nam = Name_Assert then
|
||||
null;
|
||||
|
||||
-- For predicate, we generate the string "predicate failed at
|
||||
-- yyy". We prefer all lower case for predicate.
|
||||
|
||||
elsif Nam = Name_Predicate then
|
||||
Add_Str_To_Name_Buffer ("predicate failed at ");
|
||||
|
||||
-- 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.
|
||||
|
||||
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 ");
|
||||
|
||||
-- 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).
|
||||
|
||||
elsif Nam = Name_Invariant then
|
||||
Add_Str_To_Name_Buffer ("failed invariant from ");
|
||||
|
||||
-- For all other checks, the string is "xxx failed at yyy"
|
||||
-- where xxx is the check name with current source file casing.
|
||||
|
||||
else
|
||||
Get_Name_String (Nam);
|
||||
Set_Casing (Identifier_Casing (Current_Source_File));
|
||||
Add_Str_To_Name_Buffer (" failed at ");
|
||||
end if;
|
||||
|
||||
-- In all cases, add location string
|
||||
|
||||
Add_Str_To_Name_Buffer (Loc_Str);
|
||||
|
||||
-- Build the message
|
||||
|
||||
Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Now rewrite as an if statement
|
||||
|
||||
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;
|
||||
|
||||
Analyze (N);
|
||||
|
||||
-- If new condition is always false, give a warning
|
||||
|
||||
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_Entity_Name (Original_Node (Cond))
|
||||
and then Entity (Original_Node (Cond)) = Standard_False
|
||||
then
|
||||
return;
|
||||
|
||||
elsif Nam = Name_Assert then
|
||||
Error_Msg_N ("?A?assertion will fail at run time", N);
|
||||
else
|
||||
|
||||
Error_Msg_N ("?A?check will fail at run time", N);
|
||||
end if;
|
||||
end if;
|
||||
end Expand_Pragma_Check;
|
||||
|
||||
---------------------------------
|
||||
-- Expand_Pragma_Common_Object --
|
||||
---------------------------------
|
||||
|
||||
-- Use a machine attribute to replicate semantic effect in DEC Ada
|
||||
|
||||
-- pragma Machine_Attribute (intern_name, "common_object", extern_name);
|
||||
|
||||
-- For now we do nothing with the size attribute ???
|
||||
|
||||
-- Note: Psect_Object shares this processing
|
||||
|
||||
procedure Expand_Pragma_Common_Object (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
||||
Internal : constant Node_Id := Arg1 (N);
|
||||
External : constant Node_Id := Arg2 (N);
|
||||
|
||||
Psect : Node_Id;
|
||||
-- Psect value upper cased as string literal
|
||||
|
||||
Iloc : constant Source_Ptr := Sloc (Internal);
|
||||
Eloc : constant Source_Ptr := Sloc (External);
|
||||
Ploc : Source_Ptr;
|
||||
|
||||
begin
|
||||
-- Acquire Psect value and fold to upper case
|
||||
|
||||
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;
|
||||
|
||||
Set_All_Upper_Case;
|
||||
|
||||
Psect :=
|
||||
Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
|
||||
|
||||
else
|
||||
Get_Name_String (Chars (Internal));
|
||||
Set_All_Upper_Case;
|
||||
Psect :=
|
||||
Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
|
||||
end if;
|
||||
|
||||
Ploc := Sloc (Psect);
|
||||
|
||||
-- Insert the pragma
|
||||
|
||||
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;
|
||||
|
||||
----------------------------------
|
||||
-- Expand_Pragma_Contract_Cases --
|
||||
----------------------------------
|
||||
|
||||
-- Pragma Contract_Cases is expanded in the following manner:
|
||||
|
||||
|
@ -237,7 +627,7 @@ package body Exp_Prag is
|
|||
-- . . .
|
||||
-- end S;
|
||||
|
||||
procedure Expand_Contract_Cases
|
||||
procedure Expand_Pragma_Contract_Cases
|
||||
(CCs : Node_Id;
|
||||
Subp_Id : Entity_Id;
|
||||
Decls : List_Id;
|
||||
|
@ -594,7 +984,7 @@ package body Exp_Prag is
|
|||
Others_Flag : Entity_Id := Empty;
|
||||
Post_Case : Node_Id;
|
||||
|
||||
-- Start of processing for Expand_Contract_Cases
|
||||
-- Start of processing for Expand_Pragma_Contract_Cases
|
||||
|
||||
begin
|
||||
-- Do nothing if pragma is not enabled. If pragma is disabled, it has
|
||||
|
@ -833,397 +1223,7 @@ package body Exp_Prag is
|
|||
end if;
|
||||
|
||||
Append_To (Stmts, Conseq_Checks);
|
||||
end Expand_Contract_Cases;
|
||||
|
||||
---------------------
|
||||
-- Expand_N_Pragma --
|
||||
---------------------
|
||||
|
||||
procedure Expand_N_Pragma (N : Node_Id) is
|
||||
Pname : constant Name_Id := Pragma_Name (N);
|
||||
|
||||
begin
|
||||
-- Rewrite pragma ignored by Ignore_Pragma to null statement, so that/
|
||||
-- back end or the expander here does not get over-enthusiastic and
|
||||
-- start processing such a pragma!
|
||||
|
||||
if Get_Name_Table_Boolean3 (Pname) then
|
||||
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
||||
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
|
||||
|
||||
-- Pragmas requiring special expander action
|
||||
|
||||
when Pragma_Abort_Defer =>
|
||||
Expand_Pragma_Abort_Defer (N);
|
||||
|
||||
when Pragma_Check =>
|
||||
Expand_Pragma_Check (N);
|
||||
|
||||
when Pragma_Common_Object =>
|
||||
Expand_Pragma_Common_Object (N);
|
||||
|
||||
when Pragma_Import =>
|
||||
Expand_Pragma_Import_Or_Interface (N);
|
||||
|
||||
when Pragma_Inspection_Point =>
|
||||
Expand_Pragma_Inspection_Point (N);
|
||||
|
||||
when Pragma_Interface =>
|
||||
Expand_Pragma_Import_Or_Interface (N);
|
||||
|
||||
when Pragma_Interrupt_Priority =>
|
||||
Expand_Pragma_Interrupt_Priority (N);
|
||||
|
||||
when Pragma_Loop_Variant =>
|
||||
Expand_Pragma_Loop_Variant (N);
|
||||
|
||||
when Pragma_Psect_Object =>
|
||||
Expand_Pragma_Psect_Object (N);
|
||||
|
||||
when Pragma_Relative_Deadline =>
|
||||
Expand_Pragma_Relative_Deadline (N);
|
||||
|
||||
when Pragma_Suppress_Initialization =>
|
||||
Expand_Pragma_Suppress_Initialization (N);
|
||||
|
||||
-- All other pragmas need no expander action
|
||||
|
||||
when others => null;
|
||||
end case;
|
||||
end if;
|
||||
|
||||
end Expand_N_Pragma;
|
||||
|
||||
-------------------------------
|
||||
-- Expand_Pragma_Abort_Defer --
|
||||
-------------------------------
|
||||
|
||||
-- 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.
|
||||
|
||||
-- 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
|
||||
Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
|
||||
loop
|
||||
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
|
||||
-- can inline the call to the function.
|
||||
|
||||
Add_Inlined_Body (AUD, N);
|
||||
|
||||
Rewrite (N,
|
||||
Make_Block_Statement (Loc,
|
||||
Handled_Statement_Sequence => HSS));
|
||||
|
||||
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;
|
||||
|
||||
--------------------------
|
||||
-- Expand_Pragma_Check --
|
||||
--------------------------
|
||||
|
||||
procedure Expand_Pragma_Check (N : Node_Id) is
|
||||
Cond : constant Node_Id := Arg2 (N);
|
||||
Nam : constant Name_Id := Chars (Arg1 (N));
|
||||
Msg : Node_Id;
|
||||
|
||||
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.
|
||||
|
||||
begin
|
||||
-- Nothing to do if pragma is ignored
|
||||
|
||||
if Is_Ignored (N) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Since this check is active, we rewrite the pragma into a
|
||||
-- corresponding if statement, and then analyze the statement
|
||||
|
||||
-- The normal case expansion transforms:
|
||||
|
||||
-- pragma Check (name, condition [,message]);
|
||||
|
||||
-- into
|
||||
|
||||
-- if not condition then
|
||||
-- System.Assertions.Raise_Assert_Failure (Str);
|
||||
-- end if;
|
||||
|
||||
-- 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.)
|
||||
|
||||
-- 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
|
||||
-- is active, since we don't want to generate messages in this case.
|
||||
|
||||
-- Note that the reason we do not always generate a direct raise is that
|
||||
-- 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
|
||||
-- be an explicit conditional in the source, not an implicit if, so we
|
||||
-- do not call Make_Implicit_If_Statement.
|
||||
|
||||
-- Case where we generate a direct raise
|
||||
|
||||
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)))));
|
||||
|
||||
-- Case where we call the procedure
|
||||
|
||||
else
|
||||
-- If we have a message given, use it
|
||||
|
||||
if Present (Arg3 (N)) then
|
||||
Msg := Get_Pragma_Arg (Arg3 (N));
|
||||
|
||||
-- Here we have no string, so prepare one
|
||||
|
||||
else
|
||||
declare
|
||||
Loc_Str : constant String := Build_Location_String (Loc);
|
||||
|
||||
begin
|
||||
Name_Len := 0;
|
||||
|
||||
-- For Assert, we just use the location
|
||||
|
||||
if Nam = Name_Assert then
|
||||
null;
|
||||
|
||||
-- For predicate, we generate the string "predicate failed
|
||||
-- at yyy". We prefer all lower case for predicate.
|
||||
|
||||
elsif Nam = Name_Predicate then
|
||||
Add_Str_To_Name_Buffer ("predicate failed at ");
|
||||
|
||||
-- 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.
|
||||
|
||||
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 ");
|
||||
|
||||
-- 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).
|
||||
|
||||
elsif Nam = Name_Invariant then
|
||||
Add_Str_To_Name_Buffer ("failed invariant from ");
|
||||
|
||||
-- For all other checks, the string is "xxx failed at yyy"
|
||||
-- where xxx is the check name with current source file casing.
|
||||
|
||||
else
|
||||
Get_Name_String (Nam);
|
||||
Set_Casing (Identifier_Casing (Current_Source_File));
|
||||
Add_Str_To_Name_Buffer (" failed at ");
|
||||
end if;
|
||||
|
||||
-- In all cases, add location string
|
||||
|
||||
Add_Str_To_Name_Buffer (Loc_Str);
|
||||
|
||||
-- Build the message
|
||||
|
||||
Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Now rewrite as an if statement
|
||||
|
||||
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;
|
||||
|
||||
Analyze (N);
|
||||
|
||||
-- If new condition is always false, give a warning
|
||||
|
||||
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_Entity_Name (Original_Node (Cond))
|
||||
and then Entity (Original_Node (Cond)) = Standard_False
|
||||
then
|
||||
return;
|
||||
|
||||
elsif Nam = Name_Assert then
|
||||
Error_Msg_N ("?A?assertion will fail at run time", N);
|
||||
else
|
||||
|
||||
Error_Msg_N ("?A?check will fail at run time", N);
|
||||
end if;
|
||||
end if;
|
||||
end Expand_Pragma_Check;
|
||||
|
||||
---------------------------------
|
||||
-- Expand_Pragma_Common_Object --
|
||||
---------------------------------
|
||||
|
||||
-- Use a machine attribute to replicate semantic effect in DEC Ada
|
||||
|
||||
-- pragma Machine_Attribute (intern_name, "common_object", extern_name);
|
||||
|
||||
-- For now we do nothing with the size attribute ???
|
||||
|
||||
-- Note: Psect_Object shares this processing
|
||||
|
||||
procedure Expand_Pragma_Common_Object (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
||||
Internal : constant Node_Id := Arg1 (N);
|
||||
External : constant Node_Id := Arg2 (N);
|
||||
|
||||
Psect : Node_Id;
|
||||
-- Psect value upper cased as string literal
|
||||
|
||||
Iloc : constant Source_Ptr := Sloc (Internal);
|
||||
Eloc : constant Source_Ptr := Sloc (External);
|
||||
Ploc : Source_Ptr;
|
||||
|
||||
begin
|
||||
-- Acquire Psect value and fold to upper case
|
||||
|
||||
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;
|
||||
|
||||
Set_All_Upper_Case;
|
||||
|
||||
Psect :=
|
||||
Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
|
||||
|
||||
else
|
||||
Get_Name_String (Chars (Internal));
|
||||
Set_All_Upper_Case;
|
||||
Psect :=
|
||||
Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
|
||||
end if;
|
||||
|
||||
Ploc := Sloc (Psect);
|
||||
|
||||
-- Insert the pragma
|
||||
|
||||
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;
|
||||
end Expand_Pragma_Contract_Cases;
|
||||
|
||||
---------------------------------------
|
||||
-- Expand_Pragma_Import_Or_Interface --
|
||||
|
@ -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,7 +1463,6 @@ 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 (
|
||||
|
@ -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)))))));
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Reference in New Issue