diff options
Diffstat (limited to 'gcc/ada')
72 files changed, 523 insertions, 511 deletions
diff --git a/gcc/ada/9drpc.adb b/gcc/ada/9drpc.adb index f8d36d3..75acad7 100644 --- a/gcc/ada/9drpc.adb +++ b/gcc/ada/9drpc.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -93,11 +93,11 @@ package body System.RPC is 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 @@ -153,8 +153,8 @@ package body System.RPC is -- 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 @@ -198,7 +198,7 @@ package body System.RPC is -- Debugging package procedure D - (Flag : in Debug_Level; Info : in String) renames Debugging.Debug; + (Flag : Debug_Level; Info : String) renames Debugging.Debug; -- Shortcut ------------------------ @@ -265,7 +265,7 @@ package body System.RPC is -- 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; @@ -375,7 +375,7 @@ package body System.RPC is 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; ----------------------- @@ -687,8 +687,8 @@ package body System.RPC is ---------------------------- 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 @@ -799,11 +799,11 @@ package body System.RPC is 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; diff --git a/gcc/ada/a-direio.ads b/gcc/ada/a-direio.ads index 29aef9c..24b2a0b 100644 --- a/gcc/ada/a-direio.ads +++ b/gcc/ada/a-direio.ads @@ -46,7 +46,7 @@ package Ada.Direct_IO is 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; diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index 6b3b802..98d823d 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -407,10 +407,13 @@ package body Exception_Data is ----------------------------------------- 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; --------------------------------------- diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb index 9bc7290..92ba21d 100644 --- a/gcc/ada/a-finali.adb +++ b/gcc/ada/a-finali.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -50,7 +50,6 @@ package body Ada.Finalization is procedure Adjust (Object : in out Controlled) is pragma Warnings (Off, Object); - begin null; end Adjust; @@ -61,14 +60,12 @@ package body Ada.Finalization is 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; @@ -79,14 +76,12 @@ package body Ada.Finalization is 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; diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads index c6b2b3e..eb3baaa 100644 --- a/gcc/ada/a-nudira.ads +++ b/gcc/ada/a-nudira.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -58,7 +58,7 @@ package Ada.Numerics.Discrete_Random is pragma Compile_Time_Warning (Result_Subtype'Size > 48, - "statistical properties not guaranteed for size '> 48"); + "statistical properties not guaranteed for size > 48"); -- Basic facilities diff --git a/gcc/ada/a-numeri.ads b/gcc/ada/a-numeri.ads index a0513d0..4d25bce 100644 --- a/gcc/ada/a-numeri.ads +++ b/gcc/ada/a-numeri.ads @@ -23,8 +23,8 @@ package Ada.Numerics is ["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; diff --git a/gcc/ada/a-sequio.ads b/gcc/ada/a-sequio.ads index a811d56..3953f11 100644 --- a/gcc/ada/a-sequio.ads +++ b/gcc/ada/a-sequio.ads @@ -46,7 +46,7 @@ package Ada.Sequential_IO is 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; diff --git a/gcc/ada/a-tienau.adb b/gcc/ada/a-tienau.adb index aadb479..a43c4cb 100644 --- a/gcc/ada/a-tienau.adb +++ b/gcc/ada/a-tienau.adb @@ -128,7 +128,7 @@ package body Ada.Text_IO.Enumeration_Aux is 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); @@ -167,7 +167,7 @@ package body Ada.Text_IO.Enumeration_Aux is 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); diff --git a/gcc/ada/a-tienio.adb b/gcc/ada/a-tienio.adb index 6ff484d..0c07103 100644 --- a/gcc/ada/a-tienio.adb +++ b/gcc/ada/a-tienio.adb @@ -61,7 +61,6 @@ package body Ada.Text_IO.Enumeration_IO is procedure Get (Item : out Enum) is pragma Unsuppress (Range_Check); - begin Get (Current_In, Item); end Get; @@ -98,7 +97,6 @@ package body Ada.Text_IO.Enumeration_IO is Set : Type_Set := Default_Setting) is Image : constant String := Enum'Image (Item); - begin Aux.Put (File, Image, Width, Set); end Put; @@ -118,7 +116,6 @@ package body Ada.Text_IO.Enumeration_IO is Set : Type_Set := Default_Setting) is Image : constant String := Enum'Image (Item); - begin Aux.Puts (To, Image, Set); end Put; diff --git a/gcc/ada/a-wtenau.adb b/gcc/ada/a-wtenau.adb index 0bba4ec..fcb4e1e 100644 --- a/gcc/ada/a-wtenau.adb +++ b/gcc/ada/a-wtenau.adb @@ -159,7 +159,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is 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); @@ -204,7 +204,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is 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) := diff --git a/gcc/ada/a-ztenau.adb b/gcc/ada/a-ztenau.adb index 01d996c..b7d2375 100644 --- a/gcc/ada/a-ztenau.adb +++ b/gcc/ada/a-ztenau.adb @@ -160,7 +160,7 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is 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); @@ -206,7 +206,7 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is 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) := diff --git a/gcc/ada/a-ztenio.adb b/gcc/ada/a-ztenio.adb index 4b95295..9591447 100644 --- a/gcc/ada/a-ztenio.adb +++ b/gcc/ada/a-ztenio.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -44,11 +44,9 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_IO is 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; @@ -64,11 +62,9 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_IO is 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; @@ -84,7 +80,6 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_IO is 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; @@ -104,7 +99,6 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_IO is Set : Type_Set := Default_Setting) is Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); - begin Aux.Puts (To, Image, Set); end Put; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 119cf62..1cdf5ae 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -2360,17 +2360,24 @@ package body Atree is 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; @@ -2381,9 +2388,7 @@ package body Atree is -- 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 @@ -2398,9 +2403,7 @@ package body Atree is -- 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 @@ -2439,39 +2442,36 @@ package body Atree is 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; @@ -2681,6 +2681,12 @@ package body Atree is 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); @@ -2843,6 +2849,12 @@ package body Atree is 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); @@ -2995,16 +3007,16 @@ package body Atree is 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 @@ -4647,6 +4659,12 @@ package body Atree is 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); @@ -4809,6 +4827,12 @@ package body Atree is 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); @@ -4908,11 +4932,11 @@ package body Atree is 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 diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 94618d9..80d531d 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -49,7 +49,7 @@ package Atree is -- 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 @@ -198,8 +198,8 @@ package Atree is -- 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; @@ -434,9 +434,9 @@ package Atree is 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 @@ -860,6 +860,9 @@ package Atree is 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); @@ -941,6 +944,9 @@ package Atree is 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); @@ -992,8 +998,8 @@ package Atree is 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); @@ -1785,6 +1791,9 @@ package Atree is 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); @@ -1866,6 +1875,9 @@ package Atree is 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); @@ -1917,8 +1929,8 @@ package Atree is 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); @@ -2832,8 +2844,7 @@ package Atree is -- 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 diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 77d430c..bc96b20 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -6,7 +6,7 @@ * * * 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- * @@ -382,6 +382,7 @@ extern Node_Id Current_Error_Node; #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) @@ -410,6 +411,7 @@ extern Node_Id Current_Error_Node; #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) @@ -429,7 +431,7 @@ extern Node_Id Current_Error_Node; #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) diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 59d0bd2..648c4b1 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -80,6 +80,9 @@ package body Comperr is -- 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 @@ -93,12 +96,14 @@ package body Comperr is 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 @@ -173,16 +178,16 @@ package body Comperr is 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); @@ -267,13 +272,23 @@ package body Comperr is " 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; @@ -290,7 +305,12 @@ package body Comperr is 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; @@ -299,13 +319,6 @@ package body Comperr is " 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."); diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index cbe5969..5f4b203 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -628,7 +628,7 @@ package body CStand is 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 @@ -743,14 +743,14 @@ package body CStand is 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 diff --git a/gcc/ada/env.c b/gcc/ada/env.c index 9465a3e..cbcd132 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -218,7 +218,7 @@ void __gnat_unsetenv (char *name) { #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 diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads index bd00459..a124ca6 100644 --- a/gcc/ada/exp_pakd.ads +++ b/gcc/ada/exp_pakd.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -201,10 +201,8 @@ package Exp_Pakd is -- 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 -- diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 78f975d..ad60e7a 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -238,37 +238,37 @@ package body Exp_Tss is 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 -- diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 4706d4c..6e2dde3 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -6,7 +6,7 @@ * * * 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- * @@ -167,12 +167,10 @@ extern Boolean Back_Annotate_Rep_Info; #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: */ diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index cb2e352..37e1002 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -200,6 +200,20 @@ package body Fmap is 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 -- -------------- @@ -236,20 +250,6 @@ package body Fmap is 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 -- ---------------------- diff --git a/gcc/ada/g-boumai.ads b/gcc/ada/g-boumai.ads index c3a0db5..bcadf34 100644 --- a/gcc/ada/g-boumai.ads +++ b/gcc/ada/g-boumai.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -71,7 +71,7 @@ package GNAT.Bounded_Mailboxes is -- 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. diff --git a/gcc/ada/g-cgi.adb b/gcc/ada/g-cgi.adb index 03bbeb4..34f3e4f 100644 --- a/gcc/ada/g-cgi.adb +++ b/gcc/ada/g-cgi.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -188,6 +188,7 @@ package body GNAT.CGI is Data : constant String := Metavariable (Query_String); begin Current_Method := Get; + if Data /= "" then Set_Parameter_Table (Data); end if; @@ -335,9 +336,8 @@ package body GNAT.CGI is --------------------- 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; diff --git a/gcc/ada/g-cgi.ads b/gcc/ada/g-cgi.ads index 6ad3d5f..eb7d70c 100644 --- a/gcc/ada/g-cgi.ads +++ b/gcc/ada/g-cgi.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -68,7 +68,7 @@ -- 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; diff --git a/gcc/ada/g-eacodu-vms.adb b/gcc/ada/g-eacodu-vms.adb index d2a8f39..9c0bceb 100644 --- a/gcc/ada/g-eacodu-vms.adb +++ b/gcc/ada/g-eacodu-vms.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -54,17 +54,17 @@ procedure Core_Dump (Occurrence : Exception_Occurrence) is 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 diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb index b37449f..2381c66 100644 --- a/gcc/ada/g-expect-vms.adb +++ b/gcc/ada/g-expect-vms.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1058,8 +1058,8 @@ package body GNAT.Expect is 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); diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb index cf8b62a..ef0ac85 100644 --- a/gcc/ada/g-pehage.adb +++ b/gcc/ada/g-pehage.adb @@ -1970,6 +1970,7 @@ package body GNAT.Perfect_Hash_Generators is -- 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; @@ -1991,9 +1992,9 @@ package body GNAT.Perfect_Hash_Generators is 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; diff --git a/gcc/ada/g-regpat.adb b/gcc/ada/g-regpat.adb index 6bfc2d9..de76a7b 100644 --- a/gcc/ada/g-regpat.adb +++ b/gcc/ada/g-regpat.adb @@ -684,9 +684,12 @@ package body GNAT.Regpat is 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 @@ -713,7 +716,7 @@ package body GNAT.Regpat is Link_Tail (Old, Old + 3); end if; - Old := Emit_Node (Op); + Discard := Emit_Node (Op); Emit_Ptr := Dest + Size; end Insert_Operator; @@ -2364,21 +2367,23 @@ package body GNAT.Regpat is ----------- 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, diff --git a/gcc/ada/g-regpat.ads b/gcc/ada/g-regpat.ads index 42dc3f4..dbe65b4 100644 --- a/gcc/ada/g-regpat.ads +++ b/gcc/ada/g-regpat.ads @@ -7,7 +7,7 @@ -- 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- -- @@ -583,7 +583,8 @@ package GNAT.Regpat is 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 diff --git a/gcc/ada/g-thread.adb b/gcc/ada/g-thread.adb index b49ed23..6f9dfe7 100644 --- a/gcc/ada/g-thread.adb +++ b/gcc/ada/g-thread.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -128,6 +128,7 @@ package body GNAT.Threads is T : Tasking.Task_Id; use type Tasking.Task_Id; + use type System.OS_Interface.Thread_Id; begin STPO.Lock_RTS; diff --git a/gcc/ada/g-trasym-vms-ia64.adb b/gcc/ada/g-trasym-vms-ia64.adb index 1d82b66..7636a64 100644 --- a/gcc/ada/g-trasym-vms-ia64.adb +++ b/gcc/ada/g-trasym-vms-ia64.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -69,7 +69,7 @@ package body GNAT.Traceback.Symbolic is 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; diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb index e737175..fb2b226 100644 --- a/gcc/ada/get_targ.adb +++ b/gcc/ada/get_targ.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -42,6 +42,15 @@ package body Get_Targ is 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 -- --------------------- @@ -57,13 +66,4 @@ package body Get_Targ is 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; diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index e1dddd9..9895362 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -85,7 +85,7 @@ procedure Gnatbind is 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 @@ -206,6 +206,8 @@ procedure Gnatbind is ------------------- 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. @@ -420,11 +422,11 @@ begin 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; @@ -449,7 +451,7 @@ begin -- 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 @@ -535,7 +537,7 @@ begin -- Output usage information if no files if not More_Lib_Files then - Bindusg; + Bindusg.Display; Exit_Program (E_Fatal); end if; @@ -600,8 +602,8 @@ begin -- 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 diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb index fdcf6b4..ada455e 100644 --- a/gcc/ada/gnatdll.adb +++ b/gcc/ada/gnatdll.adb @@ -253,6 +253,12 @@ procedure Gnatdll is 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 diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 7847a15..3575d8f 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -579,7 +579,6 @@ package body Inline is end loop; Comp_Unit := Parent (Pack); - while Present (Comp_Unit) and then Nkind (Comp_Unit) /= N_Compilation_Unit loop diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb index 4b65da2..14216f6 100644 --- a/gcc/ada/itypes.adb +++ b/gcc/ada/itypes.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -93,14 +93,14 @@ package body Itypes is 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; diff --git a/gcc/ada/lang.opt b/gcc/ada/lang.opt index 305ff13..82636b4 100644 --- a/gcc/ada/lang.opt +++ b/gcc/ada/lang.opt @@ -61,6 +61,10 @@ Wmissing-format-attribute Ada ; Documented for C +Woverlength-strings +Ada +; Documented for C + nostdinc Ada RejectNegative ; Don't look for source files diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 8a7039f..4a7a0b9 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -135,6 +135,9 @@ package body Makeutl is 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; diff --git a/gcc/ada/mdll-utl.adb b/gcc/ada/mdll-utl.adb index 991f3fd..7939199 100644 --- a/gcc/ada/mdll-utl.adb +++ b/gcc/ada/mdll-utl.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -250,7 +250,7 @@ package body MDLL.Utl is 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); diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb index 2e7ae46..a3188b3 100644 --- a/gcc/ada/mdll.adb +++ b/gcc/ada/mdll.adb @@ -394,6 +394,8 @@ package body MDLL is 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 @@ -402,13 +404,14 @@ package body MDLL is 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; @@ -438,7 +441,6 @@ package body MDLL is (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. @@ -472,8 +474,12 @@ package body MDLL is -- 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; diff --git a/gcc/ada/nmake.adt b/gcc/ada/nmake.adt index 3567bb7..240d522 100644 --- a/gcc/ada/nmake.adt +++ b/gcc/ada/nmake.adt @@ -6,7 +6,7 @@ -- -- -- 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- -- diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb index 2dc070e..d7c8e35 100644 --- a/gcc/ada/osint-b.adb +++ b/gcc/ada/osint-b.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -30,12 +30,6 @@ with Targparm; use Targparm; 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 -- ------------------------- @@ -51,10 +45,6 @@ package body Osint.B is 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; -------------------------- @@ -164,10 +154,6 @@ package body Osint.B is 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; @@ -183,80 +169,6 @@ package body Osint.B is 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 -- ----------------------- diff --git a/gcc/ada/osint-b.ads b/gcc/ada/osint-b.ads index e919c29..6ba2bb9 100644 --- a/gcc/ada/osint-b.ads +++ b/gcc/ada/osint-b.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -29,10 +29,6 @@ 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 @@ -45,20 +41,6 @@ package Osint.B is -- 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 -- ------------------- diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index e7e7ea0..c9695fa 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -58,6 +58,15 @@ package body Output is Special_Output_Proc := null; end Cancel_Special_Output; + ------------ + -- Column -- + ------------ + + function Column return Pos is + begin + return Pos (Next_Col); + end Column; + ------------------ -- Flush_Buffer -- ------------------ @@ -100,15 +109,6 @@ package body Output is end if; end Flush_Buffer; - ------------ - -- Column -- - ------------ - - function Column return Pos is - begin - return Pos (Next_Col); - end Column; - --------------------------- -- Restore_Output_Buffer -- --------------------------- @@ -240,8 +240,12 @@ package body Output is 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; --------------- @@ -295,6 +299,17 @@ package body Output is 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 -- --------------- diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 10df655..7273ce5 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -101,11 +101,15 @@ package Output is -- 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; @@ -144,7 +148,7 @@ package Output is -- 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 diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads index df96404..732feb3 100644 --- a/gcc/ada/prj-attr.ads +++ b/gcc/ada/prj-attr.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -110,7 +110,7 @@ package Prj.Attr is -- 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 @@ -205,7 +205,7 @@ private ---------------- 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; @@ -235,7 +235,7 @@ private -------------- 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; diff --git a/gcc/ada/s-asthan-vms-alpha.adb b/gcc/ada/s-asthan-vms-alpha.adb index f108058..867aafd 100644 --- a/gcc/ada/s-asthan-vms-alpha.adb +++ b/gcc/ada/s-asthan-vms-alpha.adb @@ -517,7 +517,7 @@ package body System.AST_Handling is ---------------------------- procedure Expand_AST_Packet_Pool - (Requested_Packets : in Natural; + (Requested_Packets : Natural; Actual_Number : out Natural; Total_Number : out Natural) is diff --git a/gcc/ada/s-atacco.ads b/gcc/ada/s-atacco.ads index 6e2b434..9fd2839 100644 --- a/gcc/ada/s-atacco.ads +++ b/gcc/ada/s-atacco.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index d8d419d..cc890d6 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -48,9 +48,9 @@ package body System.HTable is 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 -- diff --git a/gcc/ada/s-imgdec.adb b/gcc/ada/s-imgdec.adb index 34bd68b..d57d07d 100644 --- a/gcc/ada/s-imgdec.adb +++ b/gcc/ada/s-imgdec.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -41,8 +41,7 @@ package body System.Img_Dec is function Image_Decimal (V : Integer; - Scale : Integer) - return String + Scale : Integer) return String is P : Natural := 0; S : String (1 .. 64); @@ -76,10 +75,10 @@ package body System.Img_Dec is 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. @@ -147,10 +146,10 @@ package body System.Img_Dec is -- 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; @@ -181,7 +180,7 @@ package body System.Img_Dec is -- 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; diff --git a/gcc/ada/s-inmaop-posix.adb b/gcc/ada/s-inmaop-posix.adb index 486795c..e9da380 100644 --- a/gcc/ada/s-inmaop-posix.adb +++ b/gcc/ada/s-inmaop-posix.adb @@ -295,7 +295,7 @@ begin end loop; - -- Setup the masks to be exported. + -- Setup the masks to be exported Result := sigemptyset (mask'Access); pragma Assert (Result = 0); diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads index 490e9d69..d0082ae6 100644 --- a/gcc/ada/s-maccod.ads +++ b/gcc/ada/s-maccod.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -89,8 +89,7 @@ package System.Machine_Code is 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; @@ -121,7 +120,7 @@ private 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; diff --git a/gcc/ada/s-mastop-vms.adb b/gcc/ada/s-mastop-vms.adb index ce462cb..4b239f2 100644 --- a/gcc/ada/s-mastop-vms.adb +++ b/gcc/ada/s-mastop-vms.adb @@ -7,7 +7,7 @@ -- 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- -- @@ -175,7 +175,7 @@ package body System.Machine_State_Operations is 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); @@ -221,7 +221,7 @@ package body System.Machine_State_Operations is 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); @@ -255,7 +255,7 @@ package body System.Machine_State_Operations is 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); diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb index a529954..d149bd5 100644 --- a/gcc/ada/s-memory.adb +++ b/gcc/ada/s-memory.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- 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. diff --git a/gcc/ada/s-osinte-mingw.ads b/gcc/ada/s-osinte-mingw.ads index 8cc916a..1989c14 100644 --- a/gcc/ada/s-osinte-mingw.ads +++ b/gcc/ada/s-osinte-mingw.ads @@ -7,7 +7,7 @@ -- 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- -- @@ -68,6 +68,7 @@ package System.OS_Interface is 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; diff --git a/gcc/ada/s-osprim-vms.adb b/gcc/ada/s-osprim-vms.adb index 7d7a7dc..54b4b90 100644 --- a/gcc/ada/s-osprim-vms.adb +++ b/gcc/ada/s-osprim-vms.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -77,10 +77,10 @@ package body System.OS_Primitives is 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); diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb index 3c6485c..bc43eed 100644 --- a/gcc/ada/s-secsta.adb +++ b/gcc/ada/s-secsta.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -487,7 +487,7 @@ package body System.Secondary_Stack is -- 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; diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb index 8c32568..0e5c582 100644 --- a/gcc/ada/s-soflin.adb +++ b/gcc/ada/s-soflin.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -54,7 +54,7 @@ package body System.Soft_Links is -- 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 -- @@ -295,14 +295,14 @@ package body System.Soft_Links is 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 -- @@ -314,6 +314,15 @@ package body System.Soft_Links is null; end Task_Termination_NT; + -------------------- + -- Task_Unlock_NT -- + -------------------- + + procedure Task_Unlock_NT is + begin + null; + end Task_Unlock_NT; + ------------------------- -- Update_Exception_NT -- ------------------------- @@ -323,13 +332,4 @@ package body System.Soft_Links is 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; diff --git a/gcc/ada/s-stoele.ads b/gcc/ada/s-stoele.ads index ca50e03..3b1527b 100644 --- a/gcc/ada/s-stoele.ads +++ b/gcc/ada/s-stoele.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -54,6 +54,10 @@ package System.Storage_Elements is 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; diff --git a/gcc/ada/s-strxdr.adb b/gcc/ada/s-strxdr.adb index 63aa286..053582c 100644 --- a/gcc/ada/s-strxdr.adb +++ b/gcc/ada/s-strxdr.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1041,7 +1041,7 @@ package body System.Stream_Attributes is -- 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; @@ -1071,7 +1071,7 @@ package body System.Stream_Attributes is -- 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)); @@ -1092,7 +1092,7 @@ package body System.Stream_Attributes is -- 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); @@ -1105,7 +1105,7 @@ package body System.Stream_Attributes is -- 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); @@ -1123,7 +1123,7 @@ package body System.Stream_Attributes is -- 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; @@ -1205,7 +1205,7 @@ package body System.Stream_Attributes is -- 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; @@ -1239,7 +1239,7 @@ package body System.Stream_Attributes is -- 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; @@ -1321,7 +1321,7 @@ package body System.Stream_Attributes is -- 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; @@ -1367,7 +1367,7 @@ package body System.Stream_Attributes is -- 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; @@ -1463,7 +1463,7 @@ package body System.Stream_Attributes is ----------- procedure W_LLI (Stream : not null access RST; - Item : in Long_Long_Integer) + Item : Long_Long_Integer) is S : XDR_S_LLI; U : Unsigned; @@ -1511,7 +1511,7 @@ package body System.Stream_Attributes is ----------- 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; @@ -1548,7 +1548,7 @@ package body System.Stream_Attributes is -- 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; @@ -1584,7 +1584,7 @@ package body System.Stream_Attributes is -- 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; @@ -1666,7 +1666,7 @@ package body System.Stream_Attributes is -- 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; @@ -1702,7 +1702,7 @@ package body System.Stream_Attributes is 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; @@ -1732,7 +1732,7 @@ package body System.Stream_Attributes is 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; @@ -1747,7 +1747,7 @@ package body System.Stream_Attributes is -- 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); @@ -1772,7 +1772,7 @@ package body System.Stream_Attributes is -- 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); @@ -1797,7 +1797,7 @@ package body System.Stream_Attributes is -- 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; diff --git a/gcc/ada/s-trafor-default.adb b/gcc/ada/s-trafor-default.adb index 1918cae..4451f43 100644 --- a/gcc/ada/s-trafor-default.adb +++ b/gcc/ada/s-trafor-default.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -41,7 +41,7 @@ package body System.Traces.Format is -- 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 => ' '); diff --git a/gcc/ada/s-wchcon.adb b/gcc/ada/s-wchcon.adb index ad55243..9cbea7f 100755 --- a/gcc/ada/s-wchcon.adb +++ b/gcc/ada/s-wchcon.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -48,4 +48,17 @@ package body System.WCh_Con is 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; diff --git a/gcc/ada/s-wchcon.ads b/gcc/ada/s-wchcon.ads index d0c9b8f..6ae05af 100644 --- a/gcc/ada/s-wchcon.ads +++ b/gcc/ada/s-wchcon.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -186,4 +186,9 @@ package System.WCh_Con is -- 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; diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index 52a9fac..6f8ea91 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -57,45 +57,6 @@ package body Scn is 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 -- ----------------------- @@ -345,6 +306,45 @@ package body Scn is 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 -- ------------------------------ diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index b6523da..78d8798 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -558,6 +558,8 @@ package body Sem_Case is Raises_CE : out Boolean; Others_Present : out Boolean) is + pragma Assert (Choice_Table'First = 1); + E : Entity_Id; Enode : Node_Id; diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads index e07e229..66009c2 100644 --- a/gcc/ada/sem_case.ads +++ b/gcc/ada/sem_case.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -93,8 +93,8 @@ package Sem_Case is -- 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 diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index 9e29dbc..b1062b7 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -652,8 +652,8 @@ package body Sinput.L is -- 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 diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb index a333b09..4718952 100644 --- a/gcc/ada/sinput-p.adb +++ b/gcc/ada/sinput-p.adb @@ -89,8 +89,8 @@ package body Sinput.P is -- 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 diff --git a/gcc/ada/treeprs.adt b/gcc/ada/treeprs.adt index fbffd58..9de0654 100644 --- a/gcc/ada/treeprs.adt +++ b/gcc/ada/treeprs.adt @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -47,9 +47,9 @@ package Treeprs is -- 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'; @@ -79,9 +79,9 @@ package Treeprs is -- 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 diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index d295eab..7c711ab 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -134,6 +134,7 @@ package body Uintp is -- 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); @@ -422,6 +423,8 @@ package body Uintp is 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); @@ -590,18 +593,28 @@ package body Uintp is 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; diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb index c1839af..4897bf1 100644 --- a/gcc/ada/urealp.adb +++ b/gcc/ada/urealp.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1431,14 +1431,14 @@ package body Urealp is 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 -- @@ -1449,14 +1449,14 @@ package body Urealp is 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 -- @@ -1467,15 +1467,6 @@ package body Urealp is 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 -- ---------------- @@ -1494,6 +1485,15 @@ package body Urealp is 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 -- ----------------- |