Skip to content

R
riscv-gcc-1
Commit 7fe6c026 by Robert Dewar Committed by Arnaud Charlet
Options

exp_prag.adb (Expand_Pragma_Check): Ignore pragma if Is_Ignored set. 

2013-09-10  Robert Dewar  <dewar@adacore.com>

	* exp_prag.adb (Expand_Pragma_Check): Ignore pragma if Is_Ignored set.
	* sem_ch13.adb (Make_Aitem_Pragma): Set Is_Checked if needed.
	* sem_prag.adb (Check_Kind): Moved from spec (Analyze_Pragma):
	Make sure Is_Ignored/Is_Checked are set right (Analyze_Pragma,
	case Check): Ditto (Check_Applicable_Policy): Handle
	Statement_Assertion case Throughout, set and check the Is_Checked
	flag as appropriate.
	* sem_prag.ads (Check_Kind): Moved to body.
	* sinfo.ads, sinfo.adb (Is_Checked): New flag.

From-SVN: r202457
parent 15e934bf
Showing with 159 additions and 58 deletions
gcc/ada/ChangeLog
2013-09-10 Robert Dewar <dewar@adacore.com>
* exp_prag.adb (Expand_Pragma_Check): Ignore pragma if Is_Ignored set.
* sem_ch13.adb (Make_Aitem_Pragma): Set Is_Checked if needed.
* sem_prag.adb (Check_Kind): Moved from spec (Analyze_Pragma):
Make sure Is_Ignored/Is_Checked are set right (Analyze_Pragma,
case Check): Ditto (Check_Applicable_Policy): Handle
Statement_Assertion case Throughout, set and check the Is_Checked
flag as appropriate.
* sem_prag.ads (Check_Kind): Moved to body.
* sinfo.ads, sinfo.adb (Is_Checked): New flag.
2013-09-10 Robert Dewar <dewar@adacore.com>
* aspects.ads (Delay_Type): New type (Aspect_Delay): New table.
* einfo.adb (Has_Delayed_Rep_Aspects): New flag
(May_Inherit_Delayed_Rep_Aspects): New flag (Rep_Clause): Removed
......
gcc/ada/exp_prag.adb
......@@ -287,10 +287,13 @@ package body Exp_Prag is
Msg : Node_Id;
begin
-- We already know that this check is enabled, because otherwise the
-- semantic pass dealt with rewriting the assertion (see Sem_Prag)
-- Nothing to do if pragma is ignored
-- Since this check is enabled, we rewrite the pragma into a
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:
......
gcc/ada/sem_ch13.adb
......@@ -1377,6 +1377,8 @@ package body Sem_Ch13 is
if Is_Ignored (Aspect) then
Set_Is_Ignored (Aitem);
elsif Is_Checked (Aspect) then
Set_Is_Checked (Aspect);
end if;
Set_Corresponding_Aspect (Aitem, Aspect);
......
gcc/ada/sem_prag.adb
......@@ -186,6 +186,25 @@ package body Sem_Prag is
-- whether a particular item appears in a mixed list of nodes and entities.
-- It is assumed that all nodes in the list have entities.
function Check_Kind (Nam : Name_Id) return Name_Id;
-- This function is used in connection with pragmas Assert, Check,
-- and assertion aspects and pragmas, to determine if Check pragmas
-- (or corresponding assertion aspects or pragmas) are currently active
-- as determined by the presence of -gnata on the command line (which
-- sets the default), and the appearance of pragmas Check_Policy and
-- Assertion_Policy as configuration pragmas either in a configuration
-- pragma file, or at the start of the current unit, or locally given
-- Check_Policy and Assertion_Policy pragmas that are currently active.
--
-- The value returned is one of the names Check, Ignore, Disable (On
-- returns Check, and Off returns Ignore).
--
-- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
-- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
-- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
-- _Post, _Invariant, or _Type_Invariant, which are special names used
-- in identifiers to represent these attribute references.
procedure Collect_Subprogram_Inputs_Outputs
(Subp_Id : Entity_Id;
Subp_Inputs : in out Elist_Id;
......@@ -3502,7 +3521,7 @@ package body Sem_Prag is
-- For a pragma PPC in the extended main source unit, record enabled
-- status in SCO.
if not Is_Ignored (N) and then not Split_PPC (N) then
if Is_Checked (N) and then not Split_PPC (N) then
Set_SCO_Pragma_Enabled (Loc);
end if;
......@@ -8171,11 +8190,27 @@ package body Sem_Prag is
Prag_Id := Get_Pragma_Id (Pname);
Pname := Original_Name (N);
-- Check applicable policy. We skip this for a pragma that came from
-- an aspect, since we already dealt with the Disable case, and we set
-- the Is_Ignored flag at the time the aspect was analyzed.
-- Check applicable policy. We skip this if Is_Checked or Is_Ignored
-- is already set, indicating that we have already checked the policy
-- at the right point. This happens for example in the case of a pragma
-- that is derived from an Aspect.
if Is_Ignored (N) or else Is_Checked (N) then
null;
-- For a pragma that is a rewriting of another pragma, copy the
-- Is_Checked/Is_Ignored status from the rewritten pragma.
elsif Is_Rewrite_Substitution (N)
and then Nkind (Original_Node (N)) = N_Pragma
and then Original_Node (N) /= N
then
Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
Set_Is_Checked (N, Is_Checked (Original_Node (N)));
-- Otherwise query the applicable policy at this point
if not From_Aspect_Specification (N) then
else
Check_Applicable_Policy (N);
-- If pragma is disabled, rewrite as NULL and skip analysis
......@@ -8886,6 +8921,8 @@ package body Sem_Prag is
Append_To (Newa, New_Copy_Tree (Arg2));
end if;
-- Rewrite as Check pragma
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
......@@ -9497,9 +9534,6 @@ package body Sem_Prag is
Cname : Name_Id;
Str : Node_Id;
Check_On : Boolean;
-- Set True if category of assertions referenced by Name enabled
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (2);
......@@ -9533,24 +9567,33 @@ package body Sem_Prag is
null;
end case;
-- Set Check_On to indicate check status
-- Check applicable policy. We skip this if Checked/Ignored status
-- is already set (e.g. in the casse of a pragma from an aspect).
-- If this comes from an aspect, we have already taken care of
-- the policy active when the aspect was analyzed, and Is_Ignored
-- is set appropriately already.
if Is_Checked (N) or else Is_Ignored (N) then
null;
if From_Aspect_Specification (N) then
Check_On := not Is_Ignored (N);
-- For a non-source pragma that is a rewriting of another pragma,
-- copy the Is_Checked/Ignored status from the rewritten pragma.
-- Otherwise check the status right now
elsif Is_Rewrite_Substitution (N)
and then Nkind (Original_Node (N)) = N_Pragma
and then Original_Node (N) /= N
then
Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
Set_Is_Checked (N, Is_Checked (Original_Node (N)));
-- Otherwise query the applicable policy at this point
else
case Check_Kind (Cname) is
when Name_Ignore =>
Check_On := False;
Set_Is_Ignored (N, True);
Set_Is_Checked (N, False);
when Name_Check =>
Check_On := True;
Set_Is_Ignored (N, False);
Set_Is_Checked (N, True);
-- For disable, rewrite pragma as null statement and skip
-- rest of the analysis of the pragma.
......@@ -9585,7 +9628,7 @@ package body Sem_Prag is
when others =>
if Check_On and then not Split_PPC (N) then
if Is_Checked (N) and then not Split_PPC (N) then
-- Mark pragma/aspect SCO as enabled
......@@ -9602,7 +9645,7 @@ package body Sem_Prag is
-- we do want to analyze (to get proper references).
-- The Preanalyze_And_Resolve routine does just what we want
if not Check_On then
if Is_Ignored (N) then
Preanalyze_And_Resolve (Str, Standard_String);
-- Otherwise we need a proper analysis and expansion
......@@ -9625,11 +9668,11 @@ package body Sem_Prag is
-- null;
-- end if;
-- The reason we do this rewriting during semantic analysis
-- rather than as part of normal expansion is that we cannot
-- analyze and expand the code for the boolean expression
-- directly, or it may cause insertion of actions that would
-- escape the attempt to suppress the check code.
-- The reason we do this rewriting during semantic analysis rather
-- than as part of normal expansion is that we cannot analyze and
-- expand the code for the boolean expression directly, or it may
-- cause insertion of actions that would escape the attempt to
-- suppress the check code.
-- Note that the Sloc for the if statement corresponds to the
-- argument condition, not the pragma itself. The reason for
......@@ -9637,7 +9680,7 @@ package body Sem_Prag is
-- False at compile time, and we do not want to delete this
-- warning when we delete the if statement.
if Expander_Active and not Check_On then
if Expander_Active and Is_Ignored (N) then
Eloc := Sloc (Expr);
Rewrite (N,
......@@ -15047,11 +15090,9 @@ package body Sem_Prag is
Check_Optional_Identifier (Arg1, Name_Check);
Check_Precondition_Postcondition (In_Body);
-- If in spec, nothing more to do. If in body, then we convert the
-- pragma to an equivalent pragam Check. Note we do this whether
-- or not precondition checks are enabled. That works fine since
-- pragma Check will do this check, and will also analyze the
-- condition itself in the proper context.
-- If in spec, nothing more to do. If in body, then we convert
-- the pragma to an equivalent pragma Check. That works fine since
-- pragma Check will analyze the condition in the proper context.
-- The form of the pragma Check is either:
......@@ -15064,20 +15105,25 @@ package body Sem_Prag is
-- pragmas are checked.
if In_Body then
-- Rewrite as Check pragma
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Pname)),
Expression => Make_Identifier (Loc, Pname)),
Make_Pragma_Argument_Association (Sloc (Arg1),
Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
Expression =>
Relocate_Node (Get_Pragma_Arg (Arg1))))));
if Arg_Count = 2 then
Append_To (Pragma_Argument_Associations (N),
Make_Pragma_Argument_Association (Sloc (Arg2),
Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
Expression =>
Relocate_Node (Get_Pragma_Arg (Arg2))));
end if;
Analyze (N);
......@@ -18298,17 +18344,33 @@ package body Sem_Prag is
Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
begin
if Ename = Pnm or else Pnm = Name_Assertion then
if Ename = Pnm
or else Pnm = Name_Assertion
or else (Pnm = Name_Statement_Assertions
and then (Ename = Name_Assert or else
Ename = Name_Assert_And_Cut or else
Ename = Name_Assume or else
Ename = Name_Loop_Invariant))
then
Policy := Chars (Get_Pragma_Arg (Last (PPA)));
case Policy is
when Name_Off | Name_Ignore =>
Set_Is_Ignored (N, True);
Set_Is_Checked (N, False);
when Name_On | Name_Check =>
Set_Is_Checked (N, True);
Set_Is_Ignored (N, False);
when Name_Disable =>
Set_Is_Ignored (N, True);
Set_Is_Checked (N, False);
Set_Is_Disabled (N, True);
-- That should be exhaustive, the null here is a defence
-- against a malformed tree from previous errors.
when others =>
null;
end case;
......@@ -18325,8 +18387,12 @@ package body Sem_Prag is
-- compatibility with the RM for the cases of assertion, invariant,
-- precondition, predicate, and postcondition.
if not Assertions_Enabled then
Set_Is_Ignored (N);
if Assertions_Enabled then
Set_Is_Checked (N, True);
Set_Is_Ignored (N, False);
else
Set_Is_Checked (N, False);
Set_Is_Ignored (N, True);
end if;
end Check_Applicable_Policy;
......
gcc/ada/sem_prag.ads
......@@ -63,25 +63,6 @@ package Sem_Prag is
-- expressions in the pragma as "spec expressions" (see section in Sem
-- "Handling of Default and Per-Object Expressions...").
function Check_Kind (Nam : Name_Id) return Name_Id;
-- This function is used in connection with pragmas Assert, Check,
-- and assertion aspects and pragmas, to determine if Check pragmas
-- (or corresponding assertion aspects or pragmas) are currently active
-- as determined by the presence of -gnata on the command line (which
-- sets the default), and the appearance of pragmas Check_Policy and
-- Assertion_Policy as configuration pragmas either in a configuration
-- pragma file, or at the start of the current unit, or locally given
-- Check_Policy and Assertion_Policy pragmas that are currently active.
--
-- The value returned is one of the names Check, Ignore, Disable (On
-- returns Check, and Off returns Ignore).
--
-- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
-- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
-- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
-- _Post, _Invariant, or _Type_Invariant, which are special names used
-- in identifiers to represent these attribute references.
procedure Check_Applicable_Policy (N : Node_Id);
-- N is either an N_Aspect or an N_Pragma node. There are two cases. If
-- the name of the aspect or pragma is not one of those recognized as
......
gcc/ada/sinfo.adb
......@@ -1732,6 +1732,15 @@ package body Sinfo is
return Flag16 (N);
end Is_Boolean_Aspect;
function Is_Checked
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Pragma);
return Flag11 (N);
end Is_Checked;
function Is_Component_Left_Opnd
(N : Node_Id) return Boolean is
begin
......@@ -4840,6 +4849,15 @@ package body Sinfo is
Set_Flag16 (N, Val);
end Set_Is_Boolean_Aspect;
procedure Set_Is_Checked
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Pragma);
Set_Flag11 (N, Val);
end Set_Is_Checked;
procedure Set_Is_Component_Left_Opnd
(N : Node_Id; Val : Boolean := True) is
begin
......
gcc/ada/sinfo.ads
......@@ -1269,6 +1269,15 @@ package Sinfo is
-- Present in N_Aspect_Specification node. Set if the aspect is for a
-- boolean aspect (i.e. Aspect_Id is in Boolean_Aspect subtype).
-- Is_Checked (Flag11-Sem)
-- Present in N_Aspect_Specification and N_Pragma nodes. Set for an
-- assertion aspect or pragma, or check pragma for an assertion, that
-- is to be checked at run - time. If either Is_Checked or Is_Ignored
-- is set (they cannot both be set), then this means that the status of
-- the pragma has been checked at the appropriate point and should not
-- be further modified (in some cases these flags are copied when a
-- pragma is rewritten).
-- Is_Component_Left_Opnd (Flag13-Sem)
-- Is_Component_Right_Opnd (Flag14-Sem)
-- Present in concatenation nodes, to indicate that the corresponding
......@@ -2116,6 +2125,7 @@ package Sinfo is
-- Is_Delayed_Aspect (Flag14-Sem)
-- Is_Disabled (Flag15-Sem)
-- Is_Ignored (Flag9-Sem)
-- Is_Checked (Flag11-Sem)
-- Import_Interface_Present (Flag16-Sem)
-- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
......@@ -6763,6 +6773,7 @@ package Sinfo is
-- Next_Rep_Item (Node5-Sem)
-- Split_PPC (Flag17) Set if split pre/post attribute
-- Is_Boolean_Aspect (Flag16-Sem)
-- Is_Checked (Flag11-Sem)
-- Is_Delayed_Aspect (Flag14-Sem)
-- Is_Disabled (Flag15-Sem)
-- Is_Ignored (Flag9-Sem)
......@@ -8725,6 +8736,9 @@ package Sinfo is
function Is_Boolean_Aspect
(N : Node_Id) return Boolean; -- Flag16
function Is_Checked
(N : Node_Id) return Boolean; -- Flag11
function Is_Component_Left_Opnd
(N : Node_Id) return Boolean; -- Flag13
......@@ -9715,6 +9729,9 @@ package Sinfo is
procedure Set_Is_Boolean_Aspect
(N : Node_Id; Val : Boolean := True); -- Flag16
procedure Set_Is_Checked
(N : Node_Id; Val : Boolean := True); -- Flag11
procedure Set_Is_Component_Left_Opnd
(N : Node_Id; Val : Boolean := True); -- Flag13
......@@ -12100,6 +12117,7 @@ package Sinfo is
pragma Inline (Is_Accessibility_Actual);
pragma Inline (Is_Asynchronous_Call_Block);
pragma Inline (Is_Boolean_Aspect);
pragma Inline (Is_Checked);
pragma Inline (Is_Component_Left_Opnd);
pragma Inline (Is_Component_Right_Opnd);
pragma Inline (Is_Controlling_Actual);
......@@ -12425,6 +12443,7 @@ package Sinfo is
pragma Inline (Set_Is_Accessibility_Actual);
pragma Inline (Set_Is_Asynchronous_Call_Block);
pragma Inline (Set_Is_Boolean_Aspect);
pragma Inline (Set_Is_Checked);
pragma Inline (Set_Is_Component_Left_Opnd);
pragma Inline (Set_Is_Component_Right_Opnd);
pragma Inline (Set_Is_Controlling_Actual);
......
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