This change removes an annoying irregularity in N_Pragma nodes, which had
the last argument copied in two distinct syntactic descendents
(Pragma_Argument_Associations and Debug_Statement) for a pragma Debug.
This caused duplicated SCO information to be emitted for decisions occurring
in the actual parameters of the procedure call enclosed in such a pragma.
The Debug_Statement attribute is actually superfluous, and now removed.
The SCO information in the ALI file for the following compilation must
contain exactly one CX line:
$ gcc -c -gnateS dup_sco.adb
$ grep "^CX" dup_sco.ali
CX &7:28 c7:26-7:26 c7:37-7:37
pragma Debug_Policy (Check);
procedure Dup_SCO (A, B : Boolean) is
procedure Assert (X : Boolean) is
begin
null;
end Assert;
pragma Debug (Assert (A and then B));
begin
null;
end Dup_SCO;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-04 Thomas Quinot <qui...@adacore.com>
* sinfo.ads, sinfo.adb (Debug_Statement, Set_Debug_Statement): Remove.
* tbuild.ads, tbuild.adb (Make_Pragma): Adjust accordingly.
* sinfo-cn.ads, sinfo-cn.adb (Change_Name_To_Procedure_Call_Statement):
New subprogram, moved here from...
* par.adb, par-ch5.adb (P_Statement_Name): ... here.
* par-prag.adb (Par.Prag, case Pragma_Debug): Do not perform any
rewriting of the last argument into a procedure call statement here...
* sem_prag.adb (Analyze_Pragma, case Pragma_Debug): ...do it there
instead.
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 177275)
+++ sinfo.adb (working copy)
@@ -661,14 +661,6 @@
return Node5 (N);
end Dcheck_Function;
- function Debug_Statement
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Node3 (N);
- end Debug_Statement;
-
function Declarations
(N : Node_Id) return List_Id is
begin
@@ -3712,14 +3704,6 @@
Set_Node5 (N, Val); -- semantic field, no parent set
end Set_Dcheck_Function;
- procedure Set_Debug_Statement
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Node3_With_Parent (N, Val);
- end Set_Debug_Statement;
-
procedure Set_Declarations
(N : Node_Id; Val : List_Id) is
begin
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 177275)
+++ sinfo.ads (working copy)
@@ -764,15 +764,6 @@
-- This field is present in an N_Variant node, It references the entity
-- for the discriminant checking function for the variant.
- -- Debug_Statement (Node3)
- -- This field is present in an N_Pragma node. It is used only for a Debug
- -- pragma. The parameter is of the form of an expression, as required by
- -- the pragma syntax, but is actually a procedure call. To simplify
- -- semantic processing, the parser creates a copy of the argument
- -- rearranged into a procedure call statement and places it in the
- -- Debug_Statement field. Note that this field is considered syntactic
- -- field, since it is created by the parser.
-
-- Default_Expression (Node5-Sem)
-- This field is Empty if there is no default expression. If there is a
-- simple default expression (one with no side effects), then this field
@@ -2069,7 +2060,6 @@
-- Sloc points to PRAGMA
-- Next_Pragma (Node1-Sem)
-- Pragma_Argument_Associations (List2) (set to No_List if none)
- -- Debug_Statement (Node3) (set to Empty if not Debug)
-- Pragma_Identifier (Node4)
-- Next_Rep_Item (Node5-Sem)
-- Pragma_Enabled (Flag5-Sem)
@@ -8201,9 +8191,6 @@
function Dcheck_Function
(N : Node_Id) return Entity_Id; -- Node5
- function Debug_Statement
- (N : Node_Id) return Node_Id; -- Node3
-
function Declarations
(N : Node_Id) return List_Id; -- List2
@@ -9173,9 +9160,6 @@
procedure Set_Dcheck_Function
(N : Node_Id; Val : Entity_Id); -- Node5
- procedure Set_Debug_Statement
- (N : Node_Id; Val : Node_Id); -- Node3
-
procedure Set_Declarations
(N : Node_Id; Val : List_Id); -- List2
@@ -10105,7 +10089,7 @@
N_Pragma =>
(1 => False, -- Next_Pragma (Node1-Sem)
2 => True, -- Pragma_Argument_Associations (List2)
- 3 => True, -- Debug_Statement (Node3)
+ 3 => False, -- unused
4 => True, -- Pragma_Identifier (Node4)
5 => False), -- Next_Rep_Item (Node5-Sem)
@@ -11732,7 +11716,6 @@
pragma Inline (Corresponding_Spec);
pragma Inline (Corresponding_Stub);
pragma Inline (Dcheck_Function);
- pragma Inline (Debug_Statement);
pragma Inline (Declarations);
pragma Inline (Default_Expression);
pragma Inline (Default_Storage_Pool);
@@ -12053,7 +12036,6 @@
pragma Inline (Set_Corresponding_Spec);
pragma Inline (Set_Corresponding_Stub);
pragma Inline (Set_Dcheck_Function);
- pragma Inline (Set_Debug_Statement);
pragma Inline (Set_Declarations);
pragma Inline (Set_Default_Expression);
pragma Inline (Set_Default_Storage_Pool);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 177335)
+++ sem_prag.adb (working copy)
@@ -7430,7 +7430,8 @@
-- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
when Pragma_Debug => Debug : declare
- Cond : Node_Id;
+ Cond : Node_Id;
+ Call : Node_Id;
begin
GNAT_Pragma;
@@ -7443,10 +7444,41 @@
if Arg_Count = 2 then
Cond :=
Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Cond),
- Right_Opnd => Get_Pragma_Arg (Arg1));
+ Left_Opnd => Relocate_Node (Cond),
+ Right_Opnd => Get_Pragma_Arg (Arg1));
+ Call := Get_Pragma_Arg (Arg2);
+ else
+ Call := Get_Pragma_Arg (Arg1);
end if;
+ if Nkind_In (Call,
+ N_Indexed_Component,
+ N_Function_Call,
+ N_Identifier,
+ N_Selected_Component)
+ then
+ -- If this pragma Debug comes from source, its argument was
+ -- parsed as a name form (which is syntactically identical).
+ -- Change it to a procedure call statement now.
+
+ Change_Name_To_Procedure_Call_Statement (Call);
+
+ elsif Nkind (Call) = N_Procedure_Call_Statement then
+
+ -- Already in the form of a procedure call statement: nothing
+ -- to do (could happen in case of an internally generated
+ -- pragma Debug).
+
+ null;
+
+ else
+ -- All other cases: diagnose error
+
+ Error_Msg
+ ("argument of pragma% is not procedure call", Sloc (Call));
+ return;
+ end if;
+
-- Rewrite into a conditional with an appropriate condition. We
-- wrap the procedure call in a block so that overhead from e.g.
-- use of the secondary stack does not generate execution overhead
@@ -7458,8 +7490,7 @@
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Relocate_Node (Debug_Statement (N))))))));
+ Statements => New_List (Relocate_Node (Call)))))));
Analyze (N);
end Debug;
Index: tbuild.adb
===================================================================
--- tbuild.adb (revision 177275)
+++ tbuild.adb (working copy)
@@ -388,14 +388,12 @@
function Make_Pragma
(Sloc : Source_Ptr;
Chars : Name_Id;
- Pragma_Argument_Associations : List_Id := No_List;
- Debug_Statement : Node_Id := Empty) return Node_Id
+ Pragma_Argument_Associations : List_Id := No_List) return Node_Id
is
begin
return
Make_Pragma (Sloc,
Pragma_Argument_Associations => Pragma_Argument_Associations,
- Debug_Statement => Debug_Statement,
Pragma_Identifier => Make_Identifier (Sloc, Chars));
end Make_Pragma;
Index: tbuild.ads
===================================================================
--- tbuild.ads (revision 177274)
+++ tbuild.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -150,8 +150,7 @@
function Make_Pragma
(Sloc : Source_Ptr;
Chars : Name_Id;
- Pragma_Argument_Associations : List_Id := No_List;
- Debug_Statement : Node_Id := Empty) return Node_Id;
+ Pragma_Argument_Associations : List_Id := No_List) return Node_Id;
-- A convenient form of Make_Pragma not requiring a Pragma_Identifier
-- argument (this argument is built from the value given for Chars).
Index: par.adb
===================================================================
--- par.adb (revision 177274)
+++ par.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -723,10 +723,6 @@
function P_Loop_Parameter_Specification return Node_Id;
-- Used in loop constructs and quantified expressions.
- function P_Statement_Name (Name_Node : Node_Id) return Node_Id;
- -- Given a node representing a name (which is a call), converts it
- -- to the syntactically corresponding procedure call statement.
-
function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id;
-- The argument indicates the acceptable termination tokens.
-- See body in Par.Ch5 for details of the use of this parameter.
Index: sinfo-cn.adb
===================================================================
--- sinfo-cn.adb (revision 177274)
+++ sinfo-cn.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -30,7 +30,8 @@
-- general manner, but in some specific cases, the fields of related nodes
-- have been deliberately layed out in a manner that permits such alteration.
-with Atree; use Atree;
+with Atree; use Atree;
+with Snames; use Snames;
package body Sinfo.CN is
@@ -74,6 +75,58 @@
N := Extend_Node (N);
end Change_Identifier_To_Defining_Identifier;
+ ---------------------------------------------
+ -- Change_Name_To_Procedure_Call_Statement --
+ ---------------------------------------------
+
+ procedure Change_Name_To_Procedure_Call_Statement (N : Node_Id) is
+ begin
+ -- Case of Indexed component, which is a procedure call with arguments
+
+ if Nkind (N) = N_Indexed_Component then
+ declare
+ Prefix_Node : constant Node_Id := Prefix (N);
+ Exprs_Node : constant List_Id := Expressions (N);
+
+ begin
+ Change_Node (N, N_Procedure_Call_Statement);
+ Set_Name (N, Prefix_Node);
+ Set_Parameter_Associations (N, Exprs_Node);
+ end;
+
+ -- Case of function call node, which is a really a procedure call
+
+ elsif Nkind (N) = N_Function_Call then
+ declare
+ Fname_Node : constant Node_Id := Name (N);
+ Params_List : constant List_Id := Parameter_Associations (N);
+
+ begin
+ Change_Node (N, N_Procedure_Call_Statement);
+ Set_Name (N, Fname_Node);
+ Set_Parameter_Associations (N, Params_List);
+ end;
+
+ -- Case of call to attribute that denotes a procedure. Here we just
+ -- leave the attribute reference unchanged.
+
+ elsif Nkind (N) = N_Attribute_Reference
+ and then Is_Procedure_Attribute_Name (Attribute_Name (N))
+ then
+ null;
+
+ -- All other cases of names are parameterless procedure calls
+
+ else
+ declare
+ Name_Node : constant Node_Id := Relocate_Node (N);
+ begin
+ Change_Node (N, N_Procedure_Call_Statement);
+ Set_Name (N, Name_Node);
+ end;
+ end if;
+ end Change_Name_To_Procedure_Call_Statement;
+
--------------------------------------------------------
-- Change_Operator_Symbol_To_Defining_Operator_Symbol --
--------------------------------------------------------
Index: sinfo-cn.ads
===================================================================
--- sinfo-cn.ads (revision 177274)
+++ sinfo-cn.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -65,4 +65,9 @@
-- on return the Chars field is set to a copy of the contents of the
-- Chars field of the Selector_Name field.
+ procedure Change_Name_To_Procedure_Call_Statement (N : Node_Id);
+ -- Some statements (procedure call statements) are in the form of a name
+ -- and are parsed as such. This routine takes the scanned name as input
+ -- and returns the corresponding N_Procedure_Call_Statement.
+
end Sinfo.CN;
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 177274)
+++ par-prag.adb (working copy)
@@ -358,43 +358,17 @@
-- Debug --
-----------
- -- pragma Debug (PROCEDURE_CALL_STATEMENT);
+ -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
- -- This has to be processed by the parser because of the very peculiar
- -- form of the second parameter, which is syntactically from a formal
- -- point of view a function call (since it must be an expression), but
- -- semantically we treat it as a procedure call (which has exactly the
- -- same syntactic form, so that's why we can get away with this!)
+ when Pragma_Debug =>
+ Check_No_Identifier (Arg1);
- when Pragma_Debug => Debug : declare
- Expr : Node_Id;
-
- begin
if Arg_Count = 2 then
- Check_No_Identifier (Arg1);
Check_No_Identifier (Arg2);
- Expr := New_Copy (Expression (Arg2));
-
else
Check_Arg_Count (1);
- Check_No_Identifier (Arg1);
- Expr := New_Copy (Expression (Arg1));
end if;
- if Nkind (Expr) /= N_Indexed_Component
- and then Nkind (Expr) /= N_Function_Call
- and then Nkind (Expr) /= N_Identifier
- and then Nkind (Expr) /= N_Selected_Component
- then
- Error_Msg
- ("argument of pragma% is not procedure call", Sloc (Expr));
- raise Error_Resync;
- else
- Set_Debug_Statement
- (Pragma_Node, P_Statement_Name (Expr));
- end if;
- end Debug;
-
-------------------------------
-- Extensions_Allowed (GNAT) --
-------------------------------
Index: par-ch5.adb
===================================================================
--- par-ch5.adb (revision 177274)
+++ par-ch5.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -24,9 +24,11 @@
------------------------------------------------------------------------------
pragma Style_Checks (All_Checks);
--- Turn off subprogram body ordering check. Subprograms are in order
--- by RM section rather than alphabetical
+-- Turn off subprogram body ordering check. Subprograms are in order by RM
+-- section rather than alphabetical.
+with Sinfo.CN; use Sinfo.CN;
+
separate (Par)
package body Ch5 is
@@ -499,8 +501,8 @@
-- we want to speed up as much as possible.
elsif Token = Tok_Semicolon then
- Append_To (Statement_List,
- P_Statement_Name (Id_Node));
+ Change_Name_To_Procedure_Call_Statement (Id_Node);
+ Append_To (Statement_List, Id_Node);
Scan; -- past semicolon
Statement_Required := False;
@@ -652,8 +654,8 @@
-- means that the item we just scanned was a call.
elsif Token = Tok_Semicolon then
- Append_To (Statement_List,
- P_Statement_Name (Name_Node));
+ Change_Name_To_Procedure_Call_Statement (Name_Node);
+ Append_To (Statement_List, Name_Node);
Scan; -- past semicolon
Statement_Required := False;
@@ -727,8 +729,8 @@
-- call with no parameters.
if Token_Is_At_Start_Of_Line then
- Append_To (Statement_List,
- P_Statement_Name (Id_Node));
+ Change_Name_To_Procedure_Call_Statement (Id_Node);
+ Append_To (Statement_List, Id_Node);
T_Semicolon; -- to give error message
Statement_Required := False;
@@ -769,8 +771,8 @@
Append_To (Statement_List,
P_Assignment_Statement (Name_Node));
else
- Append_To (Statement_List,
- P_Statement_Name (Name_Node));
+ Change_Name_To_Procedure_Call_Statement (Name_Node);
+ Append_To (Statement_List, Name_Node);
end if;
TF_Semicolon;
@@ -954,68 +956,6 @@
-- 5.1 Statement --
--------------------
- -- Parsed by P_Sequence_Of_Statements (5.1), except for the case
- -- of a statement of the form of a name, which is handled here. The
- -- argument passed in is the tree for the name which has been scanned
- -- The returned value is the corresponding statement form.
-
- -- This routine is also used by Par.Prag for processing the procedure
- -- call that appears as the second argument of a pragma Assert.
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Statement_Name (Name_Node : Node_Id) return Node_Id is
- Stmt_Node : Node_Id;
-
- begin
- -- Case of Indexed component, which is a procedure call with arguments
-
- if Nkind (Name_Node) = N_Indexed_Component then
- declare
- Prefix_Node : constant Node_Id := Prefix (Name_Node);
- Exprs_Node : constant List_Id := Expressions (Name_Node);
-
- begin
- Change_Node (Name_Node, N_Procedure_Call_Statement);
- Set_Name (Name_Node, Prefix_Node);
- Set_Parameter_Associations (Name_Node, Exprs_Node);
- return Name_Node;
- end;
-
- -- Case of function call node, which is a really a procedure call
-
- elsif Nkind (Name_Node) = N_Function_Call then
- declare
- Fname_Node : constant Node_Id := Name (Name_Node);
- Params_List : constant List_Id :=
- Parameter_Associations (Name_Node);
-
- begin
- Change_Node (Name_Node, N_Procedure_Call_Statement);
- Set_Name (Name_Node, Fname_Node);
- Set_Parameter_Associations (Name_Node, Params_List);
- return Name_Node;
- end;
-
- -- Case of call to attribute that denotes a procedure. Here we
- -- just leave the attribute reference unchanged.
-
- elsif Nkind (Name_Node) = N_Attribute_Reference
- and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node))
- then
- return Name_Node;
-
- -- All other cases of names are parameterless procedure calls
-
- else
- Stmt_Node :=
- New_Node (N_Procedure_Call_Statement, Sloc (Name_Node));
- Set_Name (Stmt_Node, Name_Node);
- return Stmt_Node;
- end if;
-
- end P_Statement_Name;
-
---------------------------
-- 5.1 Simple Statement --
---------------------------
