+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>
* erroutc.adb: Minor reformatting.
-- --
-- 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- --
------------------------------------------------------------------------------
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
-- 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;
-- 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;
-- 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;
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;
-- 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 --
---------------------------
-- 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 => Debug : declare
- Expr : Node_Id;
+ when Pragma_Debug =>
+ Check_No_Identifier (Arg1);
- 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) --
-- --
-- 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- --
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.
procedure Process_Decisions (N : Node_Id; T : Character);
-- 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
- -- expression: if/exit when/pragma/while/expression). If T is other than X,
- -- the node N is the conditional expression involved, and a decision is
- -- always present (at the very least a simple decision is present at the
- -- top level).
+ -- to output any decisions it contains. T is one of IEGPWX (for context of
+ -- expression: if/exit when/entry guard/pragma/while/expression). If T is
+ -- other than X, the node N is the conditional expression involved, and a
+ -- decision is always present (at the very least a simple decision is
+ -- present at the top level).
procedure Process_Decisions (L : List_Id; T : Character);
-- Calls above procedure for each element of the list L
begin
case Nkind (N) is
- -- Logical operators, output table entries and then process
- -- operands recursively to deal with nested conditions.
+ -- Logical operators, output table entries and then process
+ -- operands recursively to deal with nested conditions.
when N_And_Then |
N_Or_Else |
when N_Case_Expression =>
return OK; -- ???
- -- Conditional expression, processed like an if statement
+ -- Conditional expression, processed like an IF statement
when N_Conditional_Expression =>
declare
procedure Debug_Put_SCOs is new Put_SCOs;
- -- Start of processing for pscos
+ -- Start of processing for pscos
begin
Debug_Put_SCOs;
-- Control functions for floating-point unit
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;
-- Reset the floating-point processor to the default state needed to get
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
with System.Img_Uns; use System.Img_Uns;
with System.Powten_Table; use System.Powten_Table;
with System.Unsigned_Types; use System.Unsigned_Types;
+with System.Float_Control;
package body System.Img_Real is
Aft : Natural;
Exp : Natural)
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);
Sign : Character;
X : aliased Long_Long_Float;
-- Start of processing for Set_Image_Real
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;
-- Deal with invalid values first,
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
with System.Task_Info;
with System.Interrupt_Management;
with System.Win32.Ext;
+with System.Float_Control;
with System.Soft_Links;
-- We use System.Soft_Links instead of System.Tasking.Initialization because
-- System.Task_Primitives.Operations.Create_Task during thread creation.
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);
pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
-- Get stack boundaries
begin
Specific.Set (Self_ID);
- Init_Float;
+
+ -- Properly initializes the FPU for x86 systems
+
+ System.Float_Control.Reset;
if Self_ID.Common.Task_Info /= null
and then
with System.Multiprocessors;
with System.Tasking.Debug;
with System.Interrupt_Management;
+with System.Float_Control;
with System.Soft_Links;
-- We use System.Soft_Links instead of System.Tasking.Initialization
----------------
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
-- 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
Specific.Set (Self_ID);
- Init_Float;
+ -- Properly initializes the FPU for PPC/MIPS systems
+
+ System.Float_Control.Reset;
-- Install the signal handlers
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
with System.Powten_Table; use System.Powten_Table;
with System.Val_Util; use System.Val_Util;
+with System.Float_Control;
package body System.Val_Real is
Ptr : not null access Integer;
Max : Integer) return Long_Long_Float
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;
-- Local copy of string pointer
-- Start of processing for System.Scan_Real
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);
P := Ptr.all;
Ptr.all := Start;
-- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
when Pragma_Debug => Debug : declare
- Cond : Node_Id;
+ Cond : Node_Id;
+ Call : Node_Id;
begin
GNAT_Pragma;
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
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;
-- --
-- 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- --
-- 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
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 --
--------------------------------------------------------
-- --
-- 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- --
-- 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;
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
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
-- 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
-- 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)
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
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
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)
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);
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);
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;
-- --
-- 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- --
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).
projects / gcc.git / commitdiff