diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 44 | ||||
| -rw-r--r-- | gcc/ada/a-cbmutr.adb | 187 | ||||
| -rw-r--r-- | gcc/ada/a-cbmutr.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/a-cimutr.adb | 170 | ||||
| -rw-r--r-- | gcc/ada/a-comutr.adb | 173 | ||||
| -rw-r--r-- | gcc/ada/exp_dbug.adb | 39 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/usage.adb | 4 |
10 files changed, 327 insertions, 311 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9ad5b1be173..3c668004cd5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2011-12-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_dbug.adb: Comment reformatting. + (Get_External_Name): Use Reset_Buffers to reset the contents of + Name_Buffer and Homonym_Numbers. + (Qualify_All_Entity_Names): Reset the contents of Name_Buffer and + Homonym_Numbers before creating a new qualified name for a particular + entity. + (Reset_Buffers): New routine. + +2011-12-02 Matthew Heaney <heaney@adacore.com> + + * a-cbmutr.ads (No_Node): Moved declaration from body to spec + * a-comutr.adb, a-cimutr.adb, a-cbmutr.adb (Iterator): Derives + from Root_Iterator. + (Child_Iterator): Derives from Root_Iterator. + (Finalize): Implemented as an override operation for Root_Iterator. + (First): Return value depends on Subtree component. + (Last): Component was renamed from Parent to Subtree. + (Next): Checks parameter value, and uses simplified loop. + (Iterate): Forwards to Iterate_Subtree. + (Iterate_Children): Component was renamed from Parent to Subtree. + (Iterate_Subtree): Checks parameter value + +2011-12-02 Robert Dewar <dewar@adacore.com> + + * usage.adb: Add lines for -gnatw.n and -gnatw.N + (atomic sync info msgs). + +2011-12-02 Steve Baird <baird@adacore.com> + + * sem_ch3.adb (Check_Completion): An Ada 2012 + generic formal type doesn't require a completion. + +2011-12-02 Eric Botcazou <ebotcazou@adacore.com> + + * sem_util.adb (Set_Debug_Info_Needed): Also set the flag on the + packed array type if it is to be set on the array type used to + represent it. + +2011-12-02 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Eliminate confusing use of type name. + 2011-12-02 Thomas Quinot <quinot@adacore.com> * sem_ch10.adb (Analyze_Compilation_Unit): For a library subprogram diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index aee67f02a2f..713e1be8d4b 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -33,32 +33,37 @@ with System; use type System.Address; package body Ada.Containers.Bounded_Multiway_Trees is - No_Node : constant Count_Type'Base := -1; + -------------------- + -- Root_Iterator -- + -------------------- - type Iterator is new Limited_Controlled and + type Root_Iterator is abstract new Limited_Controlled and Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; - Position : Cursor; - From_Root : Boolean; + Subtree : Count_Type; end record; - overriding procedure Finalize (Object : in out Iterator); + overriding procedure Finalize (Object : in out Root_Iterator); + + ----------------------- + -- Subtree_Iterator -- + ----------------------- + + type Subtree_Iterator is new Root_Iterator with null record; - overriding function First (Object : Iterator) return Cursor; + overriding function First (Object : Subtree_Iterator) return Cursor; overriding function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor; - type Child_Iterator is new Limited_Controlled and - Tree_Iterator_Interfaces.Reversible_Iterator with - record - Container : Tree_Access; - Parent : Count_Type; - end record; + --------------------- + -- Child_Iterator -- + --------------------- - overriding procedure Finalize (Object : in out Child_Iterator); + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record; overriding function First (Object : Child_Iterator) return Cursor; @@ -66,12 +71,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Object : Child_Iterator; Position : Cursor) return Cursor; + overriding function Last (Object : Child_Iterator) return Cursor; + overriding function Previous (Object : Child_Iterator; Position : Cursor) return Cursor; - overriding function Last (Object : Child_Iterator) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -1242,13 +1247,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- Finalize -- -------------- - procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - - procedure Finalize (Object : in out Child_Iterator) is + procedure Finalize (Object : in out Root_Iterator) is B : Natural renames Object.Container.Busy; begin B := B - 1; @@ -1278,14 +1277,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is return Cursor'(Container'Unrestricted_Access, Node); end Find; - function First (Object : Iterator) return Cursor is + ----------- + -- First -- + ----------- + + overriding function First (Object : Subtree_Iterator) return Cursor is begin - return Object.Position; + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; end First; - function First (Object : Child_Iterator) return Cursor is + overriding function First (Object : Child_Iterator) return Cursor is begin - return First_Child (Cursor'(Object.Container, Object.Parent)); + return First_Child (Cursor'(Object.Container, Object.Subtree)); end First; ----------------- @@ -1780,19 +1787,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - RC : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Position => First_Child (RC), - From_Root => True) - do - B := B + 1; - end return; + return Iterate_Subtree (Root (Container)); end Iterate; ---------------------- @@ -1879,7 +1875,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return It : constant Child_Iterator := Child_Iterator'(Limited_Controlled with Container => C, - Parent => Parent.Node) + Subtree => Parent.Node) do B := B + 1; end return; @@ -1893,17 +1889,25 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Position.Container.all.Busy; - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Position.Container, - Position => Position, - From_Root => False) - do - B := B + 1; - end return; + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + declare + B : Natural renames Position.Container.Busy; + begin + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + B := B + 1; + end return; + end; end Iterate_Subtree; procedure Iterate_Subtree @@ -1962,7 +1966,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is overriding function Last (Object : Child_Iterator) return Cursor is begin - return Last_Child (Cursor'(Object.Container, Object.Parent)); + return Last_Child (Cursor'(Object.Container, Object.Subtree)); end Last; ---------------- @@ -2023,67 +2027,43 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- Next -- ---------- - function Next - (Object : Iterator; + overriding function Next + (Object : Subtree_Iterator; Position : Cursor) return Cursor is - T : Tree renames Position.Container.all; - NN : Tree_Node_Array renames T.Nodes; - N : Tree_Node_Type renames NN (Position.Node); - begin - if Is_Leaf (Position) then - - -- If sibling is present, return it - - if N.Next /= 0 then - return (Object.Container, N.Next); - - -- If this is the last sibling, go to sibling of first ancestor that - -- has a sibling, or terminate. - - else - declare - Pos : Count_Type := N.Parent; - Par : Tree_Node_Type := NN (Pos); - - begin - while Par.Next = 0 loop - Pos := Par.Parent; - - -- If we are back at the root the iteration is complete - - if Pos = No_Node then - return No_Element; - - -- If this is a subtree iterator and we are back at the - -- starting node, iteration is complete. + if Position.Container = null then + return No_Element; + end if; - elsif Pos = Object.Position.Node - and then not Object.From_Root - then - return No_Element; + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; - else - Par := NN (Pos); - end if; - end loop; + pragma Assert (Object.Container.Count > 0); + pragma Assert (Position.Node /= Root_Node (Object.Container.all)); - if Pos = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - end if; + declare + Nodes : Tree_Node_Array renames Object.Container.Nodes; + Node : Count_Type; + begin + Node := Position.Node; - return (Object.Container, Par.Next); - end; + if Nodes (Node).Children.First > 0 then + return Cursor'(Object.Container, Nodes (Node).Children.First); end if; - -- If an internal node, return its first child + while Node /= Object.Subtree loop + if Nodes (Node).Next > 0 then + return Cursor'(Object.Container, Nodes (Node).Next); + end if; - else - return (Object.Container, N.Children.First); - end if; + Node := Nodes (Node).Parent; + end loop; + + return No_Element; + end; end Next; overriding function Next @@ -2100,6 +2080,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is "Position cursor of Next designates wrong tree"; end if; + pragma Assert (Object.Container.Count > 0); + pragma Assert (Position.Node /= Root_Node (Object.Container.all)); + return Next_Sibling (Position); end Next; diff --git a/gcc/ada/a-cbmutr.ads b/gcc/ada/a-cbmutr.ads index 797b6ea6214..73580d992cf 100644 --- a/gcc/ada/a-cbmutr.ads +++ b/gcc/ada/a-cbmutr.ads @@ -301,6 +301,8 @@ package Ada.Containers.Bounded_Multiway_Trees is private use Ada.Streams; + No_Node : constant Count_Type'Base := -1; + type Children_Type is record First : Count_Type'Base; Last : Count_Type'Base; @@ -319,7 +321,7 @@ private type Tree (Capacity : Count_Type) is tagged record Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); Elements : Element_Array (1 .. Capacity) := (others => <>); - Free : Count_Type'Base := -1; + Free : Count_Type'Base := No_Node; Busy : Integer := 0; Lock : Integer := 0; Count : Count_Type := 0; @@ -342,7 +344,7 @@ private type Cursor is record Container : Tree_Access; - Node : Count_Type'Base := -1; + Node : Count_Type'Base := No_Node; end record; procedure Read diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index 01929bbf373..daac18feb04 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -33,41 +33,50 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Multiway_Trees is - type Iterator is new Limited_Controlled and + -------------------- + -- Root_Iterator -- + -------------------- + + type Root_Iterator is abstract new Limited_Controlled and Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; - Position : Cursor; - From_Root : Boolean; + Subtree : Tree_Node_Access; end record; - type Child_Iterator is new Limited_Controlled and - Tree_Iterator_Interfaces.Reversible_Iterator with - record - Container : Tree_Access; - Parent : Tree_Node_Access; - end record; + overriding procedure Finalize (Object : in out Root_Iterator); - overriding procedure Finalize (Object : in out Iterator); + ----------------------- + -- Subtree_Iterator -- + ----------------------- + + type Subtree_Iterator is new Root_Iterator with null record; + + overriding function First (Object : Subtree_Iterator) return Cursor; - overriding function First (Object : Iterator) return Cursor; overriding function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor; - overriding procedure Finalize (Object : in out Child_Iterator); + --------------------- + -- Child_Iterator -- + --------------------- + + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record; overriding function First (Object : Child_Iterator) return Cursor; + overriding function Next (Object : Child_Iterator; Position : Cursor) return Cursor; + overriding function Last (Object : Child_Iterator) return Cursor; + overriding function Previous (Object : Child_Iterator; Position : Cursor) return Cursor; - overriding function Last (Object : Child_Iterator) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -936,13 +945,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- Finalize -- -------------- - procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - - procedure Finalize (Object : in out Child_Iterator) is + procedure Finalize (Object : in out Root_Iterator) is B : Natural renames Object.Container.Busy; begin B := B - 1; @@ -971,14 +974,18 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- First -- ----------- - function First (Object : Iterator) return Cursor is + overriding function First (Object : Subtree_Iterator) return Cursor is begin - return Object.Position; + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; end First; - function First (Object : Child_Iterator) return Cursor is + overriding function First (Object : Child_Iterator) return Cursor is begin - return First_Child (Cursor'(Object.Container, Object.Parent)); + return First_Child (Cursor'(Object.Container, Object.Subtree)); end First; ----------------- @@ -1348,18 +1355,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - RC : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Position => First_Child (RC), - From_Root => True) - do - B := B + 1; - end return; + begin + return Iterate_Subtree (Root (Container)); end Iterate; ---------------------- @@ -1438,7 +1435,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return It : constant Child_Iterator := Child_Iterator'(Limited_Controlled with Container => C, - Parent => Parent.Node) + Subtree => Parent.Node) do B := B + 1; end return; @@ -1452,17 +1449,25 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Position.Container'Unrestricted_Access.all.Busy; - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Position.Container, - Position => Position, - From_Root => False) - do - B := B + 1; - end return; + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + declare + B : Natural renames Position.Container.Busy; + begin + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + B := B + 1; + end return; + end; end Iterate_Subtree; procedure Iterate_Subtree @@ -1515,7 +1520,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is overriding function Last (Object : Child_Iterator) return Cursor is begin - return Last_Child (Cursor'(Object.Container, Object.Parent)); + return Last_Child (Cursor'(Object.Container, Object.Subtree)); end Last; ---------------- @@ -1585,63 +1590,36 @@ package body Ada.Containers.Indefinite_Multiway_Trees is ---------- function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor is - T : Tree renames Position.Container.all; - N : constant Tree_Node_Access := Position.Node; + Node : Tree_Node_Access; begin - if Is_Leaf (Position) then - - -- If sibling is present, return it - - if N.Next /= null then - return (Object.Container, N.Next); - - -- If this is the last sibling, go to sibling of first ancestor that - -- has a sibling, or terminate. - - else - declare - Par : Tree_Node_Access := N.Parent; - - begin - while Par.Next = null loop - - -- If we are back at the root the iteration is complete - - if Par = Root_Node (T) then - return No_Element; - - -- If this is a subtree iterator and we are back at the - -- starting node, iteration is complete. + if Position.Container = null then + return No_Element; + end if; - elsif Par = Object.Position.Node - and then not Object.From_Root - then - return No_Element; + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; - else - Par := Par.Parent; - end if; - end loop; + Node := Position.Node; - if Par = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - end if; + if Node.Children.First /= null then + return Cursor'(Object.Container, Node.Children.First); + end if; - return (Object.Container, Par.Next); - end; + while Node /= Object.Subtree loop + if Node.Next /= null then + return Cursor'(Object.Container, Node.Next); end if; - -- If an internal node, return its first child + Node := Node.Parent; + end loop; - else - return (Object.Container, N.Children.First); - end if; + return No_Element; end Next; function Next diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index b18b15f7534..12d675ad574 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -34,41 +34,50 @@ with System; use type System.Address; package body Ada.Containers.Multiway_Trees is - type Iterator is new Limited_Controlled and + -------------------- + -- Root_Iterator -- + -------------------- + + type Root_Iterator is abstract new Limited_Controlled and Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; - Position : Cursor; - From_Root : Boolean; + Subtree : Tree_Node_Access; end record; - type Child_Iterator is new Limited_Controlled and - Tree_Iterator_Interfaces.Reversible_Iterator with - record - Container : Tree_Access; - Parent : Tree_Node_Access; - end record; + overriding procedure Finalize (Object : in out Root_Iterator); - overriding procedure Finalize (Object : in out Iterator); + ----------------------- + -- Subtree_Iterator -- + ----------------------- + + type Subtree_Iterator is new Root_Iterator with null record; + + overriding function First (Object : Subtree_Iterator) return Cursor; - overriding function First (Object : Iterator) return Cursor; overriding function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor; - overriding procedure Finalize (Object : in out Child_Iterator); + --------------------- + -- Child_Iterator -- + --------------------- + + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record; overriding function First (Object : Child_Iterator) return Cursor; + overriding function Next (Object : Child_Iterator; Position : Cursor) return Cursor; + overriding function Last (Object : Child_Iterator) return Cursor; + overriding function Previous (Object : Child_Iterator; Position : Cursor) return Cursor; - overriding function Last (Object : Child_Iterator) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -909,13 +918,7 @@ package body Ada.Containers.Multiway_Trees is -- Finalize -- -------------- - procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - - procedure Finalize (Object : in out Child_Iterator) is + procedure Finalize (Object : in out Root_Iterator) is B : Natural renames Object.Container.Busy; begin B := B - 1; @@ -943,14 +946,18 @@ package body Ada.Containers.Multiway_Trees is -- First -- ----------- - function First (Object : Iterator) return Cursor is + overriding function First (Object : Subtree_Iterator) return Cursor is begin - return Object.Position; + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; end First; - function First (Object : Child_Iterator) return Cursor is + overriding function First (Object : Child_Iterator) return Cursor is begin - return First_Child (Cursor'(Object.Container, Object.Parent)); + return First_Child (Cursor'(Object.Container, Object.Subtree)); end First; ----------------- @@ -1376,18 +1383,8 @@ package body Ada.Containers.Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - RC : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Position => First_Child (RC), - From_Root => True) - do - B := B + 1; - end return; + begin + return Iterate_Subtree (Root (Container)); end Iterate; ---------------------- @@ -1464,9 +1461,9 @@ package body Ada.Containers.Multiway_Trees is end if; return It : constant Child_Iterator := - Child_Iterator'(Limited_Controlled with - Container => C, - Parent => Parent.Node) + (Limited_Controlled with + Container => C, + Subtree => Parent.Node) do B := B + 1; end return; @@ -1480,16 +1477,25 @@ package body Ada.Containers.Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Position.Container'Unrestricted_Access.all.Busy; begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Position.Container, - Position => Position, - From_Root => False) - do - B := B + 1; - end return; + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + declare + B : Natural renames Position.Container.Busy; + begin + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + B := B + 1; + end return; + end; end Iterate_Subtree; procedure Iterate_Subtree @@ -1542,7 +1548,7 @@ package body Ada.Containers.Multiway_Trees is overriding function Last (Object : Child_Iterator) return Cursor is begin - return Last_Child (Cursor'(Object.Container, Object.Parent)); + return Last_Child (Cursor'(Object.Container, Object.Subtree)); end Last; ---------------- @@ -1612,63 +1618,36 @@ package body Ada.Containers.Multiway_Trees is ---------- function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor is - T : Tree renames Position.Container.all; - N : constant Tree_Node_Access := Position.Node; + Node : Tree_Node_Access; begin - if Is_Leaf (Position) then - - -- If sibling is present, return it - - if N.Next /= null then - return (Object.Container, N.Next); - - -- If this is the last sibling, go to sibling of first ancestor that - -- has a sibling, or terminate. - - else - declare - Par : Tree_Node_Access := N.Parent; - - begin - while Par.Next = null loop - - -- If we are back at the root the iteration is complete - - if Par = Root_Node (T) then - return No_Element; - - -- If this is a subtree iterator and we are back at the - -- starting node, iteration is complete. + if Position.Container = null then + return No_Element; + end if; - elsif Par = Object.Position.Node - and then not Object.From_Root - then - return No_Element; + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; - else - Par := Par.Parent; - end if; - end loop; + Node := Position.Node; - if Par = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - end if; + if Node.Children.First /= null then + return Cursor'(Object.Container, Node.Children.First); + end if; - return (Object.Container, Par.Next); - end; + while Node /= Object.Subtree loop + if Node.Next /= null then + return Cursor'(Object.Container, Node.Next); end if; - else - -- If an internal node, return its first child + Node := Node.Parent; + end loop; - return (Object.Container, N.Children.First); - end if; + return No_Element; end Next; function Next diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index ca36f14ad87..5d605d75c50 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -105,11 +105,11 @@ package body Exp_Dbug is -- Homonym_Suffix -- -------------------- - -- The string defined here (and its associated length) is used to - -- gather the homonym string that will be appended to Name_Buffer - -- when the name is complete. Strip_Suffixes appends to this string - -- as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix - -- appends the string to the end of Name_Buffer. + -- The string defined here (and its associated length) is used to gather + -- the homonym string that will be appended to Name_Buffer when the name + -- is complete. Strip_Suffixes appends to this string as does + -- Append_Homonym_Number, and Output_Homonym_Numbers_Suffix appends the + -- string to the end of Name_Buffer. Homonym_Numbers : String (1 .. 256); Homonym_Len : Natural := 0; @@ -147,6 +147,10 @@ package body Exp_Dbug is -- If not already done, replaces the Chars field of the given entity -- with the appropriate fully qualified name. + procedure Reset_Buffers; + -- Reset the contents of Name_Buffer and Homonym_Numbers by setting their + -- respective lengths to zero. + procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean); -- Given an qualified entity name in Name_Buffer, remove any plain X or -- X{nb} qualification suffix. The contents of Name_Buffer is not changed @@ -701,8 +705,7 @@ package body Exp_Dbug is -- Start of processing for Get_External_Name begin - Name_Len := 0; - Homonym_Len := 0; + Reset_Buffers; -- If this is a child unit, we want the child @@ -1022,6 +1025,7 @@ package body Exp_Dbug is begin for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop E := Defining_Entity (Name_Qualify_Units.Table (J)); + Reset_Buffers; Qualify_Entity_Name (E); -- Normally entities in the qualification list are scopes, but in the @@ -1033,6 +1037,7 @@ package body Exp_Dbug is if Ekind (E) /= E_Variable then Ent := First_Entity (E); while Present (Ent) loop + Reset_Buffers; Qualify_Entity_Name (Ent); Next_Entity (Ent); @@ -1101,10 +1106,10 @@ package body Exp_Dbug is if No (E) then return; - -- If this we are qualifying entities local to a generic - -- instance, use the name of the original instantiation, - -- not that of the anonymous subprogram in the wrapper - -- package, so that gdb doesn't have to know about these. + -- If this we are qualifying entities local to a generic instance, + -- use the name of the original instantiation, not that of the + -- anonymous subprogram in the wrapper package, so that gdb doesn't + -- have to know about these. elsif Is_Generic_Instance (E) and then Is_Subprogram (E) @@ -1394,6 +1399,16 @@ package body Exp_Dbug is Name_Qualify_Units.Append (N); end Qualify_Entity_Names; + ------------------- + -- Reset_Buffers -- + ------------------- + + procedure Reset_Buffers is + begin + Name_Len := 0; + Homonym_Len := 0; + end Reset_Buffers; + -------------------- -- Strip_Suffixes -- -------------------- diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 8a51161a8fa..781e0ae6cc6 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -4953,12 +4953,14 @@ with this pragma and others compiled in normal mode without it. Syntax: @smallexample @c ada -pragma Suppress_Initialization ([Entity =>] type_Name); +pragma Suppress_Initialization ([Entity =>] subtype_Name); @end smallexample @noindent +Here subtype_Name is the name introduced by a type declaration +or subtype declaration. This pragma suppresses any implicit or explicit initialization -associated with the given type name for all variables of this type, +for all variables of the given type or subtype, including initialization resulting from the use of pragmas Normalize_Scalars or Initialize_Scalars. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e708ee7d6f6..6af0ed53989 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9585,6 +9585,7 @@ package body Sem_Ch3 is elsif Ekind (E) = E_Incomplete_Type and then No (Underlying_Type (E)) + and then not Is_Generic_Type (E) then Post_Error; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 203eec19a1d..b38536fb535 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12210,10 +12210,18 @@ package body Sem_Util is end loop; end; + -- For a packed array type, we also need debug information for + -- the type used to represent the packed array. Conversely, we + -- also need it for the former if we need it for the latter. + if Is_Packed (T) then Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T)); end if; + if Is_Packed_Array_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); + end if; + elsif Is_Access_Type (T) then Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 2c20136af7e..aa4b8156906 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -462,6 +462,10 @@ begin Write_Line (" .m* turn on warnings for suspicious modulus value"); Write_Line (" .M turn off warnings for suspicious modulus value"); Write_Line (" n* normal warning mode (cancels -gnatws/-gnatwe)"); + Write_Line (" .n turn on info messages for atomic " & + "synchronization"); + Write_Line (" .N* turn off info messages for atomic " & + "synchronization"); Write_Line (" o* turn on warnings for address clause overlay"); Write_Line (" O turn off warnings for address clause overlay"); Write_Line (" .o turn on warnings for out parameters assigned " & |
