-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006 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- --
task type Anonymous_Task_Type (Self : Anonymous_Task_Node_Access) is
entry Start
- (Message_Id : in Message_Id_Type;
- Partition : in Partition_ID;
- Params_Size : in Ada.Streams.Stream_Element_Count;
- Result_Size : in Ada.Streams.Stream_Element_Count;
- Protocol : in Garlic.Protocol_Access);
+ (Message_Id : Message_Id_Type;
+ Partition : Partition_ID;
+ Params_Size : Ada.Streams.Stream_Element_Count;
+ Result_Size : Ada.Streams.Stream_Element_Count;
+ Protocol : Garlic.Protocol_Access);
-- This entry provides an anonymous task a remote call to perform.
-- This task calls for a Request id is provided to construct the
-- reply id by using -Request. Partition is used to send the reply
-- When it is resumed, we provide the size of the reply
entry Wake_Up
- (Request : in Request_Id_Type;
- Length : in Ada.Streams.Stream_Element_Count);
+ (Request : Request_Id_Type;
+ Length : Ada.Streams.Stream_Element_Count);
-- To wake up the calling stub when the environnement task has
-- received a reply for this request
-- Debugging package
procedure D
- (Flag : in Debug_Level; Info : in String) renames Debugging.Debug;
+ (Flag : Debug_Level; Info : String) renames Debugging.Debug;
-- Shortcut
------------------------
-- Null_Node --
---------------
- function Null_Node (Index : in Packet_Node_Access) return Boolean is
+ function Null_Node (Index : Packet_Node_Access) return Boolean is
begin
return Index = null;
procedure Write
(Stream : in out Params_Stream_Type;
- Item : in Ada.Streams.Stream_Element_Array)
+ Item : Ada.Streams.Stream_Element_Array)
renames System.RPC.Streams.Write;
-----------------------
----------------------------
procedure Establish_RPC_Receiver
- (Partition : in Partition_ID;
- Receiver : in RPC_Receiver)
+ (Partition : Partition_ID;
+ Receiver : RPC_Receiver)
is
begin
-- Set Partition_RPC_Receiver and allow RPC mechanism
select
accept Start
- (Message_Id : in Message_Id_Type;
- Partition : in Partition_ID;
- Params_Size : in Ada.Streams.Stream_Element_Count;
- Result_Size : in Ada.Streams.Stream_Element_Count;
- Protocol : in Protocol_Access)
+ (Message_Id : Message_Id_Type;
+ Partition : Partition_ID;
+ Params_Size : Ada.Streams.Stream_Element_Count;
+ Result_Size : Ada.Streams.Stream_Element_Count;
+ Protocol : Protocol_Access)
do
C_Message_Id := Message_Id;
C_Partition := Partition;
pragma Compile_Time_Warning
(Element_Type'Has_Access_Values,
- "?Element_Type for Direct_'I'O instance has access values");
+ "Element_Type for Direct_IO instance has access values");
type File_Type is limited private;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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 Basic_Exception_Tback_Maxlength
- (X : Exception_Occurrence) return Natural is
+ (X : Exception_Occurrence) return Natural
+ is
+ Space_Per_Traceback : constant := 2 + 16 + 1;
+ -- Space for "0x" + HHHHHHHHHHHHHHHH + " "
begin
- return BETB_Header'Length + 1 + X.Num_Tracebacks * 19 + 1;
- -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
+ return BETB_Header'Length + 1 +
+ X.Num_Tracebacks * Space_Per_Traceback + 1;
end Basic_Exception_Tback_Maxlength;
---------------------------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
procedure Adjust (Object : in out Controlled) is
pragma Warnings (Off, Object);
-
begin
null;
end Adjust;
procedure Finalize (Object : in out Controlled) is
pragma Warnings (Off, Object);
-
begin
null;
end Finalize;
procedure Finalize (Object : in out Limited_Controlled) is
pragma Warnings (Off, Object);
-
begin
null;
end Finalize;
procedure Initialize (Object : in out Controlled) is
pragma Warnings (Off, Object);
-
begin
null;
end Initialize;
procedure Initialize (Object : in out Limited_Controlled) is
pragma Warnings (Off, Object);
-
begin
null;
end Initialize;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
pragma Compile_Time_Warning
(Result_Subtype'Size > 48,
- "statistical properties not guaranteed for size '> 48");
+ "statistical properties not guaranteed for size > 48");
-- Basic facilities
["03C0"] : constant := Pi;
-- This is the greek letter Pi (for Ada 2005 AI-388). Note that it is
- -- conforming to have this present even in Ada 95 mode, because there is
- -- no way for a normal mode Ada 95 program to reference this identifier.
+ -- conforming to have this constant present even in Ada 95 mode, as there
+ -- is no way for a normal mode Ada 95 program to reference this identifier.
e : constant :=
2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996;
pragma Compile_Time_Warning
(Element_Type'Has_Access_Values,
- "?Element_Type for Sequential_'I'O instance has access values");
+ "Element_Type for Sequential_IO instance has access values");
type File_Type is limited private;
Actual_Width : constant Count := Count'Max (Count (Width), Item'Length);
begin
- if Set = Lower_Case and then Item (1) /= ''' then
+ if Set = Lower_Case and then Item (Item'First) /= ''' then
declare
Iteml : String (Item'First .. Item'Last);
else
Ptr := To'First;
for J in Item'Range loop
- if Set = Lower_Case and then Item (1) /= ''' then
+ if Set = Lower_Case and then Item (Item'First) /= ''' then
To (Ptr) := To_Lower (Item (J));
else
To (Ptr) := Item (J);
procedure Get (Item : out Enum) is
pragma Unsuppress (Range_Check);
-
begin
Get (Current_In, Item);
end Get;
Set : Type_Set := Default_Setting)
is
Image : constant String := Enum'Image (Item);
-
begin
Aux.Put (File, Image, Width, Set);
end Put;
Set : Type_Set := Default_Setting)
is
Image : constant String := Enum'Image (Item);
-
begin
Aux.Puts (To, Image, Set);
end Put;
begin
Check_On_One_Line (TFT (File), Actual_Width);
- if Set = Lower_Case and then Item (1) /= ''' then
+ if Set = Lower_Case and then Item (Item'First) /= ''' then
declare
Iteml : Wide_String (Item'First .. Item'Last);
Ptr := To'First;
for J in Item'Range loop
if Set = Lower_Case
- and then Item (1) /= '''
+ and then Item (Item'First) /= '''
and then Is_Character (Item (J))
then
To (Ptr) :=
begin
Check_On_One_Line (TFT (File), Actual_Width);
- if Set = Lower_Case and then Item (1) /= ''' then
+ if Set = Lower_Case and then Item (Item'First) /= ''' then
declare
Iteml : Wide_Wide_String (Item'First .. Item'Last);
Ptr := To'First;
for J in Item'Range loop
if Set = Lower_Case
- and then Item (1) /= '''
+ and then Item (Item'First) /= '''
and then Is_Character (Item (J))
then
To (Ptr) :=
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
procedure Get (File : File_Type; Item : out Enum) is
Buf : Wide_Wide_String (1 .. Enum'Width);
Buflen : Natural;
-
begin
Aux.Get_Enum_Lit (File, Buf, Buflen);
Item := Enum'Wide_Wide_Value (Buf (1 .. Buflen));
-
exception
when Constraint_Error => raise Data_Error;
end Get;
Last : out Positive)
is
Start : Natural;
-
begin
Aux.Scan_Enum_Lit (From, Start, Last);
Item := Enum'Wide_Wide_Value (From (Start .. Last));
-
exception
when Constraint_Error => raise Data_Error;
end Get;
Set : Type_Set := Default_Setting)
is
Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item);
-
begin
Aux.Put (File, Image, Width, Set);
end Put;
Set : Type_Set := Default_Setting)
is
Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item);
-
begin
Aux.Puts (To, Image, Set);
end Put;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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 Traverse_Func (Node : Node_Id) return Traverse_Result is
- function Traverse_Field (Fld : Union_Id) return Traverse_Result;
- -- Fld is one of the fields of Node. If the field points to a
- -- syntactic node or list, then this node or list is traversed,
- -- and the result is the result of this traversal. Otherwise
- -- a value of True is returned with no processing.
+ function Traverse_Field
+ (Nod : Node_Id;
+ Fld : Union_Id;
+ FN : Field_Num) return Traverse_Result;
+ -- Fld is one of the fields of Nod. If the field points to syntactic
+ -- node or list, then this node or list is traversed, and the result is
+ -- the result of this traversal. Otherwise a value of True is returned
+ -- with no processing. FN is the number of the field (1 .. 5).
--------------------
-- Traverse_Field --
--------------------
- function Traverse_Field (Fld : Union_Id) return Traverse_Result is
+ function Traverse_Field
+ (Nod : Node_Id;
+ Fld : Union_Id;
+ FN : Field_Num) return Traverse_Result
+ is
begin
if Fld = Union_Id (Empty) then
return OK;
-- Traverse descendent that is syntactic subtree node
- if Parent (Node_Id (Fld)) = Node
- or else Original_Node (Parent (Node_Id (Fld))) = Node
- then
+ if Is_Syntactic_Field (Nkind (Nod), FN) then
return Traverse_Func (Node_Id (Fld));
-- Node that is not a syntactic subtree
-- Traverse descendent that is a syntactic subtree list
- if Parent (List_Id (Fld)) = Node
- or else Original_Node (Parent (List_Id (Fld))) = Node
- then
+ if Is_Syntactic_Field (Nkind (Nod), FN) then
declare
Elmt : Node_Id := First (List_Id (Fld));
begin
return OK;
when OK =>
- if Traverse_Field (Union_Id (Field1 (Node))) = Abandon
+ if Traverse_Field (Node, Union_Id (Field1 (Node)), 1) = Abandon
or else
- Traverse_Field (Union_Id (Field2 (Node))) = Abandon
+ Traverse_Field (Node, Union_Id (Field2 (Node)), 2) = Abandon
or else
- Traverse_Field (Union_Id (Field3 (Node))) = Abandon
+ Traverse_Field (Node, Union_Id (Field3 (Node)), 3) = Abandon
or else
- Traverse_Field (Union_Id (Field4 (Node))) = Abandon
+ Traverse_Field (Node, Union_Id (Field4 (Node)), 4) = Abandon
or else
- Traverse_Field (Union_Id (Field5 (Node))) = Abandon
+ Traverse_Field (Node, Union_Id (Field5 (Node)), 5) = Abandon
then
return Abandon;
-
else
return OK;
end if;
when OK_Orig =>
declare
- Onode : constant Node_Id := Original_Node (Node);
-
+ Onod : constant Node_Id := Original_Node (Node);
begin
- if Traverse_Field (Union_Id (Field1 (Onode))) = Abandon
+ if Traverse_Field (Onod, Union_Id (Field1 (Onod)), 1) = Abandon
or else
- Traverse_Field (Union_Id (Field2 (Onode))) = Abandon
+ Traverse_Field (Onod, Union_Id (Field2 (Onod)), 2) = Abandon
or else
- Traverse_Field (Union_Id (Field3 (Onode))) = Abandon
+ Traverse_Field (Onod, Union_Id (Field3 (Onod)), 3) = Abandon
or else
- Traverse_Field (Union_Id (Field4 (Onode))) = Abandon
+ Traverse_Field (Onod, Union_Id (Field4 (Onod)), 4) = Abandon
or else
- Traverse_Field (Union_Id (Field5 (Onode))) = Abandon
+ Traverse_Field (Onod, Union_Id (Field5 (Onod)), 5) = Abandon
then
return Abandon;
-
else
return OK_Orig;
end if;
return Nodes.Table (N + 4).Field9;
end Field27;
+ function Field28 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 4).Field10;
+ end Field28;
+
function Node1 (N : Node_Id) return Node_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
return Node_Id (Nodes.Table (N + 4).Field9);
end Node27;
+ function Node28 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 4).Field10);
+ end Node28;
+
function List1 (N : Node_Id) return List_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
end if;
end Elist23;
- function Elist24 (N : Node_Id) return Elist_Id is
+ function Elist25 (N : Node_Id) return Elist_Id is
pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 4).Field6;
+ Value : constant Union_Id := Nodes.Table (N + 4).Field7;
begin
if Value = 0 then
return No_Elist;
else
return Elist_Id (Value);
end if;
- end Elist24;
+ end Elist25;
function Name1 (N : Node_Id) return Name_Id is
begin
Nodes.Table (N + 4).Field9 := Val;
end Set_Field27;
+ procedure Set_Field28 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 4).Field10 := Val;
+ end Set_Field28;
+
procedure Set_Node1 (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
Nodes.Table (N + 4).Field9 := Union_Id (Val);
end Set_Node27;
+ procedure Set_Node28 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 4).Field10 := Union_Id (Val);
+ end Set_Node28;
+
procedure Set_List1 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
Nodes.Table (N + 3).Field10 := Union_Id (Val);
end Set_Elist23;
- procedure Set_Elist24 (N : Node_Id; Val : Elist_Id) is
+ procedure Set_Elist25 (N : Node_Id; Val : Elist_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field6 := Union_Id (Val);
- end Set_Elist24;
+ Nodes.Table (N + 4).Field7 := Union_Id (Val);
+ end Set_Elist25;
procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
begin
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- this tree. There is no separate symbol table structure.
-- WARNING: There is a C version of this package. Any changes to this
--- source file must be properly reflected in the C header file tree.h
+-- source file must be properly reflected in the C header file atree.h
-- Package Atree defines the basic structure of the tree and its nodes and
-- provides the basic abstract interface for manipulating the tree. Two
-- Elist6 Synonym for Field6 typed as Elist_Id (Empty = No_Elist)
-- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
- -- Similar definitions for Field7 to Field27 (and Node7-Node27,
- -- Elist7-Elist27, Uint7-Uint27, Ureal7-Ureal27). Note that not all
+ -- Similar definitions for Field7 to Field28 (and Node7-Node28,
+ -- Elist7-Elist28, Uint7-Uint28, Ureal7-Ureal28). Note that not all
-- these functions are defined, only the ones that are actually used.
type Paren_Count_Type is mod 4;
function New_Copy_Tree
(Source : Node_Id;
- Map : Elist_Id := No_Elist;
+ Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id;
+ New_Scope : Entity_Id := Empty) return Node_Id;
-- Given a node that is the root of a subtree, Copy_Tree copies the entire
-- syntactic subtree, including recursively any descendents whose parent
-- field references a copied node (descendents not linked to a copied node
function Field27 (N : Node_Id) return Union_Id;
pragma Inline (Field27);
+ function Field28 (N : Node_Id) return Union_Id;
+ pragma Inline (Field28);
+
function Node1 (N : Node_Id) return Node_Id;
pragma Inline (Node1);
function Node27 (N : Node_Id) return Node_Id;
pragma Inline (Node27);
+ function Node28 (N : Node_Id) return Node_Id;
+ pragma Inline (Node28);
+
function List1 (N : Node_Id) return List_Id;
pragma Inline (List1);
function Elist23 (N : Node_Id) return Elist_Id;
pragma Inline (Elist23);
- function Elist24 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist24);
+ function Elist25 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist25);
function Name1 (N : Node_Id) return Name_Id;
pragma Inline (Name1);
procedure Set_Field27 (N : Node_Id; Val : Union_Id);
pragma Inline (Set_Field27);
+ procedure Set_Field28 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field28);
+
procedure Set_Node1 (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Node1);
procedure Set_Node27 (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Node27);
+ procedure Set_Node28 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node28);
+
procedure Set_List1 (N : Node_Id; Val : List_Id);
pragma Inline (Set_List1);
procedure Set_Elist23 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist23);
- procedure Set_Elist24 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist24);
+ procedure Set_Elist25 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist25);
procedure Set_Name1 (N : Node_Id; Val : Name_Id);
pragma Inline (Set_Name1);
-- above is used to hold additional general fields and flags
-- as follows:
- -- Field6-9 Holds Field24-Field27
- -- Field10 currently unused, reserved for expansion
+ -- Field6-10 Holds Field24-Field28
-- Field11 Holds Flag184-Flag215
-- Field12 currently unused, reserved for expansion
* *
* C Header File *
* *
- * Copyright (C) 1992-2005, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2006, 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- *
#define Field25(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field7)
#define Field26(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field8)
#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9)
+#define Field28(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field10)
#define Node1(N) Field1 (N)
#define Node2(N) Field2 (N)
#define Node25(N) Field25 (N)
#define Node26(N) Field26 (N)
#define Node27(N) Field27 (N)
+#define Node28(N) Field28 (N)
#define List1(N) Field1 (N)
#define List2(N) Field2 (N)
#define Elist18(N) Field18 (N)
#define Elist21(N) Field21 (N)
#define Elist23(N) Field23 (N)
-#define Elist24(N) Field24 (N)
+#define Elist25(N) Field25 (N)
#define Name1(N) Field1 (N)
#define Name2(N) Field2 (N)
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- the FSF version of GNAT, but there are specializations for
-- the GNATPRO and Public releases by AdaCore.
+ XF : constant Positive := X'First;
+ -- Start index, usually 1, but we won't assume this
+
procedure End_Line;
-- Add blanks up to column 76, and then a final vertical bar
Write_Eol;
end End_Line;
- Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
- Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF;
+ Is_GPL_Version : constant Boolean := Get_Gnat_Build_Type = GPL;
+ Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF;
-- Start of processing for Compiler_Abort
begin
+ Cancel_Special_Output;
+
-- Prevent recursion through Compiler_Abort, e.g. via SIGSEGV
if Abort_In_Progress then
Last_Blank : Integer := 70;
begin
- for P in 40 .. 69 loop
- if X (P) = ' ' then
+ for P in 39 .. 68 loop
+ if X (XF + P) = ' ' then
Last_Blank := P;
end if;
end loop;
- Write_Str (X (1 .. Last_Blank));
+ Write_Str (X (XF .. XF - 1 + Last_Blank));
End_Line;
Write_Str ("| ");
- Write_Str (X (Last_Blank + 1 .. X'Length));
+ Write_Str (X (XF + Last_Blank .. X'Last));
end;
else
Write_Str (X);
" http://gcc.gnu.org/bugs.html.");
End_Line;
- elsif Is_Public_Version then
+ elsif Is_GPL_Version then
+
Write_Str
- ("| submit bug report by email " &
+ ("| Please submit a bug report by email " &
"to report@adacore.com.");
End_Line;
Write_Str
+ ("| GAP members can alternatively use GNAT Tracker:");
+ End_Line;
+
+ Write_Str
+ ("| http://www.adacore.com/ " &
+ "section 'send a report'.");
+ End_Line;
+
+ Write_Str
("| See gnatinfo.txt for full info on procedure " &
"for submitting bugs.");
End_Line;
Write_Str
("| alternatively submit a bug report by email " &
- "to report@adacore.com.");
+ "to report@adacore.com,");
+ End_Line;
+
+ Write_Str
+ ("| including your customer number #nnn " &
+ "in the subject line.");
End_Line;
end if;
" and us to track the bug.");
End_Line;
- if not (Is_Public_Version or Is_FSF_Version) then
- Write_Str
- ("| Include your customer number #nnn " &
- "in the subject line.");
- End_Line;
- end if;
-
Write_Str
("| Include the entire contents of this bug " &
"box in the report.");
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
Set_Is_Character_Type (Standard_Wide_Wide_Character);
Set_Is_Known_Valid (Standard_Wide_Wide_Character);
Set_Size_Known_At_Compile_Time (Standard_Wide_Wide_Character);
- Set_Is_Ada_2005 (Standard_Wide_Wide_Character);
+ Set_Is_Ada_2005_Only (Standard_Wide_Wide_Character);
-- Create the bounds for type Wide_Wide_Character
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node);
- Set_Ekind (Standard_Wide_Wide_String, E_String_Type);
- Set_Etype (Standard_Wide_Wide_String,
- Standard_Wide_Wide_String);
- Set_Component_Type (Standard_Wide_Wide_String,
- Standard_Wide_Wide_Character);
- Set_Component_Size (Standard_Wide_Wide_String, Uint_32);
- Init_Size_Align (Standard_Wide_Wide_String);
- Set_Is_Ada_2005 (Standard_Wide_Wide_String);
+ Set_Ekind (Standard_Wide_Wide_String, E_String_Type);
+ Set_Etype (Standard_Wide_Wide_String,
+ Standard_Wide_Wide_String);
+ Set_Component_Type (Standard_Wide_Wide_String,
+ Standard_Wide_Wide_Character);
+ Set_Component_Size (Standard_Wide_Wide_String, Uint_32);
+ Init_Size_Align (Standard_Wide_Wide_String);
+ Set_Is_Ada_2005_Only (Standard_Wide_Wide_String);
-- Set index type of Wide_Wide_String
#elif defined (__hpux__) || defined (sun) \
|| (defined (__mips) && defined (__sgi)) \
|| (defined (__vxworks) && ! defined (__RTP__)) \
- || defined (_AIX)
+ || defined (_AIX) || defined (__Lynx__)
/* On Solaris, HP-UX and IRIX there is no function to clear an environment
variable. So we look for the variable in the environ table and delete it
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- 1-2-...-7-8 9-10-...15-16 17-18-19-20-x-x-x-x x-x-x-x-x-x-x-x
- -- and now, we do indeed have the same representation. The special flag
- -- Is_Left_Justified_Modular is set in the modular type used as the
- -- packed array type in the big-endian case to ensure that this required
- -- left justification occurs.
+ -- and now, we do indeed have the same representation for the memory
+ -- version in the constrained and unconstrained cases.
-----------------
-- Subprograms --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
return Make_TSS_Name (Typ, TSS_Init_Proc);
end Make_Init_Proc_Name;
- -------------------------
- -- Make_TSS_Name_Local --
- -------------------------
+ -------------------
+ -- Make_TSS_Name --
+ -------------------
- function Make_TSS_Name_Local
+ function Make_TSS_Name
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Name_Id
is
begin
Get_Name_String (Chars (Typ));
- Add_Char_To_Name_Buffer ('_');
- Add_Nat_To_Name_Buffer (Increment_Serial_Number);
Add_Char_To_Name_Buffer (Nam (1));
Add_Char_To_Name_Buffer (Nam (2));
return Name_Find;
- end Make_TSS_Name_Local;
+ end Make_TSS_Name;
- -------------------
- -- Make_TSS_Name --
- -------------------
+ -------------------------
+ -- Make_TSS_Name_Local --
+ -------------------------
- function Make_TSS_Name
+ function Make_TSS_Name_Local
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Name_Id
is
begin
Get_Name_String (Chars (Typ));
+ Add_Char_To_Name_Buffer ('_');
+ Add_Nat_To_Name_Buffer (Increment_Serial_Number);
Add_Char_To_Name_Buffer (Nam (1));
Add_Char_To_Name_Buffer (Nam (2));
return Name_Find;
- end Make_TSS_Name;
+ end Make_TSS_Name_Local;
--------------
-- Same_TSS --
* *
* C Header File *
* *
- * Copyright (C) 1992-2005, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2006, 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- *
#define No_Exception_Handlers_Set restrict__no_exception_handlers_set
#define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc
#define Check_Elaboration_Code_Allowed restrict__check_elaboration_code_allowed
-#define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc
extern Boolean No_Exception_Handlers_Set (void);
extern void Check_No_Implicit_Heap_Alloc (Node_Id);
extern void Check_Elaboration_Code_Allowed (Node_Id);
-extern void Check_No_Implicit_Heap_Alloc (Node_Id);
/* sem_elim: */
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2006, 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- --
Last_In_Table := 0;
end Empty_Tables;
+ ---------------
+ -- Find_Name --
+ ---------------
+
+ function Find_Name return Name_Id is
+ begin
+ if Name_Buffer (1 .. Name_Len) = "/" then
+ return Error_Name;
+
+ else
+ return Name_Find;
+ end if;
+ end Find_Name;
+
--------------
-- Get_Line --
--------------
end if;
end Get_Line;
- ---------------
- -- Find_Name --
- ---------------
-
- function Find_Name return Name_Id is
- begin
- if Name_Buffer (1 .. Name_Len) = "/" then
- return Error_Name;
-
- else
- return Name_Find;
- end if;
- end Find_Name;
-
----------------------
-- Report_Truncated --
----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2005, AdaCore --
+-- Copyright (C) 2003-2006, AdaCore --
-- --
-- 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- --
-- Protected type Mailbox has the following inherited interface:
- -- entry Insert (Item : in Message_Reference);
+ -- entry Insert (Item : Message_Reference);
-- Insert Item into the Mailbox. Blocks caller
-- until space is available.
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005, AdaCore --
+-- Copyright (C) 2001-2006, AdaCore --
-- --
-- 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- --
Data : constant String := Metavariable (Query_String);
begin
Current_Method := Get;
+
if Data /= "" then
Set_Parameter_Table (Data);
end if;
---------------------
function Get_Environment (Variable_Name : String) return String is
- Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name);
+ Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name);
Result : constant String := Value.all;
-
begin
OS_Lib.Free (Value);
return Result;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2005, AdaCore --
+-- Copyright (C) 2000-2006, AdaCore --
-- --
-- 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- --
-- procedure New_Client is
-- use GNAT;
--- procedure Add_Client_To_Database (Name : in String) is
+-- procedure Add_Client_To_Database (Name : String) is
-- begin
-- ...
-- end Add_Client_To_Database;
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2006, 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- --
procedure Setexv (
Status : out Cond_Value_Type;
- Vector : in Unsigned_Longword := 0;
- Addres : in Address := Address_Zero;
- Acmode : in Access_Mode_Type := Access_Mode_Zero;
- Prvhnd : in Unsigned_Longword := 0);
+ Vector : Unsigned_Longword := 0;
+ Addres : Address := Address_Zero;
+ Acmode : Access_Mode_Type := Access_Mode_Zero;
+ Prvhnd : Unsigned_Longword := 0);
pragma Interface (External, Setexv);
pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV",
(Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type,
Unsigned_Longword),
(Value, Value, Value, Value, Value));
- procedure Lib_Signal (I : in Integer);
+ procedure Lib_Signal (I : Integer);
pragma Interface (C, Lib_Signal);
pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value));
begin
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2005, AdaCore --
+-- Copyright (C) 2002-2006, AdaCore --
-- --
-- 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- --
Pipe1 : in out Pipe_Type;
Pipe2 : in out Pipe_Type;
Pipe3 : in out Pipe_Type;
- Cmd : in String;
- Args : in System.Address)
+ Cmd : String;
+ Args : System.Address)
is
pragma Warnings (Off, Pid);
-- position selection plus Pos. Once this routine is called, reduced
-- words are sorted by subsets and each item (First, Last) in Sets
-- defines the range of identical keys.
+ -- Need comment saying exactly what Last is ???
function Count_Different_Keys
(Table : Vertex_Table_Type;
Last : in out Natural;
Pos : Natural)
is
- S : constant Vertex_Table_Type := Table (1 .. Last);
+ S : constant Vertex_Table_Type := Table (Table'First .. Last);
C : constant Natural := Pos;
- -- Shortcuts
+ -- Shortcuts (why are these not renames ???)
F : Integer;
L : Integer;
Operand : Pointer;
Greedy : Boolean := True)
is
- Dest : constant Pointer := Emit_Ptr;
- Old : Pointer;
- Size : Pointer := 3;
+ Dest : constant Pointer := Emit_Ptr;
+ Old : Pointer;
+ Size : Pointer := 3;
+
+ Discard : Pointer;
+ pragma Warnings (Off, Discard);
begin
-- If not greedy, we have to emit another opcode first
Link_Tail (Old, Old + 3);
end if;
- Old := Emit_Node (Op);
+ Discard := Emit_Node (Op);
Emit_Ptr := Dest + Size;
end Insert_Operator;
-----------
procedure Match
- (Self : Pattern_Matcher;
- Data : String;
- Matches : out Match_Array;
+ (Self : Pattern_Matcher;
+ Data : String;
+ Matches : out Match_Array;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
is
- Program : Program_Data renames Self.Program; -- Shorter notation
+ pragma Assert (Matches'First = 0);
+
+ Program : Program_Data renames Self.Program; -- Shorter notation
First_In_Data : constant Integer := Integer'Max (Data_First, Data'First);
Last_In_Data : constant Integer := Integer'Min (Data_Last, Data'Last);
-- Global work variables
- Input_Pos : Natural; -- String-input pointer
- BOL_Pos : Natural; -- Beginning of input, for ^ check
+ Input_Pos : Natural; -- String-input pointer
+ BOL_Pos : Natural; -- Beginning of input, for ^ check
Matched : Boolean := False; -- Until proven True
Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count,
-- S p e c --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1996-2005, AdaCore --
+-- Copyright (C) 1996-2006, AdaCore --
-- --
-- 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- --
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last);
-- Match Data using the given pattern matcher and store result in Matches.
- -- The expression matches if Matches (0) /= No_Match.
+ -- The expression matches if Matches (0) /= No_Match. The lower bound of
+ -- Matches is required to be zero.
--
-- At most Matches'Length parenthesis are returned
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2005 AdaCore --
+-- Copyright (C) 1998-2006 AdaCore --
-- --
-- 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- --
T : Tasking.Task_Id;
use type Tasking.Task_Id;
+ use type System.OS_Interface.Thread_Id;
begin
STPO.Lock_RTS;
-- --
-- B o d y --
-- --
--- Copyright (C) 2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2006, 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- --
procedure Symbolize
(Status : out Cond_Value_Type;
- Current_PC : in Address;
+ Current_PC : Address;
Filename_Name : out Address;
Library_Name : out Address;
Record_Number : out Integer;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
end if;
end Digits_From_Size;
+ -----------------------------
+ -- Get_Max_Unaligned_Field --
+ -----------------------------
+
+ function Get_Max_Unaligned_Field return Pos is
+ begin
+ return 64; -- Can be different on some targets (e.g., AAMP)
+ end Get_Max_Unaligned_Field;
+
---------------------
-- Width_From_Size --
---------------------
end if;
end Width_From_Size;
- -----------------------------
- -- Get_Max_Unaligned_Field --
- -----------------------------
-
- function Get_Max_Unaligned_Field return Pos is
- begin
- return 64; -- Can be different on some targets (e.g., AAMP)
- end Get_Max_Unaligned_Field;
-
end Get_Targ;
procedure Scan_Bind_Arg (Argv : String);
-- Scan and process binder specific arguments. Argv is a single argument.
-- All the one character arguments are still handled by Switch. This
- -- routine handles -aO -aI and -I-.
+ -- routine handles -aO -aI and -I-. The lower bound of Argv must be 1.
function Is_Cross_Compiler return Boolean;
-- Returns True iff this is a cross-compiler
-------------------
procedure Scan_Bind_Arg (Argv : String) is
+ pragma Assert (Argv'First = 1);
+
begin
-- Now scan arguments that are specific to the binder and are not
-- handled by the common circuitry in Switch.
Scan_Args : while Next_Arg < Arg_Count loop
declare
Next_Argv : String (1 .. Len_Arg (Next_Arg));
-
begin
Fill_Arg (Next_Argv'Address, Next_Arg);
Scan_Bind_Arg (Next_Argv);
end;
+
Next_Arg := Next_Arg + 1;
end loop Scan_Args;
-- Output usage if requested
if Usage_Requested then
- Bindusg;
+ Bindusg.Display;
end if;
-- Check that the Ada binder file specified has extension .adb and that
-- Output usage information if no files
if not More_Lib_Files then
- Bindusg;
+ Bindusg.Display;
Exit_Program (E_Fatal);
end if;
-- Set standard configuration parameters
- Suppress_Standard_Library_On_Target := True;
- Configurable_Run_Time_Mode := True;
+ Suppress_Standard_Library_On_Target := True;
+ Configurable_Run_Time_Mode := True;
end if;
-- For main ALI files, even if they are interfaces, we get their
end loop;
Close (File);
+
+ exception
+ when Name_Error =>
+ Raise_Exception
+ (Syntax_Error'Identity,
+ "list-of-files file " & List_Filename & " not found.");
end Add_Files_From_List;
-- Start of processing for Parse_Command_Line
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
end loop;
Comp_Unit := Parent (Pack);
-
while Present (Comp_Unit)
and then Nkind (Comp_Unit) /= N_Compilation_Unit
loop
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
Set_Etype (I_Typ, T);
Init_Size_Align (I_Typ);
Set_Depends_On_Private (I_Typ, Depends_On_Private (T));
- Set_Is_Public (I_Typ, Is_Public (T));
- Set_From_With_Type (I_Typ, From_With_Type (T));
+ Set_Is_Public (I_Typ, Is_Public (T));
+ Set_From_With_Type (I_Typ, From_With_Type (T));
Set_Is_Access_Constant (I_Typ, Is_Access_Constant (T));
- Set_Is_Generic_Type (I_Typ, Is_Generic_Type (T));
- Set_Is_Volatile (I_Typ, Is_Volatile (T));
- Set_Treat_As_Volatile (I_Typ, Treat_As_Volatile (T));
- Set_Is_Atomic (I_Typ, Is_Atomic (T));
- Set_Is_Ada_2005 (I_Typ, Is_Ada_2005 (T));
+ Set_Is_Generic_Type (I_Typ, Is_Generic_Type (T));
+ Set_Is_Volatile (I_Typ, Is_Volatile (T));
+ Set_Treat_As_Volatile (I_Typ, Treat_As_Volatile (T));
+ Set_Is_Atomic (I_Typ, Is_Atomic (T));
+ Set_Is_Ada_2005_Only (I_Typ, Is_Ada_2005_Only (T));
Set_Can_Never_Be_Null (I_Typ);
return I_Typ;
Ada
; Documented for C
+Woverlength-strings
+Ada
+; Documented for C
+
nostdinc
Ada RejectNegative
; Don't look for source files
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, 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- --
Finish : Natural := Argv'Last;
Equal_Pos : Natural;
+ pragma Assert (Argv'First = 1);
+ pragma Assert (Argv (1 .. 2) = "-X");
+
begin
if Argv'Last < 5 then
return False;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
if not Success then
declare
Base_Name : constant String :=
- Directory_Operations.Base_Name (Alis (1).all, ".ali");
+ Directory_Operations.Base_Name (Alis (Alis'First).all, ".ali");
begin
OS_Lib.Delete_File ("b~" & Base_Name & ".ads", Success);
OS_Lib.Delete_File ("b~" & Base_Name & ".adb", Success);
raise;
end Ada_Build_Non_Reloc_DLL;
+ -- Start of processing for Build_Dynamic_Library
+
begin
-- On Windows the binder file must not be in the first position in the
-- list. This is due to the way DLL's are built on Windows. We swap the
if L_Afiles'Length > 1 then
declare
Filename : constant String :=
- Directory_Operations.Base_Name (L_Afiles (1).all);
+ Directory_Operations.Base_Name
+ (L_Afiles (L_Afiles'First).all);
First : constant Positive := Filename'First;
begin
if Filename (First .. First + 1) = "b~" then
- L_Afiles (L_Afiles'Last) := Afiles (1);
- L_Afiles (1) := Afiles (Afiles'Last);
+ L_Afiles (L_Afiles'Last) := Afiles (Afiles'First);
+ L_Afiles (L_Afiles'First) := Afiles (Afiles'Last);
end if;
end;
end if;
(Lib_Filename : String;
Def_Filename : String)
is
-
procedure Build_Import_Library (Lib_Filename : String);
-- Build an import library. This is to build only a .a library to link
-- against a DLL.
-- convention and we try as much as possible to follow the platform
-- convention.
- if Lib_Filename'Length > 3 and then Lib_Filename (1 .. 3) = "lib" then
- Build_Import_Library (Lib_Filename (4 .. Lib_Filename'Last));
+ if Lib_Filename'Length > 3
+ and then
+ Lib_Filename (Lib_Filename'First .. Lib_Filename'First + 2) = "lib"
+ then
+ Build_Import_Library
+ (Lib_Filename (Lib_Filename'First + 3 .. Lib_Filename'Last));
else
Build_Import_Library (Lib_Filename);
end if;
-- --
-- T e m p l a t e --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2006 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- --
package body Osint.B is
- Binder_Output_Time_Stamps_Set : Boolean := False;
-
- Old_Binder_Output_Time_Stamp : Time_Stamp_Type;
- New_Binder_Output_Time_Stamp : Time_Stamp_Type;
- Recording_Time_From_Last_Bind : Boolean := False;
-
-------------------------
-- Close_Binder_Output --
-------------------------
Get_Name_String (Output_File_Name));
end if;
- if Recording_Time_From_Last_Bind then
- New_Binder_Output_Time_Stamp := File_Stamp (Output_File_Name);
- Binder_Output_Time_Stamps_Set := True;
- end if;
end Close_Binder_Output;
--------------------------
Bfile := Name_Find;
- if Recording_Time_From_Last_Bind then
- Old_Binder_Output_Time_Stamp := File_Stamp (Bfile);
- end if;
-
Create_File_And_Check (Output_FD, Text);
end Create_Binder_Output;
function Next_Main_Lib_File return File_Name_Type renames Next_Main_File;
- --------------------------------
- -- Record_Time_From_Last_Bind --
- --------------------------------
-
- procedure Record_Time_From_Last_Bind is
- begin
- Recording_Time_From_Last_Bind := True;
- end Record_Time_From_Last_Bind;
-
- -------------------------
- -- Time_From_Last_Bind --
- -------------------------
-
- function Time_From_Last_Bind return Nat is
- Old_Y : Nat;
- Old_M : Nat;
- Old_D : Nat;
- Old_H : Nat;
- Old_Mi : Nat;
- Old_S : Nat;
- New_Y : Nat;
- New_M : Nat;
- New_D : Nat;
- New_H : Nat;
- New_Mi : Nat;
- New_S : Nat;
-
- type Month_Data is array (Int range 1 .. 12) of Int;
- Cumul : constant Month_Data := (0, 0, 3, 3, 4, 4, 5, 5, 5, 6, 6, 7);
- -- Represents the difference in days from a period compared to the
- -- same period if all months had 31 days, i.e:
- --
- -- Cumul (m) = 31x(m-1) - (number of days from 01/01 to m/01)
-
- Res : Int;
-
- begin
- if not Recording_Time_From_Last_Bind
- or else not Binder_Output_Time_Stamps_Set
- or else Old_Binder_Output_Time_Stamp = Empty_Time_Stamp
- then
- return Nat'Last;
- end if;
-
- Split_Time_Stamp
- (Old_Binder_Output_Time_Stamp,
- Old_Y, Old_M, Old_D, Old_H, Old_Mi, Old_S);
-
- Split_Time_Stamp
- (New_Binder_Output_Time_Stamp,
- New_Y, New_M, New_D, New_H, New_Mi, New_S);
-
- Res := New_Mi - Old_Mi;
-
- -- 60 minutes in an hour
-
- Res := Res + 60 * (New_H - Old_H);
-
- -- 24 hours in a day
-
- Res := Res + 60 * 24 * (New_D - Old_D);
-
- -- Almost 31 days in a month
-
- Res := Res + 60 * 24 *
- (31 * (New_M - Old_M) - Cumul (New_M) + Cumul (Old_M));
-
- -- 365 days in a year
-
- Res := Res + 60 * 24 * 365 * (New_Y - Old_Y);
-
- return Res;
- end Time_From_Last_Bind;
-
-----------------------
-- Write_Binder_Info --
-----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2006 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- --
package Osint.B is
- procedure Record_Time_From_Last_Bind;
- -- Trigger the computing of the time from the last bind of the same
- -- program.
-
function More_Lib_Files return Boolean;
-- Indicates whether more library information files remain to be processed.
-- Returns False right away if no source files, or if all source files
-- called only if a previous call to More_Lib_Files returned True). This
-- name is the simple name, excluding any directory information.
- function Time_From_Last_Bind return Nat;
- -- This function give an approximate number of minute from the last bind.
- -- It bases its computation on file stamp and therefore does gibe not
- -- any meaningful result before the new output binder file is written.
- -- So it returns Nat'last if:
- --
- -- - it is the first bind of this specific program
- -- - Record_Time_From_Last_Bind was not Called first
- -- - Close_Binder_Output was not called first
- --
- -- otherwise it returns the number of minutes from the last bind. The
- -- computation does not try to be completely accurate and in particular
- -- does not take leap years into account.
-
-------------------
-- Binder Output --
-------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
Special_Output_Proc := null;
end Cancel_Special_Output;
+ ------------
+ -- Column --
+ ------------
+
+ function Column return Pos is
+ begin
+ return Pos (Next_Col);
+ end Column;
+
------------------
-- Flush_Buffer --
------------------
end if;
end Flush_Buffer;
- ------------
- -- Column --
- ------------
-
- function Column return Pos is
- begin
- return Pos (Next_Col);
- end Column;
-
---------------------------
-- Restore_Output_Buffer --
---------------------------
Write_Eol;
end if;
- Buffer (Next_Col) := C;
- Next_Col := Next_Col + 1;
+ if C = ASCII.LF then
+ Write_Eol;
+ else
+ Buffer (Next_Col) := C;
+ Next_Col := Next_Col + 1;
+ end if;
end Write_Char;
---------------
Write_Eol;
end Write_Line;
+ ------------------
+ -- Write_Spaces --
+ ------------------
+
+ procedure Write_Spaces (N : Nat) is
+ begin
+ for J in 1 .. N loop
+ Write_Char (' ');
+ end loop;
+ end Write_Spaces;
+
---------------
-- Write_Str --
---------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- Write an integer value with no leading blanks or zeroes. Negative
-- values are preceded by a minus sign).
+ procedure Write_Spaces (N : Nat);
+ -- Write N spaces
+
procedure Write_Str (S : String);
-- Write a string of characters to the standard output file. Note that
- -- end of line is handled separately using WRITE_EOL, so the string
- -- should not contain either of the characters LF or CR, but it may
- -- contain horizontal tab characters.
+ -- end of line is normally handled separately using WRITE_EOL, but it
+ -- is allowed for the string to contain LF (but not CR) characters,
+ -- which are properly interpreted as end of line characters. The string
+ -- may also contain horizontal tab characters.
procedure Write_Line (S : String);
-- Equivalent to Write_Str (S) followed by Write_Eol;
-- names, precisely to make sure that they are only used for debugging!
procedure w (C : Character);
- -- Dump quote, character quote, followed by line return
+ -- Dump quote, character, quote, followed by line return
procedure w (S : String);
-- Dump string followed by line return
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2006, 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- --
-- The type to refers to an attribute, self-initialized
Empty_Attribute : constant Attribute_Node_Id;
- -- Indicates no attribute. Default value of Attribute_Node_Id objects.
+ -- Indicates no attribute. Default value of Attribute_Node_Id objects
Attribute_First : constant Attribute_Node_Id;
-- First attribute node id of project level attributes
----------------
Attributes_Initial : constant := 50;
- Attributes_Increment : constant := 50;
+ Attributes_Increment : constant := 100;
Attribute_Node_Low_Bound : constant := 0;
Attribute_Node_High_Bound : constant := 099_999_999;
--------------
Packages_Initial : constant := 10;
- Packages_Increment : constant := 50;
+ Packages_Increment : constant := 100;
Package_Node_Low_Bound : constant := 0;
Package_Node_High_Bound : constant := 099_999_999;
----------------------------
procedure Expand_AST_Packet_Pool
- (Requested_Packets : in Natural;
+ (Requested_Packets : Natural;
Actual_Number : out Natural;
Total_Number : out Natural)
is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2006, AdaCore --
-- --
-- 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- --
Iterator_Started : Boolean := False;
function Get_Non_Null return Elmt_Ptr;
- -- Returns Null_Ptr if Iterator_Started is false of the Table is
- -- empty. Returns Iterator_Ptr if non null, or the next non null
- -- element in table if any.
+ -- Returns Null_Ptr if Iterator_Started is false or the Table is empty.
+ -- Returns Iterator_Ptr if non null, or the next non null element in
+ -- table if any.
---------
-- Get --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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 Image_Decimal
(V : Integer;
- Scale : Integer)
- return String
+ Scale : Integer) return String
is
P : Natural := 0;
S : String (1 .. 64);
Aft : Natural;
Exp : Natural)
is
- Minus : constant Boolean := (Digs (1) = '-');
+ Minus : constant Boolean := (Digs (Digs'First) = '-');
-- Set True if input is negative
- Zero : Boolean := (Digs (2) = '0');
+ Zero : Boolean := (Digs (Digs'First + 1) = '0');
-- Set True if input is exactly zero (only case when a leading zero
-- is permitted in the input string given to this procedure). This
-- flag can get set later if rounding causes the value to become zero.
-- The result is zero, unless we are rounding just before
-- the first digit, and the first digit is five or more.
- if N = 1 and then Digs (2) >= '5' then
- Digs (1) := '1';
+ if N = 1 and then Digs (Digs'First + 1) >= '5' then
+ Digs (Digs'First) := '1';
else
- Digs (1) := '0';
+ Digs (Digs'First) := '0';
Zero := True;
end if;
-- OK, because we already captured the value of the sign and
-- we are in any case destroying the value in the Digs buffer
- Digs (1) := '1';
+ Digs (Digs'First) := '1';
FD := 1;
ND := ND + 1;
Digits_Before_Point := Digits_Before_Point + 1;
end loop;
- -- Setup the masks to be exported.
+ -- Setup the masks to be exported
Result := sigemptyset (mask'Access);
pragma Assert (Result = 0);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
Outputs : Asm_Output_Operand_List;
Inputs : Asm_Input_Operand_List;
Clobber : String := "";
- Volatile : Boolean := False)
- return Asm_Insn;
+ Volatile : Boolean := False) return Asm_Insn;
function Asm (
Template : String;
type Asm_Output_Operand is new Integer;
type Asm_Insn is new Integer;
-- All three of these types are dummy types, to meet the requirements of
- -- type consistenty. No values of these types are ever referenced.
+ -- type consistency. No values of these types are ever referenced.
No_Input_Operands : constant Asm_Input_Operand := 0;
No_Output_Operands : constant Asm_Output_Operand := 0;
-- B o d y --
-- (Version for Alpha/VMS) --
-- --
--- Copyright (C) 2001-2005, AdaCore --
+-- Copyright (C) 2001-2006, AdaCore --
-- --
-- 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 Get_Code_Loc (M : Machine_State) return Code_Loc is
procedure Get_Invo_Context (
Result : out Unsigned_Longword; -- return value
- Invo_Handle : in Invo_Handle_Type;
+ Invo_Handle : Invo_Handle_Type;
Invo_Context : out Invo_Context_Blk_Type);
pragma Interface (External, Get_Invo_Context);
procedure Pop_Frame (M : Machine_State) is
procedure Get_Prev_Invo_Handle (
Result : out Invo_Handle_Type; -- return value
- ICB : in Invo_Handle_Type);
+ ICB : Invo_Handle_Type);
pragma Interface (External, Get_Prev_Invo_Handle);
procedure Get_Invo_Handle (
Result : out Invo_Handle_Type; -- return value
- Invo_Context : in Invo_Context_Blk_Type);
+ Invo_Context : Invo_Context_Blk_Type);
pragma Interface (External, Get_Invo_Handle);
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2006, 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- --
-- --
------------------------------------------------------------------------------
--- This is the default implementation of this package.
+-- This is the default implementation of this package
-- This implementation assumes that the underlying malloc/free/realloc
-- implementation is thread safe, and thus, no additional lock is required.
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2006, 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- --
subtype PSZ is Interfaces.C.Strings.chars_ptr;
subtype PCHAR is Interfaces.C.Strings.chars_ptr;
+
subtype PVOID is System.Address;
Null_Void : constant PVOID := System.Null_Address;
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2006 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- --
procedure Sys_Schdwk
(
Status : out Cond_Value_Type;
- Pidadr : in Address := Null_Address;
- Prcnam : in String := String'Null_Parameter;
- Daytim : in Long_Integer;
- Reptim : in Long_Integer := Long_Integer'Null_Parameter
+ Pidadr : Address := Null_Address;
+ Prcnam : String := String'Null_Parameter;
+ Daytim : Long_Integer;
+ Reptim : Long_Integer := Long_Integer'Null_Parameter
);
pragma Interface (External, Sys_Schdwk);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- Allocate a secondary stack for the main program to use
-- We make sure that the stack has maximum alignment. Some systems require
- -- this (e.g. Sun), and in any case it is a good idea for efficiency.
+ -- this (e.g. Sparc), and in any case it is a good idea for efficiency.
Stack : aliased Stack_Id;
for Stack'Alignment use Standard'Maximum_Alignment;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- This is currently only used under VMS.
NT_TSD : TSD;
- -- Note: we rely on the default initialization of NT_TSD.
+ -- Note: we rely on the default initialization of NT_TSD
--------------------
-- Abort_Defer_NT --
null;
end Task_Lock_NT;
- --------------------
- -- Task_Unlock_NT --
- --------------------
+ ------------------
+ -- Task_Name_NT --
+ -------------------
- procedure Task_Unlock_NT is
+ function Task_Name_NT return String is
begin
- null;
- end Task_Unlock_NT;
+ return "main_task";
+ end Task_Name_NT;
-------------------------
-- Task_Termination_NT --
null;
end Task_Termination_NT;
+ --------------------
+ -- Task_Unlock_NT --
+ --------------------
+
+ procedure Task_Unlock_NT is
+ begin
+ null;
+ end Task_Unlock_NT;
+
-------------------------
-- Update_Exception_NT --
-------------------------
Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
end Update_Exception_NT;
- ------------------
- -- Task_Name_NT --
- -------------------
-
- function Task_Name_NT return String is
- begin
- return "main_task";
- end Task_Name_NT;
-
end System.Soft_Links;
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
type Storage_Offset is range
-(2 ** (Integer'(Standard'Address_Size) - 1)) ..
+(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1);
+ -- Note: the reason for the Long_Long_Integer qualification here is to
+ -- avoid a bogus ambiguity when this unit is analyzed in an rtsfind
+ -- context. It may be possible to remove this in the future, but it is
+ -- certainly harmless in any case ???
subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last;
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2006, Free Software Foundation, Inc. --
-- --
-- GARLIC 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- --
-- W_AD --
----------
- procedure W_AD (Stream : not null access RST; Item : in Fat_Pointer) is
+ procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is
S : XDR_S_TM;
U : XDR_TM;
-- W_AS --
----------
- procedure W_AS (Stream : not null access RST; Item : in Thin_Pointer) is
+ procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is
S : XDR_S_TM;
U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1));
-- W_B --
---------
- procedure W_B (Stream : not null access RST; Item : in Boolean) is
+ procedure W_B (Stream : not null access RST; Item : Boolean) is
begin
if Item then
W_SSU (Stream, 1);
-- W_C --
---------
- procedure W_C (Stream : not null access RST; Item : in Character) is
+ procedure W_C (Stream : not null access RST; Item : Character) is
S : XDR_S_C;
pragma Assert (C_L = 1);
-- W_F --
---------
- procedure W_F (Stream : not null access RST; Item : in Float) is
+ procedure W_F (Stream : not null access RST; Item : Float) is
I : constant Precision := Single;
E_Size : Integer renames Fields (I).E_Size;
E_Bias : Integer renames Fields (I).E_Bias;
-- W_I --
---------
- procedure W_I (Stream : not null access RST; Item : in Integer) is
+ procedure W_I (Stream : not null access RST; Item : Integer) is
S : XDR_S_I;
U : XDR_U;
-- W_LF --
----------
- procedure W_LF (Stream : not null access RST; Item : in Long_Float) is
+ procedure W_LF (Stream : not null access RST; Item : Long_Float) is
I : constant Precision := Double;
E_Size : Integer renames Fields (I).E_Size;
E_Bias : Integer renames Fields (I).E_Bias;
-- W_LI --
----------
- procedure W_LI (Stream : not null access RST; Item : in Long_Integer) is
+ procedure W_LI (Stream : not null access RST; Item : Long_Integer) is
S : XDR_S_LI;
U : Unsigned;
X : Long_Unsigned;
-- W_LLF --
-----------
- procedure W_LLF (Stream : not null access RST; Item : in Long_Long_Float) is
+ procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is
I : constant Precision := Quadruple;
E_Size : Integer renames Fields (I).E_Size;
E_Bias : Integer renames Fields (I).E_Bias;
-----------
procedure W_LLI (Stream : not null access RST;
- Item : in Long_Long_Integer)
+ Item : Long_Long_Integer)
is
S : XDR_S_LLI;
U : Unsigned;
-----------
procedure W_LLU (Stream : not null access RST;
- Item : in Long_Long_Unsigned) is
+ Item : Long_Long_Unsigned) is
S : XDR_S_LLU;
U : Unsigned;
X : Long_Long_Unsigned := Item;
-- W_LU --
----------
- procedure W_LU (Stream : not null access RST; Item : in Long_Unsigned) is
+ procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is
S : XDR_S_LU;
U : Unsigned;
X : Long_Unsigned := Item;
-- W_SF --
----------
- procedure W_SF (Stream : not null access RST; Item : in Short_Float) is
+ procedure W_SF (Stream : not null access RST; Item : Short_Float) is
I : constant Precision := Single;
E_Size : Integer renames Fields (I).E_Size;
E_Bias : Integer renames Fields (I).E_Bias;
-- W_SI --
----------
- procedure W_SI (Stream : not null access RST; Item : in Short_Integer) is
+ procedure W_SI (Stream : not null access RST; Item : Short_Integer) is
S : XDR_S_SI;
U : XDR_SU;
procedure W_SSI
(Stream : not null access RST;
- Item : in Short_Short_Integer)
+ Item : Short_Short_Integer)
is
S : XDR_S_SSI;
U : XDR_SSU;
procedure W_SSU
(Stream : not null access RST;
- Item : in Short_Short_Unsigned)
+ Item : Short_Short_Unsigned)
is
U : constant XDR_SSU := XDR_SSU (Item);
S : XDR_S_SSU;
-- W_SU --
----------
- procedure W_SU (Stream : not null access RST; Item : in Short_Unsigned) is
+ procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is
S : XDR_S_SU;
U : XDR_SU := XDR_SU (Item);
-- W_U --
---------
- procedure W_U (Stream : not null access RST; Item : in Unsigned) is
+ procedure W_U (Stream : not null access RST; Item : Unsigned) is
S : XDR_S_U;
U : XDR_U := XDR_U (Item);
-- W_WC --
----------
- procedure W_WC (Stream : not null access RST; Item : in Wide_Character) is
+ procedure W_WC (Stream : not null access RST; Item : Wide_Character) is
S : XDR_S_WC;
U : XDR_WC;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2006 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- --
-- Format_Trace --
------------------
- function Format_Trace (Source : in String) return String_Trace is
+ function Format_Trace (Source : String) return String_Trace is
Length : Integer := Source'Length;
Result : String_Trace := (others => ' ');
-- --
-- B o d y --
-- --
--- Copyright (C) 2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2006, 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- --
raise Constraint_Error;
end Get_WC_Encoding_Method;
+ function Get_WC_Encoding_Method (S : String) return WC_Encoding_Method is
+ begin
+ if S = "hex" then return WCEM_Hex;
+ elsif S = "upper" then return WCEM_Upper;
+ elsif S = "shift_jis" then return WCEM_Shift_JIS;
+ elsif S = "euc" then return WCEM_EUC;
+ elsif S = "utf8" then return WCEM_UTF8;
+ elsif S = "brackets" then return WCEM_Brackets;
+ else
+ raise Constraint_Error;
+ end if;
+ end Get_WC_Encoding_Method;
+
end System.WCh_Con;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- Given a character C, returns corresponding encoding method (see array
-- WC_Encoding_Letters above). Raises Constraint_Error if not in list.
+ function Get_WC_Encoding_Method (S : String) return WC_Encoding_Method;
+ -- Given a lower case string that is one of hex, upper, shift_jis, euc,
+ -- utf8, brackets, return the corresponding encoding method. Raises
+ -- Constraint_Error if not in list.
+
end System.WCh_Con;
procedure Error_Long_Line;
-- Signal error of excessively long line
- ---------------
- -- Post_Scan --
- ---------------
-
- procedure Post_Scan is
- begin
- case Token is
- when Tok_Char_Literal =>
- Token_Node := New_Node (N_Character_Literal, Token_Ptr);
- Set_Char_Literal_Value (Token_Node, UI_From_CC (Character_Code));
- Set_Chars (Token_Node, Token_Name);
-
- when Tok_Identifier =>
- Token_Node := New_Node (N_Identifier, Token_Ptr);
- Set_Chars (Token_Node, Token_Name);
-
- when Tok_Real_Literal =>
- Token_Node := New_Node (N_Real_Literal, Token_Ptr);
- Set_Realval (Token_Node, Real_Literal_Value);
-
- when Tok_Integer_Literal =>
- Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
- Set_Intval (Token_Node, Int_Literal_Value);
-
- when Tok_String_Literal =>
- Token_Node := New_Node (N_String_Literal, Token_Ptr);
- Set_Has_Wide_Character (Token_Node, Wide_Character_Found);
- Set_Strval (Token_Node, String_Literal_Id);
-
- when Tok_Operator_Symbol =>
- Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
- Set_Chars (Token_Node, Token_Name);
- Set_Strval (Token_Node, String_Literal_Id);
-
- when others =>
- null;
- end case;
- end Post_Scan;
-
-----------------------
-- Check_End_Of_Line --
-----------------------
Check_Restriction (No_Obsolescent_Features, New_Node (N_Empty, S));
end Obsolescent_Check;
+ ---------------
+ -- Post_Scan --
+ ---------------
+
+ procedure Post_Scan is
+ begin
+ case Token is
+ when Tok_Char_Literal =>
+ Token_Node := New_Node (N_Character_Literal, Token_Ptr);
+ Set_Char_Literal_Value (Token_Node, UI_From_CC (Character_Code));
+ Set_Chars (Token_Node, Token_Name);
+
+ when Tok_Identifier =>
+ Token_Node := New_Node (N_Identifier, Token_Ptr);
+ Set_Chars (Token_Node, Token_Name);
+
+ when Tok_Real_Literal =>
+ Token_Node := New_Node (N_Real_Literal, Token_Ptr);
+ Set_Realval (Token_Node, Real_Literal_Value);
+
+ when Tok_Integer_Literal =>
+ Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
+ Set_Intval (Token_Node, Int_Literal_Value);
+
+ when Tok_String_Literal =>
+ Token_Node := New_Node (N_String_Literal, Token_Ptr);
+ Set_Has_Wide_Character (Token_Node, Wide_Character_Found);
+ Set_Strval (Token_Node, String_Literal_Id);
+
+ when Tok_Operator_Symbol =>
+ Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
+ Set_Chars (Token_Node, Token_Name);
+ Set_Strval (Token_Node, String_Literal_Id);
+
+ when others =>
+ null;
+ end case;
+ end Post_Scan;
+
------------------------------
-- Scan_Reserved_Identifier --
------------------------------
Raises_CE : out Boolean;
Others_Present : out Boolean)
is
+ pragma Assert (Choice_Table'First = 1);
+
E : Entity_Id;
Enode : Node_Id;
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2006, 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- --
-- Subtyp is the subtype of the discrete choices. The type against
-- which the discrete choices must be resolved is its base type.
--
- -- On entry Choice_Table must be big enough to contain all the
- -- discrete choices encountered.
+ -- On entry Choice_Table must be big enough to contain all the discrete
+ -- choices encountered. The lower bound of Choice_Table must be one.
--
-- On exit Choice_Table contains all the static and non empty discrete
-- choices in sorted order. Last_Choice gives the position of the last
-- We scan past junk to the first interesting compilation unit
-- token, to see if it is SEPARATE. We ignore WITH keywords during
-- this and also PRIVATE. The reason for ignoring PRIVATE is that
- -- it handles some error situations, and also it is possible that
- -- a PRIVATE WITH feature might be approved some time in the future.
+ -- it handles some error situations, and also to handle PRIVATE WITH
+ -- in Ada 2005 mode.
while Token = Tok_With
or else Token = Tok_Private
-- We scan past junk to the first interesting compilation unit
-- token, to see if it is SEPARATE. We ignore WITH keywords during
-- this and also PRIVATE. The reason for ignoring PRIVATE is that
- -- it handles some error situations, and also it is possible that
- -- a PRIVATE WITH feature might be approved some time in the future.
+ -- it handles some error situations, and also to handle PRIVATE WITH
+ -- in Ada 2005 mode.
while Token = Tok_With
or else Token = Tok_Private
-- --
-- T e m p l a t e --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- by the synonym name. The starting location for a given node type is
-- found from the corresponding entry in the Pchars_Pos_Array.
- -- The following characters identify the field. These are characters
- -- which could never occur in a field name, so they also mark the
- -- end of the previous name.
+ -- The following characters identify the field. These are characters which
+ -- could never occur in a field name, so they also mark the end of the
+ -- previous name.
subtype Fchar is Character range '#' .. '9';
-- Note this table does not include entity field and flags whose access
-- functions are in Einfo (these are handled by the Print_Entity_Info
- -- procedure in Treepr, which uses the routines in Einfo to get the
- -- proper symbolic information). In addition, the following fields are
- -- handled by Treepr, and do not appear in the Pchars array:
+ -- procedure in Treepr, which uses the routines in Einfo to get the proper
+ -- symbolic information). In addition, the following fields are handled by
+ -- Treepr, and do not appear in the Pchars array:
-- Analyzed
-- Cannot_Be_Constant
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- digit of Vec contains the sign, all other digits are always non-
-- negative. Note that the input may be directly represented, and in
-- this case Vec will contain the corresponding one or two digit value.
+ -- The low bound of Vec is always 1.
function Least_Sig_Digit (Arg : Uint) return Int;
pragma Inline (Least_Sig_Digit);
procedure Init_Operand (UI : Uint; Vec : out UI_Vector) is
Loc : Int;
+ pragma Assert (Vec'First = Int'(1));
+
begin
if Direct (UI) then
Vec (1) := Direct_Val (UI);
Num : Nat;
begin
+ -- Largest negative number has to be handled specially, since it is in
+ -- Int_Range, but we cannot take the absolute value.
+
if Input = Uint_Int_First then
return Int'Size;
+ -- For any other number in Int_Range, get absolute value of number
+
elsif UI_Is_In_Int_Range (Input) then
Num := abs (UI_To_Int (Input));
Bits := 0;
+ -- If not in Int_Range then initialize bit count for all low order
+ -- words, and set number to high order digit.
+
else
Bits := Base_Bits * (Uints.Table (Input).Length - 1);
Num := abs (Udigits.Table (Uints.Table (Input).Loc));
end if;
+ -- Increase bit count for remaining value in Num
+
while Types.">" (Num, 0) loop
Num := Num / 2;
Bits := Bits + 1;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
return UR_10_36;
end Ureal_10_36;
- -------------------
- -- Ureal_M_10_36 --
- -------------------
+ ----------------
+ -- Ureal_2_80 --
+ ----------------
- function Ureal_M_10_36 return Ureal is
+ function Ureal_2_80 return Ureal is
begin
- return UR_M_10_36;
- end Ureal_M_10_36;
+ return UR_2_80;
+ end Ureal_2_80;
-----------------
-- Ureal_2_128 --
return UR_2_128;
end Ureal_2_128;
- ----------------
- -- Ureal_2_80 --
- ----------------
+ -------------------
+ -- Ureal_2_M_80 --
+ -------------------
- function Ureal_2_80 return Ureal is
+ function Ureal_2_M_80 return Ureal is
begin
- return UR_2_80;
- end Ureal_2_80;
+ return UR_2_M_80;
+ end Ureal_2_M_80;
-------------------
-- Ureal_2_M_128 --
return UR_2_M_128;
end Ureal_2_M_128;
- -------------------
- -- Ureal_2_M_80 --
- -------------------
-
- function Ureal_2_M_80 return Ureal is
- begin
- return UR_2_M_80;
- end Ureal_2_M_80;
-
----------------
-- Ureal_Half --
----------------
return UR_M_0;
end Ureal_M_0;
+ -------------------
+ -- Ureal_M_10_36 --
+ -------------------
+
+ function Ureal_M_10_36 return Ureal is
+ begin
+ return UR_M_10_36;
+ end Ureal_M_10_36;
+
-----------------
-- Ureal_Tenth --
-----------------
OSDN Git Service
