Skip to content

R
riscv-gcc-1
Commit 7ab4d95a by Arnaud Charlet
Options

[multiple changes] 

2011-08-04  Tristan Gingold  <gingold@adacore.com>

	* s-taprop-vxworks.adb (Enter_Task): Use System.Float_Control.Reset
	instead of the locally imported procedure.
	* s-taprop-mingw.adb (Enter_Task): Ditto.
	* s-valrea.adb (Scan_Real): Ditto.
	* s-imgrea.adb (Set_Image_Real): Ditto.
	* s-flocon.ads: Make the package pure.

2011-08-04  Thomas Quinot  <quinot@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.

2011-08-04  Thomas Quinot  <quinot@adacore.com>

	* par_sco.adb: Minor reformatting.

From-SVN: r177337
parent 51c400f5
Showing with 176 additions and 189 deletions
gcc/ada/ChangeLog
2011-08-04 Tristan Gingold <gingold@adacore.com>
* s-taprop-vxworks.adb (Enter_Task): Use System.Float_Control.Reset
instead of the locally imported procedure.
* s-taprop-mingw.adb (Enter_Task): Ditto.
* s-valrea.adb (Scan_Real): Ditto.
* s-imgrea.adb (Set_Image_Real): Ditto.
* s-flocon.ads: Make the package pure.
2011-08-04 Thomas Quinot <quinot@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.
2011-08-04 Thomas Quinot <quinot@adacore.com>
* par_sco.adb: Minor reformatting.
2011-08-04 Robert Dewar <dewar@adacore.com> 2011-08-04 Robert Dewar <dewar@adacore.com>
* erroutc.adb: Minor reformatting. * erroutc.adb: Minor reformatting.
......
gcc/ada/par-ch5.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -24,8 +24,10 @@ ...@@ -24,8 +24,10 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
pragma Style_Checks (All_Checks); pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order -- Turn off subprogram body ordering check. Subprograms are in order by RM
-- by RM section rather than alphabetical -- section rather than alphabetical.
with Sinfo.CN; use Sinfo.CN;
separate (Par) separate (Par)
package body Ch5 is package body Ch5 is
...@@ -499,8 +501,8 @@ package body Ch5 is ...@@ -499,8 +501,8 @@ package body Ch5 is
-- we want to speed up as much as possible. -- we want to speed up as much as possible.
elsif Token = Tok_Semicolon then elsif Token = Tok_Semicolon then
Append_To (Statement_List, Change_Name_To_Procedure_Call_Statement (Id_Node);
P_Statement_Name (Id_Node)); Append_To (Statement_List, Id_Node);
Scan; -- past semicolon Scan; -- past semicolon
Statement_Required := False; Statement_Required := False;
...@@ -652,8 +654,8 @@ package body Ch5 is ...@@ -652,8 +654,8 @@ package body Ch5 is
-- means that the item we just scanned was a call. -- means that the item we just scanned was a call.
elsif Token = Tok_Semicolon then elsif Token = Tok_Semicolon then
Append_To (Statement_List, Change_Name_To_Procedure_Call_Statement (Name_Node);
P_Statement_Name (Name_Node)); Append_To (Statement_List, Name_Node);
Scan; -- past semicolon Scan; -- past semicolon
Statement_Required := False; Statement_Required := False;
...@@ -727,8 +729,8 @@ package body Ch5 is ...@@ -727,8 +729,8 @@ package body Ch5 is
-- call with no parameters. -- call with no parameters.
if Token_Is_At_Start_Of_Line then if Token_Is_At_Start_Of_Line then
Append_To (Statement_List, Change_Name_To_Procedure_Call_Statement (Id_Node);
P_Statement_Name (Id_Node)); Append_To (Statement_List, Id_Node);
T_Semicolon; -- to give error message T_Semicolon; -- to give error message
Statement_Required := False; Statement_Required := False;
...@@ -769,8 +771,8 @@ package body Ch5 is ...@@ -769,8 +771,8 @@ package body Ch5 is
Append_To (Statement_List, Append_To (Statement_List,
P_Assignment_Statement (Name_Node)); P_Assignment_Statement (Name_Node));
else else
Append_To (Statement_List, Change_Name_To_Procedure_Call_Statement (Name_Node);
P_Statement_Name (Name_Node)); Append_To (Statement_List, Name_Node);
end if; end if;
TF_Semicolon; TF_Semicolon;
...@@ -954,68 +956,6 @@ package body Ch5 is ...@@ -954,68 +956,6 @@ package body Ch5 is
-- 5.1 Statement -- -- 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 -- -- 5.1 Simple Statement --
--------------------------- ---------------------------
......
gcc/ada/par-prag.adb
...@@ -358,42 +358,16 @@ begin ...@@ -358,42 +358,16 @@ begin
-- Debug -- -- 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 when Pragma_Debug =>
-- form of the second parameter, which is syntactically from a formal Check_No_Identifier (Arg1);
-- 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 => Debug : declare
Expr : Node_Id;
begin
if Arg_Count = 2 then if Arg_Count = 2 then
Check_No_Identifier (Arg1);
Check_No_Identifier (Arg2); Check_No_Identifier (Arg2);
Expr := New_Copy (Expression (Arg2));
else else
Check_Arg_Count (1); 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 if;
end Debug;
------------------------------- -------------------------------
-- Extensions_Allowed (GNAT) -- -- Extensions_Allowed (GNAT) --
......
gcc/ada/par.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -723,10 +723,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is ...@@ -723,10 +723,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Loop_Parameter_Specification return Node_Id; function P_Loop_Parameter_Specification return Node_Id;
-- Used in loop constructs and quantified expressions. -- 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; function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id;
-- The argument indicates the acceptable termination tokens. -- The argument indicates the acceptable termination tokens.
-- See body in Par.Ch5 for details of the use of this parameter. -- See body in Par.Ch5 for details of the use of this parameter.
......
gcc/ada/par_sco.adb
...@@ -103,11 +103,11 @@ package body Par_SCO is ...@@ -103,11 +103,11 @@ package body Par_SCO is
procedure Process_Decisions (N : Node_Id; T : Character); procedure Process_Decisions (N : Node_Id; T : Character);
-- If N is Empty, has no effect. Otherwise scans the tree for the node N, -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
-- to output any decisions it contains. T is one of IEPWX (for context of -- to output any decisions it contains. T is one of IEGPWX (for context of
-- expression: if/exit when/pragma/while/expression). If T is other than X, -- expression: if/exit when/entry guard/pragma/while/expression). If T is
-- the node N is the conditional expression involved, and a decision is -- other than X, the node N is the conditional expression involved, and a
-- always present (at the very least a simple decision is present at the -- decision is always present (at the very least a simple decision is
-- top level). -- present at the top level).
procedure Process_Decisions (L : List_Id; T : Character); procedure Process_Decisions (L : List_Id; T : Character);
-- Calls above procedure for each element of the list L -- Calls above procedure for each element of the list L
...@@ -575,7 +575,7 @@ package body Par_SCO is ...@@ -575,7 +575,7 @@ package body Par_SCO is
when N_Case_Expression => when N_Case_Expression =>
return OK; -- ??? return OK; -- ???
-- Conditional expression, processed like an if statement -- Conditional expression, processed like an IF statement
when N_Conditional_Expression => when N_Conditional_Expression =>
declare declare
......
gcc/ada/s-flocon.ads
...@@ -32,6 +32,9 @@ ...@@ -32,6 +32,9 @@
-- Control functions for floating-point unit -- Control functions for floating-point unit
package System.Float_Control is package System.Float_Control is
pragma Pure;
-- This is not fully correct, but this unit is with-ed by pure units
-- (eg s-imgrea).
procedure Reset; procedure Reset;
-- Reset the floating-point processor to the default state needed to get -- Reset the floating-point processor to the default state needed to get
......
gcc/ada/s-imgrea.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -33,6 +33,7 @@ with System.Img_LLU; use System.Img_LLU; ...@@ -33,6 +33,7 @@ with System.Img_LLU; use System.Img_LLU;
with System.Img_Uns; use System.Img_Uns; with System.Img_Uns; use System.Img_Uns;
with System.Powten_Table; use System.Powten_Table; with System.Powten_Table; use System.Powten_Table;
with System.Unsigned_Types; use System.Unsigned_Types; with System.Unsigned_Types; use System.Unsigned_Types;
with System.Float_Control;
package body System.Img_Real is package body System.Img_Real is
...@@ -143,14 +144,6 @@ package body System.Img_Real is ...@@ -143,14 +144,6 @@ package body System.Img_Real is
Aft : Natural; Aft : Natural;
Exp : Natural) Exp : Natural)
is is
procedure Reset;
pragma Import (C, Reset, "__gnat_init_float");
-- We import the floating-point processor reset routine so that we can
-- be sure the floating-point processor is properly set for conversion
-- calls (see description of Reset in GNAT.Float_Control (g-flocon.ads).
-- This is notably need on Windows, where calls to the operating system
-- randomly reset the processor into 64-bit mode.
NFrac : constant Natural := Natural'Max (Aft, 1); NFrac : constant Natural := Natural'Max (Aft, 1);
Sign : Character; Sign : Character;
X : aliased Long_Long_Float; X : aliased Long_Long_Float;
...@@ -476,7 +469,13 @@ package body System.Img_Real is ...@@ -476,7 +469,13 @@ package body System.Img_Real is
-- Start of processing for Set_Image_Real -- Start of processing for Set_Image_Real
begin begin
Reset; -- We call the floating-point processor reset routine so that we can
-- be sure the floating-point processor is properly set for conversion
-- calls. This is notably need on Windows, where calls to the operating
-- system randomly reset the processor into 64-bit mode.
System.Float_Control.Reset;
Scale := 0; Scale := 0;
-- Deal with invalid values first, -- Deal with invalid values first,
......
gcc/ada/s-taprop-mingw.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -49,6 +49,7 @@ with System.OS_Primitives; ...@@ -49,6 +49,7 @@ with System.OS_Primitives;
with System.Task_Info; with System.Task_Info;
with System.Interrupt_Management; with System.Interrupt_Management;
with System.Win32.Ext; with System.Win32.Ext;
with System.Float_Control;
with System.Soft_Links; with System.Soft_Links;
-- We use System.Soft_Links instead of System.Tasking.Initialization because -- We use System.Soft_Links instead of System.Tasking.Initialization because
...@@ -791,16 +792,15 @@ package body System.Task_Primitives.Operations is ...@@ -791,16 +792,15 @@ package body System.Task_Primitives.Operations is
-- System.Task_Primitives.Operations.Create_Task during thread creation. -- System.Task_Primitives.Operations.Create_Task during thread creation.
procedure Enter_Task (Self_ID : Task_Id) is procedure Enter_Task (Self_ID : Task_Id) is
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for x86 systems
procedure Get_Stack_Bounds (Base : Address; Limit : Address); procedure Get_Stack_Bounds (Base : Address; Limit : Address);
pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds"); pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
-- Get stack boundaries -- Get stack boundaries
begin begin
Specific.Set (Self_ID); Specific.Set (Self_ID);
Init_Float;
-- Properly initializes the FPU for x86 systems
System.Float_Control.Reset;
if Self_ID.Common.Task_Info /= null if Self_ID.Common.Task_Info /= null
and then and then
......
gcc/ada/s-taprop-vxworks.adb
...@@ -46,6 +46,7 @@ with Interfaces.C; ...@@ -46,6 +46,7 @@ with Interfaces.C;
with System.Multiprocessors; with System.Multiprocessors;
with System.Tasking.Debug; with System.Tasking.Debug;
with System.Interrupt_Management; with System.Interrupt_Management;
with System.Float_Control;
with System.Soft_Links; with System.Soft_Links;
-- We use System.Soft_Links instead of System.Tasking.Initialization -- We use System.Soft_Links instead of System.Tasking.Initialization
...@@ -793,10 +794,6 @@ package body System.Task_Primitives.Operations is ...@@ -793,10 +794,6 @@ package body System.Task_Primitives.Operations is
---------------- ----------------
procedure Enter_Task (Self_ID : Task_Id) is procedure Enter_Task (Self_ID : Task_Id) is
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for PPC/MIPS systems
begin begin
-- Store the user-level task id in the Thread field (to be used -- Store the user-level task id in the Thread field (to be used
-- internally by the run-time system) and the kernel-level task id in -- internally by the run-time system) and the kernel-level task id in
...@@ -807,7 +804,9 @@ package body System.Task_Primitives.Operations is ...@@ -807,7 +804,9 @@ package body System.Task_Primitives.Operations is
Specific.Set (Self_ID); Specific.Set (Self_ID);
Init_Float; -- Properly initializes the FPU for PPC/MIPS systems
System.Float_Control.Reset;
-- Install the signal handlers -- Install the signal handlers
......
gcc/ada/s-valrea.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,6 +31,7 @@ ...@@ -31,6 +31,7 @@
with System.Powten_Table; use System.Powten_Table; with System.Powten_Table; use System.Powten_Table;
with System.Val_Util; use System.Val_Util; with System.Val_Util; use System.Val_Util;
with System.Float_Control;
package body System.Val_Real is package body System.Val_Real is
...@@ -43,14 +44,6 @@ package body System.Val_Real is ...@@ -43,14 +44,6 @@ package body System.Val_Real is
Ptr : not null access Integer; Ptr : not null access Integer;
Max : Integer) return Long_Long_Float Max : Integer) return Long_Long_Float
is is
procedure Reset;
pragma Import (C, Reset, "__gnat_init_float");
-- We import the floating-point processor reset routine so that we can
-- be sure the floating-point processor is properly set for conversion
-- calls (see description of Reset in GNAT.Float_Control (g-flocon.ads).
-- This is notably need on Windows, where calls to the operating system
-- randomly reset the processor into 64-bit mode.
P : Integer; P : Integer;
-- Local copy of string pointer -- Local copy of string pointer
...@@ -173,7 +166,13 @@ package body System.Val_Real is ...@@ -173,7 +166,13 @@ package body System.Val_Real is
-- Start of processing for System.Scan_Real -- Start of processing for System.Scan_Real
begin begin
Reset; -- We call the floating-point processor reset routine so that we can
-- be sure the floating-point processor is properly set for conversion
-- calls. This is notably need on Windows, where calls to the operating
-- system randomly reset the processor into 64-bit mode.
System.Float_Control.Reset;
Scan_Sign (Str, Ptr, Max, Minus, Start); Scan_Sign (Str, Ptr, Max, Minus, Start);
P := Ptr.all; P := Ptr.all;
Ptr.all := Start; Ptr.all := Start;
......
gcc/ada/sem_prag.adb
...@@ -7431,6 +7431,7 @@ package body Sem_Prag is ...@@ -7431,6 +7431,7 @@ package body Sem_Prag is
when Pragma_Debug => Debug : declare when Pragma_Debug => Debug : declare
Cond : Node_Id; Cond : Node_Id;
Call : Node_Id;
begin begin
GNAT_Pragma; GNAT_Pragma;
...@@ -7445,6 +7446,37 @@ package body Sem_Prag is ...@@ -7445,6 +7446,37 @@ package body Sem_Prag is
Make_And_Then (Loc, Make_And_Then (Loc,
Left_Opnd => Relocate_Node (Cond), Left_Opnd => Relocate_Node (Cond),
Right_Opnd => Get_Pragma_Arg (Arg1)); 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; end if;
-- Rewrite into a conditional with an appropriate condition. We -- Rewrite into a conditional with an appropriate condition. We
...@@ -7458,8 +7490,7 @@ package body Sem_Prag is ...@@ -7458,8 +7490,7 @@ package body Sem_Prag is
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (Relocate_Node (Call)))))));
Relocate_Node (Debug_Statement (N))))))));
Analyze (N); Analyze (N);
end Debug; end Debug;
......
gcc/ada/sinfo-cn.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,6 +31,7 @@ ...@@ -31,6 +31,7 @@
-- have been deliberately layed out in a manner that permits such alteration. -- 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 package body Sinfo.CN is
...@@ -74,6 +75,58 @@ package body Sinfo.CN is ...@@ -74,6 +75,58 @@ package body Sinfo.CN is
N := Extend_Node (N); N := Extend_Node (N);
end Change_Identifier_To_Defining_Identifier; 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 -- -- Change_Operator_Symbol_To_Defining_Operator_Symbol --
-------------------------------------------------------- --------------------------------------------------------
......
gcc/ada/sinfo-cn.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -65,4 +65,9 @@ package Sinfo.CN is ...@@ -65,4 +65,9 @@ package Sinfo.CN is
-- on return the Chars field is set to a copy of the contents of the -- on return the Chars field is set to a copy of the contents of the
-- Chars field of the Selector_Name field. -- 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; end Sinfo.CN;
gcc/ada/sinfo.adb
...@@ -661,14 +661,6 @@ package body Sinfo is ...@@ -661,14 +661,6 @@ package body Sinfo is
return Node5 (N); return Node5 (N);
end Dcheck_Function; 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 function Declarations
(N : Node_Id) return List_Id is (N : Node_Id) return List_Id is
begin begin
...@@ -3712,14 +3704,6 @@ package body Sinfo is ...@@ -3712,14 +3704,6 @@ package body Sinfo is
Set_Node5 (N, Val); -- semantic field, no parent set Set_Node5 (N, Val); -- semantic field, no parent set
end Set_Dcheck_Function; 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 procedure Set_Declarations
(N : Node_Id; Val : List_Id) is (N : Node_Id; Val : List_Id) is
begin begin
......
gcc/ada/sinfo.ads
...@@ -764,15 +764,6 @@ package Sinfo is ...@@ -764,15 +764,6 @@ package Sinfo is
-- This field is present in an N_Variant node, It references the entity -- This field is present in an N_Variant node, It references the entity
-- for the discriminant checking function for the variant. -- 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) -- Default_Expression (Node5-Sem)
-- This field is Empty if there is no default expression. If there is a -- 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 -- simple default expression (one with no side effects), then this field
...@@ -2069,7 +2060,6 @@ package Sinfo is ...@@ -2069,7 +2060,6 @@ package Sinfo is
-- Sloc points to PRAGMA -- Sloc points to PRAGMA
-- Next_Pragma (Node1-Sem) -- Next_Pragma (Node1-Sem)
-- Pragma_Argument_Associations (List2) (set to No_List if none) -- Pragma_Argument_Associations (List2) (set to No_List if none)
-- Debug_Statement (Node3) (set to Empty if not Debug)
-- Pragma_Identifier (Node4) -- Pragma_Identifier (Node4)
-- Next_Rep_Item (Node5-Sem) -- Next_Rep_Item (Node5-Sem)
-- Pragma_Enabled (Flag5-Sem) -- Pragma_Enabled (Flag5-Sem)
...@@ -8201,9 +8191,6 @@ package Sinfo is ...@@ -8201,9 +8191,6 @@ package Sinfo is
function Dcheck_Function function Dcheck_Function
(N : Node_Id) return Entity_Id; -- Node5 (N : Node_Id) return Entity_Id; -- Node5
function Debug_Statement
(N : Node_Id) return Node_Id; -- Node3
function Declarations function Declarations
(N : Node_Id) return List_Id; -- List2 (N : Node_Id) return List_Id; -- List2
...@@ -9173,9 +9160,6 @@ package Sinfo is ...@@ -9173,9 +9160,6 @@ package Sinfo is
procedure Set_Dcheck_Function procedure Set_Dcheck_Function
(N : Node_Id; Val : Entity_Id); -- Node5 (N : Node_Id; Val : Entity_Id); -- Node5
procedure Set_Debug_Statement
(N : Node_Id; Val : Node_Id); -- Node3
procedure Set_Declarations procedure Set_Declarations
(N : Node_Id; Val : List_Id); -- List2 (N : Node_Id; Val : List_Id); -- List2
...@@ -10105,7 +10089,7 @@ package Sinfo is ...@@ -10105,7 +10089,7 @@ package Sinfo is
N_Pragma => N_Pragma =>
(1 => False, -- Next_Pragma (Node1-Sem) (1 => False, -- Next_Pragma (Node1-Sem)
2 => True, -- Pragma_Argument_Associations (List2) 2 => True, -- Pragma_Argument_Associations (List2)
3 => True, -- Debug_Statement (Node3) 3 => False, -- unused
4 => True, -- Pragma_Identifier (Node4) 4 => True, -- Pragma_Identifier (Node4)
5 => False), -- Next_Rep_Item (Node5-Sem) 5 => False), -- Next_Rep_Item (Node5-Sem)
...@@ -11732,7 +11716,6 @@ package Sinfo is ...@@ -11732,7 +11716,6 @@ package Sinfo is
pragma Inline (Corresponding_Spec); pragma Inline (Corresponding_Spec);
pragma Inline (Corresponding_Stub); pragma Inline (Corresponding_Stub);
pragma Inline (Dcheck_Function); pragma Inline (Dcheck_Function);
pragma Inline (Debug_Statement);
pragma Inline (Declarations); pragma Inline (Declarations);
pragma Inline (Default_Expression); pragma Inline (Default_Expression);
pragma Inline (Default_Storage_Pool); pragma Inline (Default_Storage_Pool);
...@@ -12053,7 +12036,6 @@ package Sinfo is ...@@ -12053,7 +12036,6 @@ package Sinfo is
pragma Inline (Set_Corresponding_Spec); pragma Inline (Set_Corresponding_Spec);
pragma Inline (Set_Corresponding_Stub); pragma Inline (Set_Corresponding_Stub);
pragma Inline (Set_Dcheck_Function); pragma Inline (Set_Dcheck_Function);
pragma Inline (Set_Debug_Statement);
pragma Inline (Set_Declarations); pragma Inline (Set_Declarations);
pragma Inline (Set_Default_Expression); pragma Inline (Set_Default_Expression);
pragma Inline (Set_Default_Storage_Pool); pragma Inline (Set_Default_Storage_Pool);
......
gcc/ada/tbuild.adb
...@@ -388,14 +388,12 @@ package body Tbuild is ...@@ -388,14 +388,12 @@ package body Tbuild is
function Make_Pragma function Make_Pragma
(Sloc : Source_Ptr; (Sloc : Source_Ptr;
Chars : Name_Id; Chars : Name_Id;
Pragma_Argument_Associations : List_Id := No_List; Pragma_Argument_Associations : List_Id := No_List) return Node_Id
Debug_Statement : Node_Id := Empty) return Node_Id
is is
begin begin
return return
Make_Pragma (Sloc, Make_Pragma (Sloc,
Pragma_Argument_Associations => Pragma_Argument_Associations, Pragma_Argument_Associations => Pragma_Argument_Associations,
Debug_Statement => Debug_Statement,
Pragma_Identifier => Make_Identifier (Sloc, Chars)); Pragma_Identifier => Make_Identifier (Sloc, Chars));
end Make_Pragma; end Make_Pragma;
......
gcc/ada/tbuild.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -150,8 +150,7 @@ package Tbuild is ...@@ -150,8 +150,7 @@ package Tbuild is
function Make_Pragma function Make_Pragma
(Sloc : Source_Ptr; (Sloc : Source_Ptr;
Chars : Name_Id; Chars : Name_Id;
Pragma_Argument_Associations : List_Id := No_List; Pragma_Argument_Associations : List_Id := No_List) return Node_Id;
Debug_Statement : Node_Id := Empty) return Node_Id;
-- A convenient form of Make_Pragma not requiring a Pragma_Identifier -- A convenient form of Make_Pragma not requiring a Pragma_Identifier
-- argument (this argument is built from the value given for Chars). -- argument (this argument is built from the value given for Chars).
......
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