diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-08-03 10:38:26 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-08-03 10:38:26 +0000 |
| commit | 098d3082ab1e8ba60b762e7663cdb3a70a9c963e (patch) | |
| tree | fc7be1c9704d0d4e2e74847db194b13f6d7fc48a /gcc/ada | |
| parent | 039fcfa6316d4a70d271d974f9ded9c2001a97b8 (diff) | |
| download | gcc-098d3082ab1e8ba60b762e7663cdb3a70a9c963e.tar.gz | |
2011-08-03 Robert Dewar <dewar@adacore.com>
* gnatcmd.adb, prj-proc.adb, mlib-prj.adb, prj.adb, makeutl.ads,
prj-util.adb, prj-util.ads, prj-conf.adb, prj-env.adb: Minor
reformatting.
2011-08-03 Javier Miranda <miranda@adacore.com>
* exp_util.adb (Is_VM_By_Copy_Actual): Include N_Slide nodes as actuals
that must be passed by copy in VM targets.
2011-08-03 Emmanuel Briot <briot@adacore.com>
* prj.ads, prj-nmsc.adb (Files_Htable): removed this htable, which
duplicates a similar htable now in the project tree.
2011-08-03 Claire Dross <dross@adacore.com>
* a-cfdlli.adb, a-cfhama.adb, a-cfhase.adb, a-cforma.adb, a-cforse.adb,
a-cofove.adb ("=", Length, Is_Empty, Clear, Assign, Copy, Element,
Replace_Element, Query_Element, Update_Element, Move, Insert, Prepend,
Append, Delete, Delete_First, Delete_Last, Reverse_Element, Swap,
Splice, First, First_Element, Last, Last_Element, Next, Previous, Find,
Reverse_Find, Contains, Has_Element, Iterate, Reverse_Iterate, Capacity,
Reserve_Length, Length, Strict_Equal, Left, Right): Data-structure
update.
2011-08-03 Arnaud Charlet <charlet@adacore.com>
* s-taprop-posix.adb, s-taprop-linux.adb, s-taprop-tru64.adb
(ATCB_Key): Removed, not always used.
* s-tpopsp-posix.adb, s-tpopsp-posix-foreign.adb (ATCB_Key): Moved from
s-taprop-posix.adb.
* s-tpopsp-tls.adb: New file.
* gcc-interface/Makefile.in: Use TLS implementation of s-tpopsp.adb on
x86/x64/ia64/powerpc/sparc Linux.
2011-08-03 Arnaud Charlet <charlet@adacore.com>
* system-aix.ads, system-aix64.ads: Set ZCX_By_Default to True.
* gcc-interface/Makefile.in: Switch to ZCX by default on AIX ports.
2011-08-03 Thomas Quinot <quinot@adacore.com>
* rtsfind.ads, exp_dist.adb, exp_dist.ads
(Build_From_Any_Call, Build_To_Any_Call, Build_TypeCode_Call):
Fix type selection for mapping integer types to PolyORB types.
2011-08-03 Bob Duff <duff@adacore.com>
* sem_ch7.adb: Minor comment clarification.
2011-08-03 Bob Duff <duff@adacore.com>
* sem_ch13.adb (Analyze_Enumeration_Representation_Clause): If we get
an error analyzing a choice, skip further processing. Further
processing could cause a crash or cascade errors.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177262 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
40 files changed, 2209 insertions, 5077 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5fa9661a903..763881a98ad 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,61 @@ +2011-08-03 Robert Dewar <dewar@adacore.com> + + * gnatcmd.adb, prj-proc.adb, mlib-prj.adb, prj.adb, makeutl.ads, + prj-util.adb, prj-util.ads, prj-conf.adb, prj-env.adb: Minor + reformatting. + +2011-08-03 Javier Miranda <miranda@adacore.com> + + * exp_util.adb (Is_VM_By_Copy_Actual): Include N_Slide nodes as actuals + that must be passed by copy in VM targets. + +2011-08-03 Emmanuel Briot <briot@adacore.com> + + * prj.ads, prj-nmsc.adb (Files_Htable): removed this htable, which + duplicates a similar htable now in the project tree. + +2011-08-03 Claire Dross <dross@adacore.com> + + * a-cfdlli.adb, a-cfhama.adb, a-cfhase.adb, a-cforma.adb, a-cforse.adb, + a-cofove.adb ("=", Length, Is_Empty, Clear, Assign, Copy, Element, + Replace_Element, Query_Element, Update_Element, Move, Insert, Prepend, + Append, Delete, Delete_First, Delete_Last, Reverse_Element, Swap, + Splice, First, First_Element, Last, Last_Element, Next, Previous, Find, + Reverse_Find, Contains, Has_Element, Iterate, Reverse_Iterate, Capacity, + Reserve_Length, Length, Strict_Equal, Left, Right): Data-structure + update. + +2011-08-03 Arnaud Charlet <charlet@adacore.com> + + * s-taprop-posix.adb, s-taprop-linux.adb, s-taprop-tru64.adb + (ATCB_Key): Removed, not always used. + * s-tpopsp-posix.adb, s-tpopsp-posix-foreign.adb (ATCB_Key): Moved from + s-taprop-posix.adb. + * s-tpopsp-tls.adb: New file. + * gcc-interface/Makefile.in: Use TLS implementation of s-tpopsp.adb on + x86/x64/ia64/powerpc/sparc Linux. + +2011-08-03 Arnaud Charlet <charlet@adacore.com> + + * system-aix.ads, system-aix64.ads: Set ZCX_By_Default to True. + * gcc-interface/Makefile.in: Switch to ZCX by default on AIX ports. + +2011-08-03 Thomas Quinot <quinot@adacore.com> + + * rtsfind.ads, exp_dist.adb, exp_dist.ads + (Build_From_Any_Call, Build_To_Any_Call, Build_TypeCode_Call): + Fix type selection for mapping integer types to PolyORB types. + +2011-08-03 Bob Duff <duff@adacore.com> + + * sem_ch7.adb: Minor comment clarification. + +2011-08-03 Bob Duff <duff@adacore.com> + + * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): If we get + an error analyzing a choice, skip further processing. Further + processing could cause a crash or cascade errors. + 2011-08-03 Emmanuel Briot <briot@adacore.com> * gnatcmd.adb, prj-proc.adb, prj-proc.ads, make.adb, mlib-prj.adb, diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index 4f70f8174f6..d72566a03e1 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/gcc/ada/a-cfdlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-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- -- @@ -42,71 +42,17 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is (Container : in out List; New_Node : out Count_Type); - function Copy - (Source : Plain_List; - Capacity : Count_Type := 0) return PList_Access; - - function Find_Between - (Container : Plain_List; - Item : Element_Type; - From : Count_Type; - To : Count_Type; - Bg : Count_Type) return Cursor; - - function Element_Unchecked - (Container : List; - Position : Count_Type) return Element_Type; - procedure Free - (Container : in out Plain_List; + (Container : in out List; X : Count_Type); - function Has_Element_Base - (Container : Plain_List; - Position : Cursor) return Boolean; - procedure Insert_Internal (Container : in out List; Before : Count_Type; New_Node : Count_Type); - procedure Iterate_Between - (Container : List; - From : Count_Type; - To : Count_Type; - Process : - not null access procedure (Container : List; Position : Cursor)); - - function Next_Unchecked - (Container : List; - Position : Count_Type) return Count_Type; - - procedure Query_Element_Plain - (Container : Plain_List; Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - function Reverse_Find_Between - (Container : Plain_List; - Item : Element_Type; - From : Count_Type; - To : Count_Type) return Cursor; - - procedure Reverse_Iterate_Between - (Container : List; - From : Count_Type; - To : Count_Type; - Process : - not null access procedure (Container : List; Position : Cursor)); - function Vet (L : List; Position : Cursor) return Boolean; - procedure Write_Between - (Stream : not null access Root_Stream_Type'Class; - Item : Plain_List; - Length : Count_Type; - From : Count_Type; - To : Count_Type); - --------- -- "=" -- --------- @@ -124,14 +70,14 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is end if; LI := Left.First; - RI := Right.First; + RI := Left.First; while LI /= 0 loop - if Element_Unchecked (Left, LI) /= Element_Unchecked (Right, LI) then + if Left.Nodes (LI).Element /= Right.Nodes (LI).Element then return False; end if; - LI := Next_Unchecked (Left, LI); - RI := Next_Unchecked (Right, RI); + LI := Left.Nodes (LI).Next; + RI := Right.Nodes (RI).Next; end loop; return True; @@ -146,52 +92,36 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is New_Item : Element_Type; New_Node : out Count_Type) is - ContainerP : Plain_List renames Container.Plain.all; - begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; - - declare - N : Node_Array renames Container.Plain.all.Nodes; + N : Node_Array renames Container.Nodes; - begin - if ContainerP.Free >= 0 then - New_Node := ContainerP.Free; - N (New_Node).Element := New_Item; - ContainerP.Free := N (New_Node).Next; + begin + if Container.Free >= 0 then + New_Node := Container.Free; + N (New_Node).Element := New_Item; + Container.Free := N (New_Node).Next; - else - New_Node := abs ContainerP.Free; - N (New_Node).Element := New_Item; - ContainerP.Free := ContainerP.Free - 1; - end if; - end; + else + New_Node := abs Container.Free; + N (New_Node).Element := New_Item; + Container.Free := Container.Free - 1; + end if; end Allocate; procedure Allocate (Container : in out List; New_Node : out Count_Type) is - ContainerP : Plain_List renames Container.Plain.all; - begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; - - declare - N : Node_Array renames ContainerP.Nodes; + N : Node_Array renames Container.Nodes; - begin - if ContainerP.Free >= 0 then - New_Node := ContainerP.Free; - ContainerP.Free := N (New_Node).Next; + begin + if Container.Free >= 0 then + New_Node := Container.Free; + Container.Free := N (New_Node).Next; - else - New_Node := abs ContainerP.Free; - ContainerP.Free := ContainerP.Free - 1; - end if; - end; + else + New_Node := abs Container.Free; + Container.Free := Container.Free - 1; + end if; end Allocate; ------------ @@ -212,33 +142,26 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ------------ procedure Assign (Target : in out List; Source : List) is + N : Node_Array renames Source.Nodes; + J : Count_Type; + begin - if Target.K /= Plain or Source.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if Target'Address = Source'Address then + return; end if; - declare - N : Node_Array renames Source.Plain.Nodes; - J : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; + if Target.Capacity < Source.Length then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; - Clear (Target); + Clear (Target); - J := Source.First; - while J /= 0 loop - Append (Target, N (J).Element); - J := N (J).Next; - end loop; - end; + J := Source.First; + while J /= 0 loop + Append (Target, N (J).Element); + J := N (J).Next; + end loop; end Assign; ----------- @@ -246,53 +169,46 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ----------- procedure Clear (Container : in out List) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + begin - if Container.K /= Plain then - raise Constraint_Error; + if Container.Length = 0 then + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + pragma Assert (Container.Busy = 0); + pragma Assert (Container.Lock = 0); + return; end if; - declare - N : Node_Array renames Container.Plain.Nodes; - X : Count_Type; - - begin - if Container.Length = 0 then - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - pragma Assert (Container.Plain.Busy = 0); - pragma Assert (Container.Plain.Lock = 0); - return; - end if; + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; - if Container.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; + while Container.Length > 1 loop + X := Container.First; - while Container.Length > 1 loop - X := Container.First; + Container.First := N (X).Next; + N (Container.First).Prev := 0; - Container.First := N (X).Next; - N (Container.First).Prev := 0; + Container.Length := Container.Length - 1; - Container.Length := Container.Length - 1; - - Free (Container.Plain.all, X); - end loop; + Free (Container, X); + end loop; - X := Container.First; + X := Container.First; - Container.First := 0; - Container.Last := 0; - Container.Length := 0; + Container.First := 0; + Container.Last := 0; + Container.Length := 0; - Free (Container.Plain.all, X); - end; + Free (Container, X); end Clear; -------------- @@ -312,14 +228,13 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ---------- function Copy - (Source : Plain_List; - Capacity : Count_Type := 0) return PList_Access + (Source : List; + Capacity : Count_Type := 0) return List is C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity); - P : PList_Access; N : Count_Type := 1; + P : List (C); begin - P := new Plain_List (C); while N <= Source.Capacity loop P.Nodes (N).Prev := Source.Nodes (N).Prev; P.Nodes (N).Next := Source.Nodes (N).Next; @@ -327,61 +242,19 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is N := N + 1; end loop; P.Free := Source.Free; + P.Length := Source.Length; + P.First := Source.First; + P.Last := Source.Last; if P.Free >= 0 then N := Source.Capacity + 1; while N <= C loop - Free (P.all, N); + Free (P, N); N := N + 1; end loop; end if; return P; end Copy; - function Copy - (Source : List; - Capacity : Count_Type := 0) return List - is - Cap : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity); - begin - case Source.K is - when Plain => - return (Capacity => Cap, - Length => Source.Length, - Plain => Copy (Source.Plain.all, Cap), - First => Source.First, - Last => Source.Last, - others => <>); - when Part => - declare - Target : List (Capacity => Cap); - C : Cursor; - P : Cursor; - begin - Target := (Capacity => Cap, - Length => Source.Part.LLength, - Plain => Copy (Source.Plain.all, Cap), - First => Source.Part.LFirst, - Last => Source.Part.LLast, - others => <>); - C := (Node => Target.First); - while C.Node /= Source.First loop - P := Next (Target, C); - Delete (Container => Target, Position => C); - C := P; - end loop; - if Source.Last /= 0 then - C := (Node => Source.Plain.all.Nodes (Source.Last).Next); - while C.Node /= 0 loop - P := Next (Target, C); - Delete (Container => Target, Position => C); - C := P; - end loop; - end if; - return Target; - end; - end case; - end Copy; - ------------ -- Delete -- ------------ @@ -391,70 +264,63 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is Position : in out Cursor; Count : Count_Type := 1) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if not Has_Element (Container => Container, + Position => Position) then + raise Constraint_Error with + "Position cursor has no element"; end if; - declare - N : Node_Array renames Container.Plain.Nodes; - X : Count_Type; + pragma Assert (Vet (Container, Position), "bad cursor in Delete"); + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); - begin - if not Has_Element (Container => Container, - Position => Position) then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - if Position.Node = Container.First then - Delete_First (Container, Count); - Position := No_Element; - return; - end if; + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; + return; + end if; - if Count = 0 then - Position := No_Element; - return; - end if; + if Count = 0 then + Position := No_Element; + return; + end if; - if Container.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; - for Index in 1 .. Count loop - pragma Assert (Container.Length >= 2); + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); - X := Position.Node; - Container.Length := Container.Length - 1; + X := Position.Node; + Container.Length := Container.Length - 1; - if X = Container.Last then - Position := No_Element; + if X = Container.Last then + Position := No_Element; - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; - Free (Container.Plain.all, X); - return; - end if; + Free (Container, X); + return; + end if; - Position.Node := N (X).Next; - pragma Assert (N (Position.Node).Prev >= 0); + Position.Node := N (X).Next; + pragma Assert (N (Position.Node).Prev >= 0); - N (N (X).Next).Prev := N (X).Prev; - N (N (X).Prev).Next := N (X).Next; + N (N (X).Next).Prev := N (X).Prev; + N (N (X).Prev).Next := N (X).Next; - Free (Container.Plain.all, X); - end loop; - Position := No_Element; - end; + Free (Container, X); + end loop; + Position := No_Element; end Delete; ------------------ @@ -465,42 +331,35 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is (Container : in out List; Count : Count_Type := 1) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if Count >= Container.Length then + Clear (Container); + return; end if; - declare - N : Node_Array renames Container.Plain.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; + if Count = 0 then + return; + end if; - if Container.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; - for I in 1 .. Count loop - X := Container.First; - pragma Assert (N (N (X).Next).Prev = Container.First); + for I in 1 .. Count loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); - Container.First := N (X).Next; - N (Container.First).Prev := 0; + Container.First := N (X).Next; + N (Container.First).Prev := 0; - Container.Length := Container.Length - 1; + Container.Length := Container.Length - 1; - Free (Container.Plain.all, X); - end loop; - end; + Free (Container, X); + end loop; end Delete_First; ----------------- @@ -511,60 +370,41 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is (Container : in out List; Count : Count_Type := 1) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if Count >= Container.Length then + Clear (Container); + return; end if; - declare - N : Node_Array renames Container.Plain.Nodes; - X : Count_Type; + if Count = 0 then + return; + end if; - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; - if Count = 0 then - return; - end if; + for I in 1 .. Count loop + X := Container.Last; + pragma Assert (N (N (X).Prev).Next = Container.Last); - if Container.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; - for I in 1 .. Count loop - X := Container.Last; - pragma Assert (N (N (X).Prev).Next = Container.Last); + Container.Length := Container.Length - 1; - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Container.Length := Container.Length - 1; - - Free (Container.Plain.all, X); - end loop; - end; + Free (Container, X); + end loop; end Delete_Last; ------------- -- Element -- ------------- - function Element_Unchecked - (Container : List; - Position : Count_Type) return Element_Type is - begin - case Container.K is - when Plain => - return Container.Plain.Nodes (Position).Element; - when others => - return Container.Plain.all.Nodes (Position).Element; - end case; - end Element_Unchecked; - function Element (Container : List; Position : Cursor) return Element_Type is @@ -574,41 +414,13 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is "Position cursor has no element"; end if; - return Element_Unchecked (Container => Container, - Position => Position.Node); + return Container.Nodes (Position.Node).Element; end Element; ---------- -- Find -- ---------- - function Find_Between - (Container : Plain_List; - Item : Element_Type; - From : Count_Type; - To : Count_Type; - Bg : Count_Type) return Cursor - is - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type := Bg; - begin - while Node /= From loop - if Node = 0 or else Node = To then - raise Constraint_Error with - "Position cursor has no element"; - end if; - Node := Nodes (Node).Next; - end loop; - while Node /= Nodes (To).Next loop - if Nodes (Node).Element = Item then - return (Node => Node); - end if; - Node := Nodes (Node).Next; - end loop; - - return No_Element; - end Find_Between; - function Find (Container : List; Item : Element_Type; @@ -623,15 +435,19 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is From := Container.First; end if; if Position.Node /= 0 and then - not Has_Element_Base (Container.Plain.all, Position) then + not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor has no element"; end if; - return Find_Between (Container => Container.Plain.all, - Item => Item, - From => From, - To => Container.Last, - Bg => Container.First); + + while From /= 0 loop + if Container.Nodes (From).Element = Item then + return (Node => From); + end if; + From := Container.Nodes (From).Next; + end loop; + + return No_Element; end Find; ----------- @@ -656,7 +472,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is if F = 0 then raise Constraint_Error with "list is empty"; else - return Element_Unchecked (Container, F); + return Container.Nodes (F).Element; end if; end First_Element; @@ -665,7 +481,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ---------- procedure Free - (Container : in out Plain_List; + (Container : in out List; X : Count_Type) is pragma Assert (X > 0); @@ -714,7 +530,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - Nodes : Node_Array renames Container.Plain.all.Nodes; + Nodes : Node_Array renames Container.Nodes; Node : Count_Type := Container.First; begin for I in 2 .. Container.Length loop @@ -736,62 +552,55 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is (Target : in out List; Source : in out List) is + LN : Node_Array renames Target.Nodes; + RN : Node_Array renames Source.Nodes; + LI : Cursor; + RI : Cursor; + begin - if Target.K /= Plain or Source.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if Target'Address = Source'Address then + return; end if; - declare - LN : Node_Array renames Target.Plain.Nodes; - RN : Node_Array renames Source.Plain.Nodes; - LI : Cursor; - RI : Cursor; + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; - begin - if Target'Address = Source'Address then - return; - end if; + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; - if Target.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; + LI := First (Target); + RI := First (Source); + while RI.Node /= 0 loop + pragma Assert (RN (RI.Node).Next = 0 + or else not (RN (RN (RI.Node).Next).Element < + RN (RI.Node).Element)); - if Source.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + if LI.Node = 0 then + Splice (Target, No_Element, Source); + return; end if; - LI := First (Target); - RI := First (Source); - while RI.Node /= 0 loop - pragma Assert (RN (RI.Node).Next = 0 - or else not (RN (RN (RI.Node).Next).Element < - RN (RI.Node).Element)); + pragma Assert (LN (LI.Node).Next = 0 + or else not (LN (LN (LI.Node).Next).Element < + LN (LI.Node).Element)); - if LI.Node = 0 then - Splice (Target, No_Element, Source); - return; - end if; + if RN (RI.Node).Element < LN (LI.Node).Element then + declare + RJ : Cursor := RI; + pragma Warnings (Off, RJ); + begin + RI.Node := RN (RI.Node).Next; + Splice (Target, LI, Source, RJ); + end; - pragma Assert (LN (LI.Node).Next = 0 - or else not (LN (LN (LI.Node).Next).Element < - LN (LI.Node).Element)); - - if RN (RI.Node).Element < LN (LI.Node).Element then - declare - RJ : Cursor := RI; - pragma Warnings (Off, RJ); - begin - RI.Node := RN (RI.Node).Next; - Splice (Target, LI, Source, RJ); - end; - - else - LI.Node := LN (LI.Node).Next; - end if; - end loop; - end; + else + LI.Node := LN (LI.Node).Next; + end if; + end loop; end Merge; ---------- @@ -799,101 +608,94 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ---------- procedure Sort (Container : in out List) is - begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; - - declare - N : Node_Array renames Container.Plain.Nodes; - - procedure Partition (Pivot, Back : Count_Type); - procedure Sort (Front, Back : Count_Type); - - --------------- - -- Partition -- - --------------- + N : Node_Array renames Container.Nodes; - procedure Partition (Pivot, Back : Count_Type) is - Node : Count_Type := N (Pivot).Next; + procedure Partition (Pivot, Back : Count_Type); + procedure Sort (Front, Back : Count_Type); - begin - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; + --------------- + -- Partition -- + --------------- - begin - N (Prev).Next := Next; + procedure Partition (Pivot, Back : Count_Type) is + Node : Count_Type := N (Pivot).Next; - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; + begin + while Node /= Back loop + if N (Node).Element < N (Pivot).Element then + declare + Prev : constant Count_Type := N (Node).Prev; + Next : constant Count_Type := N (Node).Next; - N (Pivot).Prev := Node; + begin + N (Prev).Next := Next; - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; + if Next = 0 then + Container.Last := Prev; + else + N (Next).Prev := Prev; + end if; - Node := Next; - end; + N (Node).Next := Pivot; + N (Node).Prev := N (Pivot).Prev; - else - Node := N (Node).Next; - end if; - end loop; - end Partition; + N (Pivot).Prev := Node; - ---------- - -- Sort -- - ---------- + if N (Node).Prev = 0 then + Container.First := Node; + else + N (N (Node).Prev).Next := Node; + end if; - procedure Sort (Front, Back : Count_Type) is - Pivot : Count_Type; + Node := Next; + end; - begin - if Front = 0 then - Pivot := Container.First; else - Pivot := N (Front).Next; + Node := N (Node).Next; end if; + end loop; + end Partition; - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; + ---------- + -- Sort -- + ---------- - -- Start of processing for Sort + procedure Sort (Front, Back : Count_Type) is + Pivot : Count_Type; begin - if Container.Length <= 1 then - return; + if Front = 0 then + Pivot := Container.First; + else + Pivot := N (Front).Next; end if; - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - if Container.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); end if; + end Sort; - Sort (Front => 0, Back => 0); + -- Start of processing for Sort - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end; + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; + + Sort (Front => 0, Back => 0); + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); end Sort; end Generic_Sorting; @@ -902,38 +704,12 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is -- Has_Element -- ----------------- - function Has_Element_Base (Container : Plain_List; Position : Cursor) - return Boolean - is - begin - return Container.Nodes (Position.Node).Prev /= -1; - end Has_Element_Base; - function Has_Element (Container : List; Position : Cursor) return Boolean is begin if Position.Node = 0 then return False; end if; - - case Container.K is - when Plain => - return Container.Plain.Nodes (Position.Node).Prev /= -1; - when Part => - declare - Current : Count_Type := Container.First; - begin - if Container.Plain.Nodes (Position.Node).Prev = -1 then - return False; - end if; - while Current /= 0 loop - if Current = Position.Node then - return True; - end if; - Current := Next_Unchecked (Container, Current); - end loop; - return False; - end; - end case; + return Container.Nodes (Position.Node).Prev /= -1; end Has_Element; ------------ @@ -951,10 +727,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; - if Before.Node /= 0 then null; pragma Assert (Vet (Container, Before), "bad cursor in Insert"); @@ -969,7 +741,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error with "new length exceeds capacity"; end if; - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (list is busy)"; end if; @@ -1006,10 +778,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; - if Before.Node /= 0 then null; pragma Assert (Vet (Container, Before), "bad cursor in Insert"); @@ -1024,7 +792,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error with "new length exceeds capacity"; end if; - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (list is busy)"; end if; @@ -1048,57 +816,50 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is Before : Count_Type; New_Node : Count_Type) is - begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; - - declare - N : Node_Array renames Container.Plain.Nodes; + N : Node_Array renames Container.Nodes; - begin - if Container.Length = 0 then - pragma Assert (Before = 0); - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); + begin + if Container.Length = 0 then + pragma Assert (Before = 0); + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); - Container.First := New_Node; - Container.Last := New_Node; + Container.First := New_Node; + Container.Last := New_Node; - N (Container.First).Prev := 0; - N (Container.Last).Next := 0; + N (Container.First).Prev := 0; + N (Container.Last).Next := 0; - elsif Before = 0 then - pragma Assert (N (Container.Last).Next = 0); + elsif Before = 0 then + pragma Assert (N (Container.Last).Next = 0); - N (Container.Last).Next := New_Node; - N (New_Node).Prev := Container.Last; + N (Container.Last).Next := New_Node; + N (New_Node).Prev := Container.Last; - Container.Last := New_Node; - N (Container.Last).Next := 0; + Container.Last := New_Node; + N (Container.Last).Next := 0; - elsif Before = Container.First then - pragma Assert (N (Container.First).Prev = 0); + elsif Before = Container.First then + pragma Assert (N (Container.First).Prev = 0); - N (Container.First).Prev := New_Node; - N (New_Node).Next := Container.First; + N (Container.First).Prev := New_Node; + N (New_Node).Next := Container.First; - Container.First := New_Node; - N (Container.First).Prev := 0; + Container.First := New_Node; + N (Container.First).Prev := 0; - else - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); + else + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); - N (New_Node).Next := Before; - N (New_Node).Prev := N (Before).Prev; + N (New_Node).Next := Before; + N (New_Node).Prev := N (Before).Prev; - N (N (Before).Prev).Next := New_Node; - N (Before).Prev := New_Node; - end if; + N (N (Before).Prev).Next := New_Node; + N (Before).Prev := New_Node; + end if; - Container.Length := Container.Length + 1; - end; + Container.Length := Container.Length + 1; end Insert_Internal; -------------- @@ -1114,27 +875,23 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is -- Iterate -- ------------- - procedure Iterate_Between + procedure Iterate (Container : List; - From : Count_Type; - To : Count_Type; Process : - not null access procedure (Container : List; Position : Cursor)) + not null access procedure (Container : List; Position : Cursor)) is - C : Plain_List renames Container.Plain.all; - N : Node_Array renames C.Nodes; + C : List renames Container'Unrestricted_Access.all; B : Natural renames C.Busy; - Node : Count_Type := From; + Node : Count_Type := Container.First; begin B := B + 1; begin - while Node /= N (To).Next loop - pragma Assert (N (Node).Prev >= 0); - Process (Container, Position => (Node => Node)); - Node := N (Node).Next; + while Node /= 0 loop + Process (Container, (Node => Node)); + Node := Container.Nodes (Node).Next; end loop; exception when others => @@ -1143,18 +900,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is end; B := B - 1; - end Iterate_Between; - - procedure Iterate - (Container : List; - Process : - not null access procedure (Container : List; Position : Cursor)) - is - begin - if Container.Length = 0 then - return; - end if; - Iterate_Between (Container, Container.First, Container.Last, Process); end Iterate; ---------- @@ -1179,7 +924,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is if L = 0 then raise Constraint_Error with "list is empty"; else - return Element_Unchecked (Container, L); + return Container.Nodes (L).Element; end if; end Last_Element; @@ -1188,57 +933,23 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ---------- function Left (Container : List; Position : Cursor) return List is - L : Count_Type := 0; - C : Count_Type := Container.First; - LLe : Count_Type; - LF : Count_Type; - LLa : Count_Type; + Curs : Cursor := Position; + C : List (Container.Capacity) := Copy (Container, Container.Capacity); + Node : Count_Type; begin - case Container.K is - when Plain => - LLe := Container.Length; - LF := Container.First; - LLa := Container.Last; - when Part => - LLe := Container.Part.LLength; - LF := Container.Part.LFirst; - LLa := Container.Part.LLast; - end case; - if Position.Node = 0 then - return (Capacity => Container.Capacity, - K => Part, - Length => Container.Length, - First => Container.First, - Last => Container.Last, - Plain => Container.Plain, - Part => (LLength => LLe, LFirst => LF, LLast => LLa)); - else - while C /= Position.Node loop - if C = Container.Last or C = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - C := Next_Unchecked (Container, C); - L := L + 1; - end loop; - if L = 0 then - return (Capacity => Container.Capacity, - K => Part, - Length => 0, - First => 0, - Last => 0, - Plain => Container.Plain, - Part => (LLength => LLe, LFirst => LF, LLast => LLa)); - else - return (Capacity => Container.Capacity, - K => Part, - Length => L, - First => Container.First, - Last => Container.Plain.Nodes (C).Prev, - Plain => Container.Plain, - Part => (LLength => LLe, LFirst => LF, LLast => LLa)); - end if; + if Curs = No_Element then + return C; + end if; + if not Has_Element (Container, Curs) then + raise Constraint_Error; end if; + + while Curs.Node /= 0 loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); + end loop; + return C; end Left; ------------ @@ -1258,44 +969,36 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is (Target : in out List; Source : in out List) is + N : Node_Array renames Source.Nodes; + X : Count_Type; + begin - if Target.K /= Plain or Source.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if Target'Address = Source'Address then + return; end if; - declare - - N : Node_Array renames Source.Plain.Nodes; - X : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; + if Target.Capacity < Source.Length then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; - if Source.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; - Clear (Target); + Clear (Target); - while Source.Length > 0 loop - X := Source.First; - Append (Target, N (X).Element); -- optimize away??? + while Source.Length > 0 loop + X := Source.First; + Append (Target, N (X).Element); -- optimize away??? - Source.First := N (X).Next; - N (Source.First).Prev := 0; + Source.First := N (X).Next; + N (Source.First).Prev := 0; - Source.Length := Source.Length - 1; - Free (Source.Plain.all, X); - end loop; - end; + Source.Length := Source.Length - 1; + Free (Source, X); + end loop; end Move; ---------- @@ -1315,25 +1018,9 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is if not Has_Element (Container, Position) then raise Program_Error with "Position cursor has no element"; end if; - return (Node => Next_Unchecked (Container, Position.Node)); + return (Node => Container.Nodes (Position.Node).Next); end Next; - function Next_Unchecked (Container : List; Position : Count_Type) - return Count_Type - is - begin - case Container.K is - when Plain => - return Container.Plain.Nodes (Position).Next; - when Part => - if Position = Container.Last then - return 0; - else - return Container.Plain.Nodes (Position).Next; - end if; - end case; - end Next_Unchecked; - ------------- -- Prepend -- ------------- @@ -1365,32 +1052,27 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is if not Has_Element (Container, Position) then raise Program_Error with "Position cursor has no element"; end if; - - case Container.K is - when Plain => - return (Node => Container.Plain.Nodes (Position.Node).Prev); - when Part => - if Container.First = Position.Node then - return No_Element; - else - return (Node => Container.Plain.Nodes (Position.Node).Prev); - end if; - end case; + return (Node => Container.Nodes (Position.Node).Prev); end Previous; ------------------- -- Query_Element -- ------------------- - procedure Query_Element_Plain - (Container : Plain_List; Position : Cursor; + procedure Query_Element + (Container : List; Position : Cursor; Process : not null access procedure (Element : Element_Type)) is - C : Plain_List renames Container'Unrestricted_Access.all; + C : List renames Container'Unrestricted_Access.all; B : Natural renames C.Busy; L : Natural renames C.Lock; begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor has no element"; + end if; + B := B + 1; L := L + 1; @@ -1407,18 +1089,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is L := L - 1; B := B - 1; - end Query_Element_Plain; - - procedure Query_Element - (Container : List; Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor has no element"; - end if; - Query_Element_Plain (Container.Plain.all, Position, Process); end Query_Element; ---------- @@ -1471,15 +1141,12 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is New_Item : Element_Type) is begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor has no element"; end if; - if Container.Plain.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (list is locked)"; end if; @@ -1488,7 +1155,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is "bad cursor in Replace_Element"); declare - N : Node_Array renames Container.Plain.Nodes; + N : Node_Array renames Container.Nodes; begin N (Position.Node).Element := New_Item; end; @@ -1499,119 +1166,93 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ---------------------- procedure Reverse_Elements (Container : in out List) is - begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; - - declare - N : Node_Array renames Container.Plain.Nodes; - I : Count_Type := Container.First; - J : Count_Type := Container.Last; + N : Node_Array renames Container.Nodes; + I : Count_Type := Container.First; + J : Count_Type := Container.Last; - procedure Swap (L, R : Count_Type); + procedure Swap (L, R : Count_Type); - ---------- - -- Swap -- - ---------- + ---------- + -- Swap -- + ---------- - procedure Swap (L, R : Count_Type) is - LN : constant Count_Type := N (L).Next; - LP : constant Count_Type := N (L).Prev; + procedure Swap (L, R : Count_Type) is + LN : constant Count_Type := N (L).Next; + LP : constant Count_Type := N (L).Prev; - RN : constant Count_Type := N (R).Next; - RP : constant Count_Type := N (R).Prev; + RN : constant Count_Type := N (R).Next; + RP : constant Count_Type := N (R).Prev; - begin - if LP /= 0 then - N (LP).Next := R; - end if; + begin + if LP /= 0 then + N (LP).Next := R; + end if; - if RN /= 0 then - N (RN).Prev := L; - end if; + if RN /= 0 then + N (RN).Prev := L; + end if; - N (L).Next := RN; - N (R).Prev := LP; + N (L).Next := RN; + N (R).Prev := LP; - if LN = R then - pragma Assert (RP = L); + if LN = R then + pragma Assert (RP = L); - N (L).Prev := R; - N (R).Next := L; + N (L).Prev := R; + N (R).Next := L; - else - N (L).Prev := RP; - N (RP).Next := L; + else + N (L).Prev := RP; + N (RP).Next := L; - N (R).Next := LN; - N (LN).Prev := R; - end if; - end Swap; + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; - -- Start of processing for Reverse_Elements + -- Start of processing for Reverse_Elements - begin - if Container.Length <= 1 then - return; - end if; + begin + if Container.Length <= 1 then + return; + end if; - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); - if Container.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; - Container.First := J; - Container.Last := I; - loop - Swap (L => I, R => J); + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); - J := N (J).Next; - exit when I = J; + J := N (J).Next; + exit when I = J; - I := N (I).Prev; - exit when I = J; + I := N (I).Prev; + exit when I = J; - Swap (L => J, R => I); + Swap (L => J, R => I); - I := N (I).Next; - exit when I = J; + I := N (I).Next; + exit when I = J; - J := N (J).Prev; - exit when I = J; - end loop; + J := N (J).Prev; + exit when I = J; + end loop; - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end; + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); end Reverse_Elements; ------------------ -- Reverse_Find -- ------------------ - function Reverse_Find_Between - (Container : Plain_List; - Item : Element_Type; - From : Count_Type; - To : Count_Type) return Cursor - is - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type := To; - begin - while Node /= Nodes (From).Prev loop - if Nodes (Node).Element = Item then - return (Node => Node); - end if; - Node := Nodes (Node).Prev; - end loop; - - return No_Element; - end Reverse_Find_Between; - function Reverse_Find (Container : List; Item : Element_Type; @@ -1626,37 +1267,38 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is if Container.Length = 0 then return No_Element; end if; - return Reverse_Find_Between (Container => Container.Plain.all, - Item => Item, - From => CFirst, - To => Container.Last); + + while CFirst /= 0 loop + if Container.Nodes (CFirst).Element = Item then + return (Node => CFirst); + end if; + CFirst := Container.Nodes (CFirst).Prev; + end loop; + + return No_Element; end Reverse_Find; --------------------- -- Reverse_Iterate -- --------------------- - procedure Reverse_Iterate_Between + procedure Reverse_Iterate (Container : List; - From : Count_Type; - To : Count_Type; Process : - not null access procedure (Container : List; Position : Cursor)) + not null access procedure (Container : List; Position : Cursor)) is - C : Plain_List renames Container.Plain.all; - N : Node_Array renames C.Nodes; + C : List renames Container'Unrestricted_Access.all; B : Natural renames C.Busy; - Node : Count_Type := To; + Node : Count_Type := Container.Last; begin B := B + 1; begin - while Node /= N (From).Prev loop - pragma Assert (N (Node).Prev >= 0); - Process (Container, Position => (Node => Node)); - Node := N (Node).Prev; + while Node /= 0 loop + Process (Container, (Node => Node)); + Node := Container.Nodes (Node).Prev; end loop; exception @@ -1666,19 +1308,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is end; B := B - 1; - end Reverse_Iterate_Between; - - procedure Reverse_Iterate - (Container : List; - Process : - not null access procedure (Container : List; Position : Cursor)) - is - begin - if Container.Length = 0 then - return; - end if; - Reverse_Iterate_Between - (Container, Container.First, Container.Last, Process); end Reverse_Iterate; ----------- @@ -1686,47 +1315,24 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ----------- function Right (Container : List; Position : Cursor) return List is - L : Count_Type := 0; - C : Count_Type := Container.First; - LLe : Count_Type; - LF : Count_Type; - LLa : Count_Type; + Curs : Cursor := First (Container); + C : List (Container.Capacity) := Copy (Container, Container.Capacity); + Node : Count_Type; begin - case Container.K is - when Plain => - LLe := Container.Length; - LF := Container.First; - LLa := Container.Last; - when Part => - LLe := Container.Part.LLength; - LF := Container.Part.LFirst; - LLa := Container.Part.LLast; - end case; - if Position.Node = 0 then - return (Capacity => Container.Capacity, - K => Part, - Length => 0, - First => 0, - Last => 0, - Plain => Container.Plain, - Part => (LLength => LLe, LFirst => LF, LLast => LLa)); - else - while C /= Position.Node loop - if C = Container.Last or C = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - C := Next_Unchecked (Container, C); - L := L + 1; - end loop; - return (Capacity => Container.Capacity, - K => Part, - Length => Container.Length - L, - First => Position.Node, - Last => Container.Last, - Plain => Container.Plain, - Part => (LLength => LLe, LFirst => LF, LLast => LLa)); + if Curs = No_Element then + Clear (C); + return C; + end if; + if Position /= No_Element and not Has_Element (Container, Position) then + raise Constraint_Error; end if; + + while Curs.Node /= Position.Node loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); + end loop; + return C; end Right; ------------ @@ -1738,53 +1344,46 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is Before : Cursor; Source : in out List) is + SN : Node_Array renames Source.Nodes; + begin - if Target.K /= Plain or Source.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if Before.Node /= 0 then + null; + pragma Assert (Vet (Target, Before), "bad cursor in Splice"); end if; - declare - SN : Node_Array renames Source.Plain.Nodes; - - begin - if Before.Node /= 0 then - null; - pragma Assert (Vet (Target, Before), "bad cursor in Splice"); - end if; - - if Target'Address = Source'Address - or else Source.Length = 0 - then - return; - end if; + if Target'Address = Source'Address + or else Source.Length = 0 + then + return; + end if; - pragma Assert (SN (Source.First).Prev = 0); - pragma Assert (SN (Source.Last).Next = 0); + pragma Assert (SN (Source.First).Prev = 0); + pragma Assert (SN (Source.Last).Next = 0); - if Target.Length > Count_Type'Base'Last - Source.Length then - raise Constraint_Error with "new length exceeds maximum"; - end if; + if Target.Length > Count_Type'Base'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; - if Target.Length + Source.Length > Target.Capacity then - raise Constraint_Error; - end if; + if Target.Length + Source.Length > Target.Capacity then + raise Constraint_Error; + end if; - if Target.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; - if Source.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; - loop - Insert (Target, Before, SN (Source.Last).Element); - Delete_Last (Source); - exit when Is_Empty (Source); - end loop; - end; + loop + Insert (Target, Before, SN (Source.Last).Element); + Delete_Last (Source); + exit when Is_Empty (Source); + end loop; end Splice; procedure Splice @@ -1796,9 +1395,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is Target_Position : Cursor; begin - if Target.K /= Plain or Source.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; if Target'Address = Source'Address then Splice (Target, Before, Position); @@ -1815,12 +1411,12 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error; end if; - if Target.Plain.Busy > 0 then + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; end if; - if Source.Plain.Busy > 0 then + if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; @@ -1828,7 +1424,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is Insert (Container => Target, Before => Before, - New_Item => Source.Plain.Nodes (Position.Node).Element, + New_Item => Source.Nodes (Position.Node).Element, Position => Target_Position); Delete (Source, Position); @@ -1840,105 +1436,98 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is Before : Cursor; Position : Cursor) is + N : Node_Array renames Container.Nodes; + begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if Before.Node /= 0 then + null; + pragma Assert (Vet (Container, Before), + "bad Before cursor in Splice"); end if; - declare - N : Node_Array renames Container.Plain.Nodes; + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; - begin - if Before.Node /= 0 then - null; - pragma Assert (Vet (Container, Before), - "bad Before cursor in Splice"); - end if; + pragma Assert (Vet (Container, Position), + "bad Position cursor in Splice"); - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Position.Node = Before.Node + or else N (Position.Node).Next = Before.Node + then + return; + end if; - pragma Assert (Vet (Container, Position), - "bad Position cursor in Splice"); + pragma Assert (Container.Length >= 2); - if Position.Node = Before.Node - or else N (Position.Node).Next = Before.Node - then - return; - end if; + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; - pragma Assert (Container.Length >= 2); + if Before.Node = 0 then + pragma Assert (Position.Node /= Container.Last); - if Container.Plain.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; end if; - if Before.Node = 0 then - pragma Assert (Position.Node /= Container.Last); + N (Container.Last).Next := Position.Node; + N (Position.Node).Prev := Container.Last; - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; + Container.Last := Position.Node; + N (Container.Last).Next := 0; - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; + return; + end if; - N (Container.Last).Next := Position.Node; - N (Position.Node).Prev := Container.Last; + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); - Container.Last := Position.Node; + if Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; N (Container.Last).Next := 0; - return; + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; end if; - if Before.Node = Container.First then - pragma Assert (Position.Node /= Container.First); - - if Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.First).Prev := Position.Node; - N (Position.Node).Next := Container.First; + N (Container.First).Prev := Position.Node; + N (Position.Node).Next := Container.First; - Container.First := Position.Node; - N (Container.First).Prev := 0; + Container.First := Position.Node; + N (Container.First).Prev := 0; - return; - end if; + return; + end if; - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; - elsif Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; + elsif Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; - N (N (Before.Node).Prev).Next := Position.Node; - N (Position.Node).Prev := N (Before.Node).Prev; + N (N (Before.Node).Prev).Next := Position.Node; + N (Position.Node).Prev := N (Before.Node).Prev; - N (Before.Node).Prev := Position.Node; - N (Position.Node).Next := Before.Node; + N (Before.Node).Prev := Position.Node; + N (Position.Node).Next := Before.Node; - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end; + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); end Splice; ------------------ @@ -1951,11 +1540,11 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is begin while CL /= 0 or CR /= 0 loop if CL /= CR or else - Element_Unchecked (Left, CL) /= Element_Unchecked (Right, CL) then + Left.Nodes (CL).Element /= Right.Nodes (CL).Element then return False; end if; - CL := Next_Unchecked (Left, CL); - CR := Next_Unchecked (Right, CR); + CL := Left.Nodes (CL).Next; + CR := Right.Nodes (CR).Next; end loop; return True; end Strict_Equal; @@ -1969,9 +1558,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is I, J : Cursor) is begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; if I.Node = 0 then raise Constraint_Error with "I cursor has no element"; @@ -1985,7 +1571,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return; end if; - if Container.Plain.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (list is locked)"; end if; @@ -1994,7 +1580,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is pragma Assert (Vet (Container, J), "bad J cursor in Swap"); declare - NN : Node_Array renames Container.Plain.Nodes; + NN : Node_Array renames Container.Nodes; NI : Node_Type renames NN (I.Node); NJ : Node_Type renames NN (J.Node); @@ -2017,9 +1603,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is I_Next, J_Next : Cursor; begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; if I.Node = 0 then raise Constraint_Error with "I cursor has no element"; @@ -2033,7 +1616,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return; end if; - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (list is busy)"; end if; @@ -2070,9 +1653,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is Process : not null access procedure (Element : in out Element_Type)) is begin - if Container.K /= Plain then - raise Program_Error with "cannot modify part of container"; - end if; if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; @@ -2082,15 +1662,15 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is "bad cursor in Update_Element"); declare - B : Natural renames Container.Plain.Busy; - L : Natural renames Container.Plain.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; L := L + 1; declare - N : Node_Type renames Container.Plain.Nodes (Position.Node); + N : Node_Type renames Container.Nodes (Position.Node); begin Process (N.Element); exception @@ -2110,174 +1690,155 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is --------- function Vet (L : List; Position : Cursor) return Boolean is + N : Node_Array renames L.Nodes; + begin - if L.K /= Plain then - raise Program_Error with "cannot modify part of container"; + if L.Length = 0 then + return False; end if; - declare - N : Node_Array renames L.Plain.Nodes; + if L.First = 0 then + return False; + end if; - begin - if L.Length = 0 then - return False; - end if; + if L.Last = 0 then + return False; + end if; - if L.First = 0 then - return False; - end if; + if Position.Node > L.Capacity then + return False; + end if; - if L.Last = 0 then - return False; - end if; + if N (Position.Node).Prev < 0 + or else N (Position.Node).Prev > L.Capacity + then + return False; + end if; - if Position.Node > L.Capacity then - return False; - end if; + if N (Position.Node).Next > L.Capacity then + return False; + end if; - if N (Position.Node).Prev < 0 - or else N (Position.Node).Prev > L.Capacity - then - return False; - end if; + if N (L.First).Prev /= 0 then + return False; + end if; - if N (Position.Node).Next > L.Capacity then - return False; - end if; + if N (L.Last).Next /= 0 then + return False; + end if; - if N (L.First).Prev /= 0 then - return False; - end if; + if N (Position.Node).Prev = 0 + and then Position.Node /= L.First + then + return False; + end if; - if N (L.Last).Next /= 0 then - return False; - end if; + if N (Position.Node).Next = 0 + and then Position.Node /= L.Last + then + return False; + end if; - if N (Position.Node).Prev = 0 - and then Position.Node /= L.First - then - return False; - end if; + if L.Length = 1 then + return L.First = L.Last; + end if; - if N (Position.Node).Next = 0 - and then Position.Node /= L.Last - then - return False; - end if; + if L.First = L.Last then + return False; + end if; - if L.Length = 1 then - return L.First = L.Last; - end if; + if N (L.First).Next = 0 then + return False; + end if; - if L.First = L.Last then - return False; - end if; + if N (L.Last).Prev = 0 then + return False; + end if; - if N (L.First).Next = 0 then - return False; - end if; + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; - if N (L.Last).Prev = 0 then - return False; - end if; + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; - if N (N (L.First).Next).Prev /= L.First then + if L.Length = 2 then + if N (L.First).Next /= L.Last then return False; end if; - if N (N (L.Last).Prev).Next /= L.Last then + if N (L.Last).Prev /= L.First then return False; end if; - if L.Length = 2 then - if N (L.First).Next /= L.Last then - return False; - end if; + return True; + end if; - if N (L.Last).Prev /= L.First then - return False; - end if; + if N (L.First).Next = L.Last then + return False; + end if; - return True; - end if; + if N (L.Last).Prev = L.First then + return False; + end if; - if N (L.First).Next = L.Last then - return False; - end if; + if Position.Node = L.First then + return True; + end if; - if N (L.Last).Prev = L.First then - return False; - end if; + if Position.Node = L.Last then + return True; + end if; - if Position.Node = L.First then - return True; - end if; + if N (Position.Node).Next = 0 then + return False; + end if; - if Position.Node = L.Last then - return True; - end if; + if N (Position.Node).Prev = 0 then + return False; + end if; - if N (Position.Node).Next = 0 then - return False; - end if; + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; - if N (Position.Node).Prev = 0 then - return False; - end if; + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + end if; - if N (N (Position.Node).Next).Prev /= Position.Node then + if L.Length = 3 then + if N (L.First).Next /= Position.Node then return False; end if; - if N (N (Position.Node).Prev).Next /= Position.Node then + if N (L.Last).Prev /= Position.Node then return False; end if; + end if; - if L.Length = 3 then - if N (L.First).Next /= Position.Node then - return False; - end if; - - if N (L.Last).Prev /= Position.Node then - return False; - end if; - end if; - - return True; - end; + return True; end Vet; ----------- -- Write -- ----------- - procedure Write_Between + procedure Write (Stream : not null access Root_Stream_Type'Class; - Item : Plain_List; - Length : Count_Type; - From : Count_Type; - To : Count_Type) is - + Item : List) + is N : Node_Array renames Item.Nodes; Node : Count_Type; begin - Count_Type'Base'Write (Stream, Length); + Count_Type'Base'Write (Stream, Item.Length); - Node := From; - while Node /= N (To).Next loop + Node := Item.First; + while Node /= 0 loop Element_Type'Write (Stream, N (Node).Element); Node := N (Node).Next; end loop; - end Write_Between; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List) - is - begin - Write_Between - (Stream, Item.Plain.all, Item.Length, Item.First, Item.Last); end Write; procedure Write diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index d961cb9535c..714ce6761f4 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -251,33 +251,14 @@ private type Node_Array is array (Count_Type range <>) of Node_Type; function "=" (L, R : Node_Array) return Boolean is abstract; - type List_Access is access all List; - for List_Access'Storage_Size use 0; - - type Kind is (Plain, Part); - - type Plain_List (Capacity : Count_Type) is record + type List (Capacity : Count_Type) is tagged record Nodes : Node_Array (1 .. Capacity) := (others => <>); Free : Count_Type'Base := -1; Busy : Natural := 0; Lock : Natural := 0; - end record; - - type PList_Access is access Plain_List; - - type Part_List is record - LLength : Count_Type := 0; - LFirst : Count_Type := 0; - LLast : Count_Type := 0; - end record; - - type List (Capacity : Count_Type) is tagged record - K : Kind := Plain; Length : Count_Type := 0; First : Count_Type := 0; Last : Count_Type := 0; - Part : Part_List; - Plain : PList_Access := new Plain_List'(Capacity, others => <>); end record; use Ada.Streams; diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index 34a8a43f1fc..5bcafe2d293 100644 --- a/gcc/ada/a-cfhama.adb +++ b/gcc/ada/a-cfhama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-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- -- @@ -46,29 +46,19 @@ package body Ada.Containers.Formal_Hashed_Maps is Node : Node_Type) return Boolean; pragma Inline (Equivalent_Keys); - function Find_Between - (HT : Hash_Table_Type; - Key : Key_Type; - From : Count_Type; - To : Count_Type) return Count_Type; - procedure Free - (HT : in out Hash_Table_Type; + (HT : in out Map; X : Count_Type); generic with procedure Set_Element (Node : in out Node_Type); procedure Generic_Allocate - (HT : in out Hash_Table_Type; + (HT : in out Map; Node : out Count_Type); function Hash_Node (Node : Node_Type) return Hash_Type; pragma Inline (Hash_Node); - function Next_Unchecked - (Container : Map; - Position : Cursor) return Cursor; - function Next (Node : Node_Type) return Count_Type; pragma Inline (Next); @@ -113,27 +103,20 @@ package body Ada.Containers.Formal_Hashed_Maps is end if; declare - Node : Count_Type := First (Left).Node; + Node : Count_Type := Left.First.Node; ENode : Count_Type; - Last : Count_Type; begin - if Left.K = Plain then - Last := 0; - else - Last := HT_Ops.Next (Left.HT.all, Left.Last); - end if; - - while Node /= Last loop + while Node /= 0 loop ENode := Find (Container => Right, - Key => Left.HT.Nodes (Node).Key).Node; + Key => Left.Nodes (Node).Key).Node; if ENode = 0 or else - Right.HT.Nodes (ENode).Element /= Left.HT.Nodes (Node).Element + Right.Nodes (ENode).Element /= Left.Nodes (Node).Element then return False; end if; - Node := HT_Ops.Next (Left.HT.all, Node); + Node := HT_Ops.Next (Left, Node); end loop; return True; @@ -158,7 +141,7 @@ package body Ada.Containers.Formal_Hashed_Maps is -------------------- procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.HT.Nodes (Source_Node); + N : Node_Type renames Source.Nodes (Source_Node); begin Target.Insert (N.Key, N.Element); end Insert_Element; @@ -166,10 +149,6 @@ package body Ada.Containers.Formal_Hashed_Maps is -- Start of processing for Assign begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Target'Address = Source'Address then return; @@ -182,19 +161,7 @@ package body Ada.Containers.Formal_Hashed_Maps is Clear (Target); -- checks busy bits - case Source.K is - when Plain => - Insert_Elements (Source.HT.all); - when Part => - declare - N : Count_Type := Source.First; - begin - while N /= HT_Ops.Next (Source.HT.all, Source.Last) loop - Insert_Element (N); - N := HT_Ops.Next (Source.HT.all, N); - end loop; - end; - end case; + Insert_Elements (Source); end Assign; -------------- @@ -203,7 +170,7 @@ package body Ada.Containers.Formal_Hashed_Maps is function Capacity (Container : Map) return Count_Type is begin - return Container.HT.Nodes'Length; + return Container.Nodes'Length; end Capacity; ----------- @@ -212,13 +179,7 @@ package body Ada.Containers.Formal_Hashed_Maps is procedure Clear (Container : in out Map) is begin - - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - HT_Ops.Clear (Container.HT.all); + HT_Ops.Clear (Container); end Clear; -------------- @@ -245,40 +206,22 @@ package body Ada.Containers.Formal_Hashed_Maps is Target : Map (C, Source.Modulus); Cu : Cursor; begin - if (Source.K = Part and Source.Length = 0) or - Source.HT.Length = 0 then - return Target; - end if; - Target.HT.Length := Source.HT.Length; - Target.HT.Free := Source.HT.Free; + Target.Length := Source.Length; + Target.Free := Source.Free; while H <= Source.Modulus loop - Target.HT.Buckets (H) := Source.HT.Buckets (H); + Target.Buckets (H) := Source.Buckets (H); H := H + 1; end loop; while N <= Source.Capacity loop - Target.HT.Nodes (N) := Source.HT.Nodes (N); + Target.Nodes (N) := Source.Nodes (N); N := N + 1; end loop; while N <= C loop Cu := (Node => N); - Free (Target.HT.all, Cu.Node); + Free (Target, Cu.Node); N := N + 1; end loop; - if Source.K = Part then - N := HT_Ops.First (Target.HT.all); - while N /= Source.First loop - Cu := (Node => N); - N := HT_Ops.Next (Target.HT.all, N); - Delete (Target, Cu); - end loop; - N := HT_Ops.Next (Target.HT.all, Source.Last); - while N /= 0 loop - Cu := (Node => N); - N := HT_Ops.Next (Target.HT.all, N); - Delete (Target, Cu); - end loop; - end if; return Target; end Copy; @@ -300,43 +243,33 @@ package body Ada.Containers.Formal_Hashed_Maps is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - Key_Ops.Delete_Key_Sans_Free (Container.HT.all, Key, X); + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); if X = 0 then raise Constraint_Error with "attempt to delete key not in map"; end if; - Free (Container.HT.all, X); + Free (Container, X); end Delete; procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Delete has no element"; end if; - if Container.HT.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "Delete attempted to tamper with elements (map is busy)"; end if; pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - HT_Ops.Delete_Node_Sans_Free (Container.HT.all, Position.Node); + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - Free (Container.HT.all, Position.Node); + Free (Container, Position.Node); end Delete; ------------- @@ -352,7 +285,7 @@ package body Ada.Containers.Formal_Hashed_Maps is "no element available because key not in map"; end if; - return Container.HT.Nodes (Node).Element; + return Container.Nodes (Node).Element; end Element; function Element (Container : Map; Position : Cursor) return Element_Type is @@ -364,7 +297,7 @@ package body Ada.Containers.Formal_Hashed_Maps is pragma Assert (Vet (Container, Position), "bad cursor in function Element"); - return Container.HT.Nodes (Position.Node).Element; + return Container.Nodes (Position.Node).Element; end Element; --------------------- @@ -398,11 +331,9 @@ package body Ada.Containers.Formal_Hashed_Maps is "Right cursor of Equivalent_Keys is bad"); declare - LT : Hash_Table_Type renames Left.HT.all; - RT : Hash_Table_Type renames Right.HT.all; - LN : Node_Type renames LT.Nodes (CLeft.Node); - RN : Node_Type renames RT.Nodes (CRight.Node); + LN : Node_Type renames Left.Nodes (CLeft.Node); + RN : Node_Type renames Right.Nodes (CRight.Node); begin return Equivalent_Keys (LN.Key, RN.Key); @@ -423,8 +354,7 @@ package body Ada.Containers.Formal_Hashed_Maps is "Left cursor in Equivalent_Keys is bad"); declare - LT : Hash_Table_Type renames Left.HT.all; - LN : Node_Type renames LT.Nodes (CLeft.Node); + LN : Node_Type renames Left.Nodes (CLeft.Node); begin return Equivalent_Keys (LN.Key, Right); @@ -445,8 +375,7 @@ package body Ada.Containers.Formal_Hashed_Maps is "Right cursor of Equivalent_Keys is bad"); declare - RT : Hash_Table_Type renames Right.HT.all; - RN : Node_Type renames RT.Nodes (CRight.Node); + RN : Node_Type renames Right.Nodes (CRight.Node); begin return Equivalent_Keys (Left, RN.Key); @@ -460,85 +389,24 @@ package body Ada.Containers.Formal_Hashed_Maps is procedure Exclude (Container : in out Map; Key : Key_Type) is X : Count_Type; begin - - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - Key_Ops.Delete_Key_Sans_Free (Container.HT.all, Key, X); - Free (Container.HT.all, X); + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Free (Container, X); end Exclude; ---------- -- Find -- ---------- - function Find_Between - (HT : Hash_Table_Type; - Key : Key_Type; - From : Count_Type; - To : Count_Type) return Count_Type is - - Indx : Hash_Type; - Indx_From : constant Hash_Type := - Key_Ops.Index (HT, HT.Nodes (From).Key); - Indx_To : constant Hash_Type := - Key_Ops.Index (HT, HT.Nodes (To).Key); - Node : Count_Type; - To_Node : Count_Type; - - begin - - Indx := Key_Ops.Index (HT, Key); - - if Indx < Indx_From or Indx > Indx_To then - return 0; - end if; - - if Indx = Indx_From then - Node := From; - else - Node := HT.Buckets (Indx); - end if; - - if Indx = Indx_To then - To_Node := HT.Nodes (To).Next; - else - To_Node := 0; - end if; - - while Node /= To_Node loop - if Equivalent_Keys (Key, HT.Nodes (Node)) then - return Node; - end if; - Node := HT.Nodes (Node).Next; - end loop; - return 0; - end Find_Between; function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := + Key_Ops.Find (Container, Key); + begin - case Container.K is - when Plain => - declare - Node : constant Count_Type := - Key_Ops.Find (Container.HT.all, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - when Part => - if Container.Length = 0 then - return No_Element; - end if; + if Node = 0 then + return No_Element; + end if; - return (Node => Find_Between (Container.HT.all, Key, - Container.First, Container.Last)); - end case; + return (Node => Node); end Find; ----------- @@ -546,31 +414,15 @@ package body Ada.Containers.Formal_Hashed_Maps is ----------- function First (Container : Map) return Cursor is + Node : constant Count_Type := HT_Ops.First (Container); + begin - case Container.K is - when Plain => - declare - Node : constant Count_Type := HT_Ops.First (Container.HT.all); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - when Part => - declare - Node : constant Count_Type := Container.First; - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end case; + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end First; ---------- @@ -578,7 +430,7 @@ package body Ada.Containers.Formal_Hashed_Maps is ---------- procedure Free - (HT : in out Hash_Table_Type; + (HT : in out Map; X : Count_Type) is begin @@ -591,7 +443,7 @@ package body Ada.Containers.Formal_Hashed_Maps is ---------------------- procedure Generic_Allocate - (HT : in out Hash_Table_Type; + (HT : in out Map; Node : out Count_Type) is @@ -610,57 +462,10 @@ package body Ada.Containers.Formal_Hashed_Maps is function Has_Element (Container : Map; Position : Cursor) return Boolean is begin if Position.Node = 0 or else - not Container.HT.Nodes (Position.Node).Has_Element then + not Container.Nodes (Position.Node).Has_Element then return False; end if; - - if Container.K = Plain then - return True; - end if; - - declare - Lst_Index : constant Hash_Type := - Key_Ops.Index (Container.HT.all, - Container.HT.Nodes (Container.Last).Key); - Fst_Index : constant Hash_Type := - Key_Ops.Index (Container.HT.all, - Container.HT.Nodes (Container.First).Key); - Index : constant Hash_Type := - Key_Ops.Index (Container.HT.all, - Container.HT.Nodes (Position.Node).Key); - Lst_Node : Count_Type; - Node : Count_Type; - begin - - if Index < Fst_Index or Index > Lst_Index then - return False; - end if; - - if Index > Fst_Index and Index < Lst_Index then - return True; - end if; - - if Index = Fst_Index then - Node := Container.First; - else - Node := Container.HT.Buckets (Index); - end if; - - if Index = Lst_Index then - Lst_Node := Container.HT.Nodes (Container.Last).Next; - else - Lst_Node := 0; - end if; - - while Node /= Lst_Node loop - if Position.Node = Node then - return True; - end if; - Node := HT_Ops.Next (Container.HT.all, Node); - end loop; - - return False; - end; + return True; end Has_Element; --------------- @@ -689,13 +494,13 @@ package body Ada.Containers.Formal_Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "Include attempted to tamper with cursors (map is locked)"; end if; declare - N : Node_Type renames Container.HT.Nodes (Position.Node); + N : Node_Type renames Container.Nodes (Position.Node); begin N.Key := Key; N.Element := New_Item; @@ -713,52 +518,44 @@ package body Ada.Containers.Formal_Hashed_Maps is Position : out Cursor; Inserted : out Boolean) is - begin + procedure Assign_Key (Node : in out Node_Type); + pragma Inline (Assign_Key); - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - declare - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); + function New_Node return Count_Type; + pragma Inline (New_Node); - function New_Node return Count_Type; - pragma Inline (New_Node); + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Assign_Key); + procedure Allocate is + new Generic_Allocate (Assign_Key); - ----------------- - -- Assign_Key -- - ----------------- + ----------------- + -- Assign_Key -- + ----------------- - procedure Assign_Key (Node : in out Node_Type) is - begin - Node.Key := Key; - -- Node.Element := New_Item; - end Assign_Key; + procedure Assign_Key (Node : in out Node_Type) is + begin + Node.Key := Key; + -- Node.Element := New_Item; + end Assign_Key; - -------------- - -- New_Node -- - -------------- + -------------- + -- New_Node -- + -------------- - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container.HT.all, Result); - return Result; - end New_Node; + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; - -- Start of processing for Insert + -- Start of processing for Insert - begin + begin - Local_Insert (Container.HT.all, Key, Position.Node, Inserted); - end; + Local_Insert (Container, Key, Position.Node, Inserted); end Insert; procedure Insert @@ -768,52 +565,44 @@ package body Ada.Containers.Formal_Hashed_Maps is Position : out Cursor; Inserted : out Boolean) is - begin - - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - declare - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); + procedure Assign_Key (Node : in out Node_Type); + pragma Inline (Assign_Key); - function New_Node return Count_Type; - pragma Inline (New_Node); + function New_Node return Count_Type; + pragma Inline (New_Node); - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); - procedure Allocate is - new Generic_Allocate (Assign_Key); + procedure Allocate is + new Generic_Allocate (Assign_Key); - ----------------- - -- Assign_Key -- - ----------------- + ----------------- + -- Assign_Key -- + ----------------- - procedure Assign_Key (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Assign_Key; + procedure Assign_Key (Node : in out Node_Type) is + begin + Node.Key := Key; + Node.Element := New_Item; + end Assign_Key; - -------------- - -- New_Node -- - -------------- + -------------- + -- New_Node -- + -------------- - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container.HT.all, Result); - return Result; - end New_Node; + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; - -- Start of processing for Insert + -- Start of processing for Insert - begin + begin - Local_Insert (Container.HT.all, Key, Position.Node, Inserted); - end; + Local_Insert (Container, Key, Position.Node, Inserted); end Insert; procedure Insert @@ -867,7 +656,7 @@ package body Ada.Containers.Formal_Hashed_Maps is Process (Container, (Node => Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.Busy; -- Start of processing for Iterate @@ -875,24 +664,7 @@ package body Ada.Containers.Formal_Hashed_Maps is B := B + 1; begin - case Container.K is - when Plain => - Local_Iterate (Container.HT.all); - when Part => - - if Container.Length = 0 then - return; - end if; - - declare - Node : Count_Type := Container.First; - begin - while Node /= Container.HT.Nodes (Container.Last).Next loop - Process_Node (Node); - Node := HT_Ops.Next (Container.HT.all, Node); - end loop; - end; - end case; + Local_Iterate (Container); exception when others => B := B - 1; @@ -915,7 +687,7 @@ package body Ada.Containers.Formal_Hashed_Maps is pragma Assert (Vet (Container, Position), "bad cursor in function Key"); - return Container.HT.Nodes (Position.Node).Key; + return Container.Nodes (Position.Node).Key; end Key; ---------- @@ -923,37 +695,24 @@ package body Ada.Containers.Formal_Hashed_Maps is ---------- function Left (Container : Map; Position : Cursor) return Map is - Lst : Count_Type; - Fst : constant Count_Type := First (Container).Node; - L : Count_Type := 0; - C : Count_Type := Fst; + Curs : Cursor := Position; + C : Map (Container.Capacity, Container.Modulus) := + Copy (Container, Container.Capacity); + Node : Count_Type; begin - while C /= Position.Node loop - if C = 0 or C = Container.Last then - raise Constraint_Error with - "Position cursor has no element"; - end if; - Lst := C; - C := HT_Ops.Next (Container.HT.all, C); - L := L + 1; - end loop; - if L = 0 then - return (Capacity => Container.Capacity, - Modulus => Container.Modulus, - K => Part, - HT => Container.HT, - Length => 0, - First => 0, - Last => 0); - else - return (Capacity => Container.Capacity, - Modulus => Container.Modulus, - K => Part, - HT => Container.HT, - Length => L, - First => Fst, - Last => Lst); + if Curs = No_Element then + return C; end if; + if not Has_Element (Container, Curs) then + raise Constraint_Error; + end if; + + while Curs.Node /= 0 loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); + end loop; + return C; end Left; ------------ @@ -962,12 +721,7 @@ package body Ada.Containers.Formal_Hashed_Maps is function Length (Container : Map) return Count_Type is begin - case Container.K is - when Plain => - return Container.HT.Length; - when Part => - return Container.Length; - end case; + return Container.Length; end Length; ---------- @@ -978,17 +732,11 @@ package body Ada.Containers.Formal_Hashed_Maps is (Target : in out Map; Source : in out Map) is - HT : HT_Types.Hash_Table_Type renames Source.HT.all; - NN : HT_Types.Nodes_Type renames HT.Nodes; + NN : HT_Types.Nodes_Type renames Source.Nodes; X, Y : Count_Type; begin - if Target.K /= Plain or Source.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Target'Address = Source'Address then return; end if; @@ -998,25 +746,25 @@ package body Ada.Containers.Formal_Hashed_Maps is "Source length exceeds Target capacity"; end if; - if HT.Busy > 0 then + if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; Clear (Target); - if HT.Length = 0 then + if Source.Length = 0 then return; end if; - X := HT_Ops.First (HT); + X := HT_Ops.First (Source); while X /= 0 loop Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? - Y := HT_Ops.Next (HT, X); + Y := HT_Ops.Next (Source, X); - HT_Ops.Delete_Node_Sans_Free (HT, X); - Free (HT, X); + HT_Ops.Delete_Node_Sans_Free (Source, X); + Free (Source, X); X := Y; end loop; @@ -1031,25 +779,6 @@ package body Ada.Containers.Formal_Hashed_Maps is return Node.Next; end Next; - function Next_Unchecked - (Container : Map; - Position : Cursor) return Cursor - is - HT : Hash_Table_Type renames Container.HT.all; - Node : constant Count_Type := HT_Ops.Next (HT, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - if Container.K = Part and then Container.Last = Position.Node then - return No_Element; - end if; - - return (Node => Node); - end Next_Unchecked; - function Next (Container : Map; Position : Cursor) return Cursor is begin if Position.Node = 0 then @@ -1063,7 +792,16 @@ package body Ada.Containers.Formal_Hashed_Maps is pragma Assert (Vet (Container, Position), "bad cursor in function Next"); - return Next_Unchecked (Container, Position); + declare + Node : constant Count_Type := HT_Ops.Next (Container, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; end Next; procedure Next (Container : Map; Position : in out Cursor) is @@ -1077,8 +815,7 @@ package body Ada.Containers.Formal_Hashed_Maps is function Overlap (Left, Right : Map) return Boolean is Left_Node : Count_Type; - Left_Nodes : Nodes_Type renames Left.HT.Nodes; - To_Node : Count_Type; + Left_Nodes : Nodes_Type renames Left.Nodes; begin if Length (Right) = 0 or Length (Left) = 0 then return False; @@ -1090,13 +827,7 @@ package body Ada.Containers.Formal_Hashed_Maps is Left_Node := First (Left).Node; - if Left.K = Plain then - To_Node := 0; - else - To_Node := Left.HT.Nodes (Left.Last).Next; - end if; - - while Left_Node /= To_Node loop + while Left_Node /= 0 loop declare N : Node_Type renames Left_Nodes (Left_Node); E : Key_Type renames N.Key; @@ -1107,7 +838,7 @@ package body Ada.Containers.Formal_Hashed_Maps is end if; end; - Left_Node := HT_Ops.Next (Left.HT.all, Left_Node); + Left_Node := HT_Ops.Next (Left, Left_Node); end loop; return False; @@ -1124,10 +855,6 @@ package body Ada.Containers.Formal_Hashed_Maps is procedure (Key : Key_Type; Element : Element_Type)) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with @@ -1137,11 +864,10 @@ package body Ada.Containers.Formal_Hashed_Maps is pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); declare - HT : Hash_Table_Type renames Container.HT.all; - N : Node_Type renames HT.Nodes (Position.Node); + N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; @@ -1202,26 +928,13 @@ package body Ada.Containers.Formal_Hashed_Maps is -- Start of processing for Read_Node begin - Allocate (Container.HT.all, Node); + Allocate (Container, Node); return Node; end Read_Node; -- Start of processing for Read - Result : HT_Access; begin - if Container.K /= Plain then - raise Constraint_Error; - end if; - - if Container.HT = null then - Result := new HT_Types.Hash_Table_Type (Container.Capacity, - Container.Modulus); - else - Result := Container.HT; - end if; - - Read_Nodes (Stream, Result.all); - Container.HT := Result; + Read_Nodes (Stream, Container); end Read; procedure Read @@ -1241,26 +954,22 @@ package body Ada.Containers.Formal_Hashed_Maps is Key : Key_Type; New_Item : Element_Type) is - Node : constant Count_Type := Key_Ops.Find (Container.HT.all, Key); + Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Node = 0 then raise Constraint_Error with "attempt to replace key not in map"; end if; - if Container.HT.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "Replace attempted to tamper with cursors (map is locked)"; end if; declare - N : Node_Type renames Container.HT.Nodes (Node); + N : Node_Type renames Container.Nodes (Node); begin N.Key := Key; N.Element := New_Item; @@ -1277,17 +986,13 @@ package body Ada.Containers.Formal_Hashed_Maps is New_Item : Element_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Replace_Element has no element"; end if; - if Container.HT.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "Replace_Element attempted to tamper with cursors (map is locked)"; end if; @@ -1295,7 +1000,7 @@ package body Ada.Containers.Formal_Hashed_Maps is pragma Assert (Vet (Container, Position), "bad cursor in Replace_Element"); - Container.HT.Nodes (Position.Node).Element := New_Item; + Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; ---------------------- @@ -1307,10 +1012,6 @@ package body Ada.Containers.Formal_Hashed_Maps is Capacity : Count_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Capacity > Container.Capacity then raise Capacity_Error with "requested capacity is too large"; @@ -1322,50 +1023,25 @@ package body Ada.Containers.Formal_Hashed_Maps is ----------- function Right (Container : Map; Position : Cursor) return Map is - Last : Count_Type; - Lst : Count_Type; - L : Count_Type := 0; - C : Count_Type := Position.Node; + Curs : Cursor := First (Container); + C : Map (Container.Capacity, Container.Modulus) := + Copy (Container, Container.Capacity); + Node : Count_Type; begin - - if C = 0 then - return (Capacity => Container.Capacity, - Modulus => Container.Modulus, - K => Part, - HT => Container.HT, - Length => 0, - First => 0, - Last => 0); - end if; - - if Container.K = Plain then - Lst := 0; - else - Lst := HT_Ops.Next (Container.HT.all, Container.Last); + if Curs = No_Element then + Clear (C); + return C; end if; - - if C = Lst then - raise Constraint_Error with - "Position cursor has no element"; + if Position /= No_Element and not Has_Element (Container, Position) then + raise Constraint_Error; end if; - while C /= Lst loop - if C = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - Last := C; - C := HT_Ops.Next (Container.HT.all, C); - L := L + 1; + while Curs.Node /= Position.Node loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); end loop; - - return (Capacity => Container.Capacity, - Modulus => Container.Modulus, - K => Part, - HT => Container.HT, - Length => L, - First => Position.Node, - Last => Last); + return C; end Right; -------------- @@ -1391,14 +1067,14 @@ package body Ada.Containers.Formal_Hashed_Maps is while CuL.Node /= 0 or CuR.Node /= 0 loop if CuL.Node /= CuR.Node or else - (Left.HT.Nodes (CuL.Node).Element /= - Right.HT.Nodes (CuR.Node).Element or - Left.HT.Nodes (CuL.Node).Key /= - Right.HT.Nodes (CuR.Node).Key) then + (Left.Nodes (CuL.Node).Element /= + Right.Nodes (CuR.Node).Element or + Left.Nodes (CuL.Node).Key /= + Right.Nodes (CuR.Node).Key) then return False; end if; - CuL := Next_Unchecked (Left, CuL); - CuR := Next_Unchecked (Right, CuR); + CuL := Next (Left, CuL); + CuR := Next (Right, CuR); end loop; return True; @@ -1415,11 +1091,6 @@ package body Ada.Containers.Formal_Hashed_Maps is Element : in out Element_Type)) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Update_Element has no element"; @@ -1429,16 +1100,15 @@ package body Ada.Containers.Formal_Hashed_Maps is "bad cursor in Update_Element"); declare - HT : Hash_Table_Type renames Container.HT.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; L := L + 1; declare - N : Node_Type renames HT.Nodes (Position.Node); + N : Node_Type renames Container.Nodes (Position.Node); K : Key_Type renames N.Key; E : Element_Type renames N.Element; @@ -1467,33 +1137,33 @@ package body Ada.Containers.Formal_Hashed_Maps is end if; declare - M : HT_Types.Hash_Table_Type renames Container.HT.all; X : Count_Type; begin - if M.Length = 0 then + if Container.Length = 0 then return False; end if; - if M.Capacity = 0 then + if Container.Capacity = 0 then return False; end if; - if M.Buckets'Length = 0 then + if Container.Buckets'Length = 0 then return False; end if; - if Position.Node > M.Capacity then + if Position.Node > Container.Capacity then return False; end if; - if M.Nodes (Position.Node).Next = Position.Node then + if Container.Nodes (Position.Node).Next = Position.Node then return False; end if; - X := M.Buckets (Key_Ops.Index (M, M.Nodes (Position.Node).Key)); + X := Container.Buckets + (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key)); - for J in 1 .. M.Length loop + for J in 1 .. Container.Length loop if X = Position.Node then return True; end if; @@ -1502,11 +1172,12 @@ package body Ada.Containers.Formal_Hashed_Maps is return False; end if; - if X = M.Nodes (X).Next then -- to prevent unnecessary looping + if X = Container.Nodes (X).Next then + -- to prevent unnecessary looping return False; end if; - X := M.Nodes (X).Next; + X := Container.Nodes (X).Next; end loop; return False; @@ -1544,7 +1215,7 @@ package body Ada.Containers.Formal_Hashed_Maps is -- Start of processing for Write begin - Write_Nodes (Stream, Container.HT.all); + Write_Nodes (Stream, Container); end Write; procedure Write diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index 31e3b7350e9..c076d4072d5 100644 --- a/gcc/ada/a-cfhama.ads +++ b/gcc/ada/a-cfhama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -66,8 +66,7 @@ package Ada.Containers.Formal_Hashed_Maps is pragma Pure; type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private; - -- pragma Preelaborable_Initialization (Map); - -- why is this commented out??? + pragma Preelaborable_Initialization (Map); type Cursor is private; pragma Preelaborable_Initialization (Cursor); @@ -232,19 +231,10 @@ private package HT_Types is new Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types - (Node_Type); + (Node_Type); - type HT_Access is access all HT_Types.Hash_Table_Type; - - type Kind is (Plain, Part); - - type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged record - HT : HT_Access := new HT_Types.Hash_Table_Type (Capacity, Modulus); - K : Kind := Plain; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - end record; + type Map (Capacity : Count_Type; Modulus : Hash_Type) is + new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; use HT_Types; use Ada.Streams; diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index ed514c826d6..2a79b046266 100644 --- a/gcc/ada/a-cfhase.adb +++ b/gcc/ada/a-cfhase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-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- -- @@ -43,7 +43,7 @@ package body Ada.Containers.Formal_Hashed_Sets is procedure Difference (Left, Right : Set; - Target : in out Hash_Table_Type); + Target : in out Set); function Equivalent_Keys (Key : Element_Type; @@ -51,41 +51,37 @@ package body Ada.Containers.Formal_Hashed_Sets is pragma Inline (Equivalent_Keys); procedure Free - (HT : in out Hash_Table_Type; + (HT : in out Set; X : Count_Type); generic with procedure Set_Element (Node : in out Node_Type); procedure Generic_Allocate - (HT : in out Hash_Table_Type; + (HT : in out Set; Node : out Count_Type); function Hash_Node (Node : Node_Type) return Hash_Type; pragma Inline (Hash_Node); procedure Insert - (Container : in out Hash_Table_Type; + (Container : in out Set; New_Item : Element_Type; Node : out Count_Type; Inserted : out Boolean); procedure Intersection - (Left : Hash_Table_Type; + (Left : Set; Right : Set; - Target : in out Hash_Table_Type); + Target : in out Set); function Is_In - (HT : HT_Types.Hash_Table_Type; + (HT : Set; Key : Node_Type) return Boolean; pragma Inline (Is_In); procedure Set_Element (Node : in out Node_Type; Item : Element_Type); pragma Inline (Set_Element); - function Next_Unchecked - (Container : Set; - Position : Cursor) return Cursor; - function Next (Node : Node_Type) return Count_Type; pragma Inline (Next); @@ -133,25 +129,18 @@ package body Ada.Containers.Formal_Hashed_Sets is declare Node : Count_Type := First (Left).Node; ENode : Count_Type; - Last : Count_Type; begin - if Left.K = Plain then - Last := 0; - else - Last := HT_Ops.Next (Left.HT.all, Left.Last); - end if; - - while Node /= Last loop + while Node /= 0 loop ENode := Find (Container => Right, - Item => Left.HT.Nodes (Node).Element).Node; + Item => Left.Nodes (Node).Element).Node; if ENode = 0 or else - Right.HT.Nodes (ENode).Element /= Left.HT.Nodes (Node).Element + Right.Nodes (ENode).Element /= Left.Nodes (Node).Element then return False; end if; - Node := HT_Ops.Next (Left.HT.all, Node); + Node := HT_Ops.Next (Left, Node); end loop; return True; @@ -175,22 +164,18 @@ package body Ada.Containers.Formal_Hashed_Sets is -------------------- procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.HT.Nodes (Source_Node); + N : Node_Type renames Source.Nodes (Source_Node); X : Count_Type; B : Boolean; begin - Insert (Target.HT.all, N.Element, X, B); + Insert (Target, N.Element, X, B); pragma Assert (B); end Insert_Element; -- Start of processing for Assign begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Target'Address = Source'Address then return; @@ -200,21 +185,8 @@ package body Ada.Containers.Formal_Hashed_Sets is raise Storage_Error with "not enough capacity"; -- SE or CE? ??? end if; - HT_Ops.Clear (Target.HT.all); - - case Source.K is - when Plain => - Insert_Elements (Source.HT.all); - when Part => - declare - N : Count_Type := Source.First; - begin - while N /= HT_Ops.Next (Source.HT.all, Source.Last) loop - Insert_Element (N); - N := HT_Ops.Next (Source.HT.all, N); - end loop; - end; - end case; + HT_Ops.Clear (Target); + Insert_Elements (Source); end Assign; -------------- @@ -223,7 +195,7 @@ package body Ada.Containers.Formal_Hashed_Sets is function Capacity (Container : Set) return Count_Type is begin - return Container.HT.Nodes'Length; + return Container.Nodes'Length; end Capacity; ----------- @@ -233,12 +205,7 @@ package body Ada.Containers.Formal_Hashed_Sets is procedure Clear (Container : in out Set) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - HT_Ops.Clear (Container.HT.all); + HT_Ops.Clear (Container); end Clear; -------------- @@ -265,40 +232,22 @@ package body Ada.Containers.Formal_Hashed_Sets is Target : Set (C, Source.Modulus); Cu : Cursor; begin - if (Source.K = Part and Source.Length = 0) or - Source.HT.Length = 0 then - return Target; - end if; - Target.HT.Length := Source.HT.Length; - Target.HT.Free := Source.HT.Free; + Target.Length := Source.Length; + Target.Free := Source.Free; while H <= Source.Modulus loop - Target.HT.Buckets (H) := Source.HT.Buckets (H); + Target.Buckets (H) := Source.Buckets (H); H := H + 1; end loop; while N <= Source.Capacity loop - Target.HT.Nodes (N) := Source.HT.Nodes (N); + Target.Nodes (N) := Source.Nodes (N); N := N + 1; end loop; while N <= C loop Cu := (Node => N); - Free (Target.HT.all, Cu.Node); + Free (Target, Cu.Node); N := N + 1; end loop; - if Source.K = Part then - N := HT_Ops.First (Target.HT.all); - while N /= Source.First loop - Cu := (Node => N); - N := HT_Ops.Next (Target.HT.all, N); - Delete (Target, Cu); - end loop; - N := HT_Ops.Next (Target.HT.all, Source.Last); - while N /= 0 loop - Cu := (Node => N); - N := HT_Ops.Next (Target.HT.all, N); - Delete (Target, Cu); - end loop; - end if; return Target; end Copy; @@ -323,17 +272,12 @@ package body Ada.Containers.Formal_Hashed_Sets is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - Element_Keys.Delete_Key_Sans_Free (Container.HT.all, Item, X); + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); if X = 0 then raise Constraint_Error with "attempt to delete element not in set"; end if; - Free (Container.HT.all, X); + Free (Container, X); end Delete; procedure Delete @@ -342,24 +286,19 @@ package body Ada.Containers.Formal_Hashed_Sets is is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor has no element"; end if; - if Container.HT.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (set is busy)"; end if; pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - HT_Ops.Delete_Node_Sans_Free (Container.HT.all, Position.Node); - Free (Container.HT.all, Position.Node); + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + Free (Container, Position.Node); Position := No_Element; end Delete; @@ -374,80 +313,65 @@ package body Ada.Containers.Formal_Hashed_Sets is is Tgt_Node, Src_Node, Src_Last, Src_Length : Count_Type; - TN : Nodes_Type renames Target.HT.Nodes; - SN : Nodes_Type renames Source.HT.Nodes; + TN : Nodes_Type renames Target.Nodes; + SN : Nodes_Type renames Source.Nodes; begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Target'Address = Source'Address then Clear (Target); return; end if; - case Source.K is - when Plain => - Src_Length := Source.HT.Length; - when Part => - Src_Length := Source.Length; - end case; + Src_Length := Source.Length; if Src_Length = 0 then return; end if; - if Target.HT.Busy > 0 then + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (set is busy)"; end if; - case Source.K is - when Plain => - if Src_Length >= Target.HT.Length then - Tgt_Node := HT_Ops.First (Target.HT.all); - while Tgt_Node /= 0 loop - if Element_Keys.Find (Source.HT.all, - TN (Tgt_Node).Element) /= 0 then - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.HT.all, X); - Free (Target.HT.all, X); - end; - else - Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node); - end if; - end loop; - return; + if Src_Length >= Target.Length then + Tgt_Node := HT_Ops.First (Target); + while Tgt_Node /= 0 loop + if Element_Keys.Find (Source, + TN (Tgt_Node).Element) /= 0 then + declare + X : constant Count_Type := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + Free (Target, X); + end; else - Src_Node := HT_Ops.First (Source.HT.all); - Src_Last := 0; + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); end if; - when Part => - Src_Node := Source.First; - Src_Last := HT_Ops.Next (Source.HT.all, Source.Last); - end case; + end loop; + return; + else + Src_Node := HT_Ops.First (Source); + Src_Last := 0; + end if; + while Src_Node /= Src_Last loop Tgt_Node := Element_Keys.Find - (Target.HT.all, SN (Src_Node).Element); + (Target, SN (Src_Node).Element); if Tgt_Node /= 0 then - HT_Ops.Delete_Node_Sans_Free (Target.HT.all, Tgt_Node); - Free (Target.HT.all, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node); + Free (Target, Tgt_Node); end if; - Src_Node := HT_Ops.Next (Source.HT.all, Src_Node); + Src_Node := HT_Ops.Next (Source, Src_Node); end loop; end Difference; procedure Difference (Left, Right : Set; - Target : in out Hash_Table_Type) + Target : in out Set) is procedure Process (L_Node : Count_Type); @@ -459,7 +383,7 @@ package body Ada.Containers.Formal_Hashed_Sets is ------------- procedure Process (L_Node : Count_Type) is - E : Element_Type renames Left.HT.Nodes (L_Node).Element; + E : Element_Type renames Left.Nodes (L_Node).Element; X : Count_Type; B : Boolean; @@ -473,29 +397,12 @@ package body Ada.Containers.Formal_Hashed_Sets is -- Start of processing for Difference begin - if Left.K = Plain then - Iterate (Left.HT.all); - else - - if Left.Length = 0 then - return; - end if; - - declare - Node : Count_Type := Left.First; - begin - while Node /= Left.HT.Nodes (Left.Last).Next loop - Process (Node); - Node := HT_Ops.Next (Left.HT.all, Node); - end loop; - end; - end if; + Iterate (Left); end Difference; function Difference (Left, Right : Set) return Set is C : Count_Type; H : Hash_Type; - S : Set (C, H); begin if Left'Address = Right'Address then return Empty_Set; @@ -511,8 +418,9 @@ package body Ada.Containers.Formal_Hashed_Sets is C := Length (Left); H := Default_Modulus (C); - Difference (Left, Right, Target => S.HT.all); - return S; + return S : Set (C, H) do + Difference (Left, Right, Target => S); + end return; end Difference; ------------- @@ -530,11 +438,7 @@ package body Ada.Containers.Formal_Hashed_Sets is pragma Assert (Vet (Container, Position), "bad cursor in function Element"); - declare - HT : Hash_Table_Type renames Container.HT.all; - begin - return HT.Nodes (Position.Node).Element; - end; + return Container.Nodes (Position.Node).Element; end Element; --------------------- @@ -542,118 +446,49 @@ package body Ada.Containers.Formal_Hashed_Sets is --------------------- function Equivalent_Sets (Left, Right : Set) return Boolean is - begin - if Left.K = Plain and Right.K = Plain then - declare - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean; - pragma Inline (Find_Equivalent_Key); - - function Is_Equivalent is - new HT_Ops.Generic_Equal (Find_Equivalent_Key); - - ------------------------- - -- Find_Equivalent_Key -- - ------------------------- - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - - R_Node : Count_Type := R_HT.Buckets (R_Index); - - RN : Nodes_Type renames R_HT.Nodes; - - begin - loop - if R_Node = 0 then - return False; - end if; - - if Equivalent_Elements (L_Node.Element, - RN (R_Node).Element) then - return True; - end if; - - R_Node := HT_Ops.Next (R_HT, R_Node); - end loop; - end Find_Equivalent_Key; - - -- Start of processing of Equivalent_Sets - - begin - return Is_Equivalent (Left.HT.all, Right.HT.all); - end; - else - declare - function Equal_Between - (L : Hash_Table_Type; R : Set; - From : Count_Type; To : Count_Type) return Boolean; + function Find_Equivalent_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean; + pragma Inline (Find_Equivalent_Key); - -- To and From are valid and Length are equal - function Equal_Between - (L : Hash_Table_Type; R : Set; - From : Count_Type; To : Count_Type) return Boolean - is - L_Index : Hash_Type; - To_Index : constant Hash_Type := - Element_Keys.Index (L, L.Nodes (To).Element); - L_Node : Count_Type := From; + function Is_Equivalent is + new HT_Ops.Generic_Equal (Find_Equivalent_Key); - begin - - L_Index := Element_Keys.Index (L, L.Nodes (From).Element); - - -- For each node of hash table L, search for an equivalent - -- node in hash table R. - - while L_Index /= To_Index or else - L_Node /= HT_Ops.Next (L, To) loop - pragma Assert (L_Node /= 0); + ------------------------- + -- Find_Equivalent_Key -- + ------------------------- - if Find (R, L.Nodes (L_Node).Element).Node = 0 then - return False; - end if; + function Find_Equivalent_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); - L_Node := L.Nodes (L_Node).Next; + R_Node : Count_Type := R_HT.Buckets (R_Index); - if L_Node = 0 then - -- We have exhausted the nodes in this bucket - -- Find the next bucket + RN : Nodes_Type renames R_HT.Nodes; - loop - L_Index := L_Index + 1; - L_Node := L.Buckets (L_Index); - exit when L_Node /= 0; - end loop; - end if; - end loop; - - return True; - end Equal_Between; - - begin - if Length (Left) /= Length (Right) then + begin + loop + if R_Node = 0 then return False; end if; - if Length (Left) = 0 then + + if Equivalent_Elements (L_Node.Element, + RN (R_Node).Element) then return True; end if; - if Left.K = Part then - return Equal_Between (Left.HT.all, Right, - Left.First, Left.Last); - else - return Equal_Between (Right.HT.all, Left, - Right.First, Right.Last); - end if; - end; - end if; + + R_Node := HT_Ops.Next (R_HT, R_Node); + end loop; + end Find_Equivalent_Key; + + -- Start of processing of Equivalent_Sets + + begin + return Is_Equivalent (Left, Right); end Equivalent_Sets; ------------------------- @@ -680,8 +515,8 @@ package body Ada.Containers.Formal_Hashed_Sets is "bad Right cursor in Equivalent_Elements"); declare - LN : Node_Type renames Left.HT.Nodes (CLeft.Node); - RN : Node_Type renames Right.HT.Nodes (CRight.Node); + LN : Node_Type renames Left.Nodes (CLeft.Node); + RN : Node_Type renames Right.Nodes (CRight.Node); begin return Equivalent_Elements (LN.Element, RN.Element); end; @@ -701,7 +536,7 @@ package body Ada.Containers.Formal_Hashed_Sets is "Left cursor in Equivalent_Elements is bad"); declare - LN : Node_Type renames Left.HT.Nodes (CLeft.Node); + LN : Node_Type renames Left.Nodes (CLeft.Node); begin return Equivalent_Elements (LN.Element, Right); end; @@ -722,7 +557,7 @@ package body Ada.Containers.Formal_Hashed_Sets is "Right cursor of Equivalent_Elements is bad"); declare - RN : Node_Type renames Right.HT.Nodes (CRight.Node); + RN : Node_Type renames Right.Nodes (CRight.Node); begin return Equivalent_Elements (Left, RN.Element); end; @@ -750,12 +585,8 @@ package body Ada.Containers.Formal_Hashed_Sets is is X : Count_Type; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - Element_Keys.Delete_Key_Sans_Free (Container.HT.all, Item, X); - Free (Container.HT.all, X); + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + Free (Container, X); end Exclude; ---------- @@ -766,81 +597,15 @@ package body Ada.Containers.Formal_Hashed_Sets is (Container : Set; Item : Element_Type) return Cursor is - begin - case Container.K is - when Plain => - declare - Node : constant Count_Type := - Element_Keys.Find (Container.HT.all, Item); - - begin - if Node = 0 then - return No_Element; - end if; - return (Node => Node); - end; - when Part => - declare - function Find_Between - (HT : Hash_Table_Type; - Key : Element_Type; - From : Count_Type; - To : Count_Type) return Count_Type; - - function Find_Between - (HT : Hash_Table_Type; - Key : Element_Type; - From : Count_Type; - To : Count_Type) return Count_Type is - - Indx : Hash_Type; - Indx_From : constant Hash_Type := - Element_Keys.Index (HT, - HT.Nodes (From).Element); - Indx_To : constant Hash_Type := - Element_Keys.Index (HT, - HT.Nodes (To).Element); - Node : Count_Type; - To_Node : Count_Type; - - begin - - Indx := Element_Keys.Index (HT, Key); - - if Indx < Indx_From or Indx > Indx_To then - return 0; - end if; - - if Indx = Indx_From then - Node := From; - else - Node := HT.Buckets (Indx); - end if; - - if Indx = Indx_To then - To_Node := HT.Nodes (To).Next; - else - To_Node := 0; - end if; - - while Node /= To_Node loop - if Equivalent_Keys (Key, HT.Nodes (Node)) then - return Node; - end if; - Node := HT.Nodes (Node).Next; - end loop; - return 0; - end Find_Between; - begin + Node : constant Count_Type := + Element_Keys.Find (Container, Item); - if Container.Length = 0 then - return No_Element; - end if; + begin + if Node = 0 then + return No_Element; + end if; + return (Node => Node); - return (Node => Find_Between (Container.HT.all, Item, - Container.First, Container.Last)); - end; - end case; end Find; ----------- @@ -848,31 +613,14 @@ package body Ada.Containers.Formal_Hashed_Sets is ----------- function First (Container : Set) return Cursor is + Node : constant Count_Type := HT_Ops.First (Container); begin - case Container.K is - when Plain => - declare - Node : constant Count_Type := HT_Ops.First (Container.HT.all); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - when Part => - declare - Node : constant Count_Type := Container.First; + if Node = 0 then + return No_Element; + end if; - begin - if Node = 0 then - return No_Element; - end if; + return (Node => Node); - return (Node => Node); - end; - end case; end First; ---------- @@ -880,7 +628,7 @@ package body Ada.Containers.Formal_Hashed_Sets is ---------- procedure Free - (HT : in out Hash_Table_Type; + (HT : in out Set; X : Count_Type) is begin @@ -893,7 +641,7 @@ package body Ada.Containers.Formal_Hashed_Sets is ---------------------- procedure Generic_Allocate - (HT : in out Hash_Table_Type; + (HT : in out Set; Node : out Count_Type) is @@ -912,60 +660,10 @@ package body Ada.Containers.Formal_Hashed_Sets is function Has_Element (Container : Set; Position : Cursor) return Boolean is begin if Position.Node = 0 or else - not Container.HT.Nodes (Position.Node).Has_Element then + not Container.Nodes (Position.Node).Has_Element then return False; end if; - - if Container.K = Plain then - return True; - end if; - - declare - Lst_Index : constant Hash_Type := - Element_Keys.Index (Container.HT.all, - Container.HT.Nodes - (Container.Last).Element); - Fst_Index : constant Hash_Type := - Element_Keys.Index (Container.HT.all, - Container.HT.Nodes - (Container.First).Element); - Index : constant Hash_Type := - Element_Keys.Index (Container.HT.all, - Container.HT.Nodes - (Position.Node).Element); - Lst_Node : Count_Type; - Node : Count_Type; - begin - - if Index < Fst_Index or Index > Lst_Index then - return False; - end if; - - if Index > Fst_Index and Index < Lst_Index then - return True; - end if; - - if Index = Fst_Index then - Node := Container.First; - else - Node := Container.HT.Buckets (Index); - end if; - - if Index = Lst_Index then - Lst_Node := Container.HT.Nodes (Container.Last).Next; - else - Lst_Node := 0; - end if; - - while Node /= Lst_Node loop - if Position.Node = Node then - return True; - end if; - Node := HT_Ops.Next (Container.HT.all, Node); - end loop; - - return False; - end; + return True; end Has_Element; --------------- @@ -992,12 +690,12 @@ package body Ada.Containers.Formal_Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (set is locked)"; end if; - Container.HT.Nodes (Position.Node).Element := New_Item; + Container.Nodes (Position.Node).Element := New_Item; end if; end Include; @@ -1012,12 +710,7 @@ package body Ada.Containers.Formal_Hashed_Sets is Inserted : out Boolean) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - Insert (Container.HT.all, New_Item, Position.Node, Inserted); + Insert (Container, New_Item, Position.Node, Inserted); end Insert; procedure Insert @@ -1037,7 +730,7 @@ package body Ada.Containers.Formal_Hashed_Sets is end Insert; procedure Insert - (Container : in out Hash_Table_Type; + (Container : in out Set; New_Item : Element_Type; Node : out Count_Type; Inserted : out Boolean) @@ -1091,49 +784,45 @@ package body Ada.Containers.Formal_Hashed_Sets is Source : Set) is Tgt_Node : Count_Type; - TN : Nodes_Type renames Target.HT.Nodes; + TN : Nodes_Type renames Target.Nodes; begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Target'Address = Source'Address then return; end if; - if Source.HT.Length = 0 then + if Source.Length = 0 then Clear (Target); return; end if; - if Target.HT.Busy > 0 then + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (set is busy)"; end if; - Tgt_Node := HT_Ops.First (Target.HT.all); + Tgt_Node := HT_Ops.First (Target); while Tgt_Node /= 0 loop if Find (Source, TN (Tgt_Node).Element).Node /= 0 then - Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node); + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); else declare X : constant Count_Type := Tgt_Node; begin - Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.HT.all, X); - Free (Target.HT.all, X); + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + Free (Target, X); end; end if; end loop; end Intersection; procedure Intersection - (Left : Hash_Table_Type; + (Left : Set; Right : Set; - Target : in out Hash_Table_Type) + Target : in out Set) is procedure Process (L_Node : Count_Type); @@ -1165,8 +854,6 @@ package body Ada.Containers.Formal_Hashed_Sets is function Intersection (Left, Right : Set) return Set is C : Count_Type; H : Hash_Type; - X : Count_Type; - B : Boolean; begin if Left'Address = Right'Address then @@ -1177,19 +864,7 @@ package body Ada.Containers.Formal_Hashed_Sets is H := Default_Modulus (C); return S : Set (C, H) do if Length (Left) /= 0 and Length (Right) /= 0 then - if Left.K = Plain then - Intersection (Left.HT.all, Right, Target => S.HT.all); - else - C := Left.First; - while C /= Left.HT.Nodes (Left.Last).Next loop - pragma Assert (C /= 0); - if Find (Right, Left.HT.Nodes (C).Element).Node /= 0 then - Insert (S.HT.all, Left.HT.Nodes (C).Element, X, B); - pragma Assert (B); - end if; - C := Left.HT.Nodes (C).Next; - end loop; - end if; + Intersection (Left, Right, Target => S); end if; end return; end Intersection; @@ -1207,7 +882,7 @@ package body Ada.Containers.Formal_Hashed_Sets is -- Is_In -- ----------- - function Is_In (HT : HT_Types.Hash_Table_Type; + function Is_In (HT : Set; Key : Node_Type) return Boolean is begin return Element_Keys.Find (HT, Key.Element) /= 0; @@ -1219,8 +894,7 @@ package body Ada.Containers.Formal_Hashed_Sets is function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is Subset_Node : Count_Type; - Subset_Nodes : Nodes_Type renames Subset.HT.Nodes; - To_Node : Count_Type; + Subset_Nodes : Nodes_Type renames Subset.Nodes; begin if Subset'Address = Of_Set'Address then return True; @@ -1232,13 +906,7 @@ package body Ada.Containers.Formal_Hashed_Sets is Subset_Node := First (Subset).Node; - if Subset.K = Plain then - To_Node := 0; - else - To_Node := Subset.HT.Nodes (Subset.Last).Next; - end if; - - while Subset_Node /= To_Node loop + while Subset_Node /= 0 loop declare N : Node_Type renames Subset_Nodes (Subset_Node); E : Element_Type renames N.Element; @@ -1249,7 +917,7 @@ package body Ada.Containers.Formal_Hashed_Sets is end if; end; - Subset_Node := HT_Ops.Next (Subset.HT.all, Subset_Node); + Subset_Node := HT_Ops.Next (Subset, Subset_Node); end loop; return True; @@ -1279,7 +947,7 @@ package body Ada.Containers.Formal_Hashed_Sets is Process (Container, (Node => Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.Busy; -- Start of processing for Iterate @@ -1287,24 +955,7 @@ package body Ada.Containers.Formal_Hashed_Sets is B := B + 1; begin - case Container.K is - when Plain => - Iterate (Container.HT.all); - when Part => - - if Container.Length = 0 then - return; - end if; - - declare - Node : Count_Type := Container.First; - begin - while Node /= Container.HT.Nodes (Container.Last).Next loop - Process_Node (Node); - Node := HT_Ops.Next (Container.HT.all, Node); - end loop; - end; - end case; + Iterate (Container); exception when others => B := B - 1; @@ -1319,37 +970,24 @@ package body Ada.Containers.Formal_Hashed_Sets is ---------- function Left (Container : Set; Position : Cursor) return Set is - Lst : Count_Type; - Fst : constant Count_Type := First (Container).Node; - L : Count_Type := 0; - C : Count_Type := Fst; + Curs : Cursor := Position; + C : Set (Container.Capacity, Container.Modulus) := + Copy (Container, Container.Capacity); + Node : Count_Type; begin - while C /= Position.Node loop - if C = 0 or C = Container.Last then - raise Constraint_Error with - "Position cursor has no element"; - end if; - Lst := C; - C := HT_Ops.Next (Container.HT.all, C); - L := L + 1; - end loop; - if L = 0 then - return (Capacity => Container.Capacity, - Modulus => Container.Modulus, - K => Part, - HT => Container.HT, - Length => 0, - First => 0, - Last => 0); - else - return (Capacity => Container.Capacity, - Modulus => Container.Modulus, - K => Part, - HT => Container.HT, - Length => L, - First => Fst, - Last => Lst); + if Curs = No_Element then + return C; + end if; + if not Has_Element (Container, Curs) then + raise Constraint_Error; end if; + + while Curs.Node /= 0 loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); + end loop; + return C; end Left; ------------ @@ -1358,12 +996,7 @@ package body Ada.Containers.Formal_Hashed_Sets is function Length (Container : Set) return Count_Type is begin - case Container.K is - when Plain => - return Container.HT.Length; - when Part => - return Container.Length; - end case; + return Container.Length; end Length; ---------- @@ -1371,17 +1004,11 @@ package body Ada.Containers.Formal_Hashed_Sets is ---------- procedure Move (Target : in out Set; Source : in out Set) is - HT : HT_Types.Hash_Table_Type renames Source.HT.all; - NN : HT_Types.Nodes_Type renames HT.Nodes; + NN : HT_Types.Nodes_Type renames Source.Nodes; X, Y : Count_Type; begin - if Target.K /= Plain or Source.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Target'Address = Source'Address then return; end if; @@ -1391,25 +1018,25 @@ package body Ada.Containers.Formal_Hashed_Sets is "Source length exceeds Target capacity"; end if; - if HT.Busy > 0 then + if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; Clear (Target); - if HT.Length = 0 then + if Source.Length = 0 then return; end if; - X := HT_Ops.First (HT); + X := HT_Ops.First (Source); while X /= 0 loop Insert (Target, NN (X).Element); -- optimize??? - Y := HT_Ops.Next (HT, X); + Y := HT_Ops.Next (Source, X); - HT_Ops.Delete_Node_Sans_Free (HT, X); - Free (HT, X); + HT_Ops.Delete_Node_Sans_Free (Source, X); + Free (Source, X); X := Y; end loop; @@ -1424,25 +1051,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return Node.Next; end Next; - function Next_Unchecked - (Container : Set; - Position : Cursor) return Cursor - is - HT : Hash_Table_Type renames Container.HT.all; - Node : constant Count_Type := HT_Ops.Next (HT, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - if Container.K = Part and then Container.Last = Position.Node then - return No_Element; - end if; - - return (Node => Node); - end Next_Unchecked; - function Next (Container : Set; Position : Cursor) return Cursor is begin if Position.Node = 0 then @@ -1456,7 +1064,7 @@ package body Ada.Containers.Formal_Hashed_Sets is pragma Assert (Vet (Container, Position), "bad cursor in Next"); - return Next_Unchecked (Container, Position); + return (Node => HT_Ops.Next (Container, Position.Node)); end Next; procedure Next (Container : Set; Position : in out Cursor) is @@ -1470,8 +1078,7 @@ package body Ada.Containers.Formal_Hashed_Sets is function Overlap (Left, Right : Set) return Boolean is Left_Node : Count_Type; - Left_Nodes : Nodes_Type renames Left.HT.Nodes; - To_Node : Count_Type; + Left_Nodes : Nodes_Type renames Left.Nodes; begin if Length (Right) = 0 or Length (Left) = 0 then return False; @@ -1483,13 +1090,7 @@ package body Ada.Containers.Formal_Hashed_Sets is Left_Node := First (Left).Node; - if Left.K = Plain then - To_Node := 0; - else - To_Node := Left.HT.Nodes (Left.Last).Next; - end if; - - while Left_Node /= To_Node loop + while Left_Node /= 0 loop declare N : Node_Type renames Left_Nodes (Left_Node); E : Element_Type renames N.Element; @@ -1500,7 +1101,7 @@ package body Ada.Containers.Formal_Hashed_Sets is end if; end; - Left_Node := HT_Ops.Next (Left.HT.all, Left_Node); + Left_Node := HT_Ops.Next (Left, Left_Node); end loop; return False; @@ -1516,11 +1117,6 @@ package body Ada.Containers.Formal_Hashed_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Query_Element has no element"; @@ -1529,17 +1125,16 @@ package body Ada.Containers.Formal_Hashed_Sets is pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); declare - HT : Hash_Table_Type renames Container.HT.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; L := L + 1; begin - Process (HT.Nodes (Position.Node).Element); + Process (Container.Nodes (Position.Node).Element); exception when others => L := L - 1; @@ -1589,26 +1184,14 @@ package body Ada.Containers.Formal_Hashed_Sets is -- Start of processing for Read_Node begin - Allocate (Container.HT.all, Node); + Allocate (Container, Node); return Node; end Read_Node; -- Start of processing for Read - Result : HT_Access; begin - if Container.K /= Plain then - raise Constraint_Error; - end if; - if Container.HT = null then - Result := new HT_Types.Hash_Table_Type (Container.Capacity, - Container.Modulus); - else - Result := Container.HT; - end if; - - Read_Nodes (Stream, Result.all); - Container.HT := Result; + Read_Nodes (Stream, Container); end Read; procedure Read @@ -1628,25 +1211,21 @@ package body Ada.Containers.Formal_Hashed_Sets is New_Item : Element_Type) is Node : constant Count_Type := - Element_Keys.Find (Container.HT.all, New_Item); + Element_Keys.Find (Container, New_Item); begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Node = 0 then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.HT.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (set is locked)"; end if; - Container.HT.Nodes (Node).Element := New_Item; + Container.Nodes (Node).Element := New_Item; end Replace; --------------------- @@ -1659,10 +1238,6 @@ package body Ada.Containers.Formal_Hashed_Sets is New_Item : Element_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with @@ -1672,7 +1247,7 @@ package body Ada.Containers.Formal_Hashed_Sets is pragma Assert (Vet (Container, Position), "bad cursor in Replace_Element"); - Replace_Element (Container.HT.all, Position.Node, New_Item); + Replace_Element (Container, Position.Node, New_Item); end Replace_Element; ---------------------- @@ -1684,10 +1259,6 @@ package body Ada.Containers.Formal_Hashed_Sets is Capacity : Count_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Capacity > Container.Capacity then raise Constraint_Error with "requested capacity is too large"; end if; @@ -1698,50 +1269,25 @@ package body Ada.Containers.Formal_Hashed_Sets is ----------- function Right (Container : Set; Position : Cursor) return Set is - Last : Count_Type; - Lst : Count_Type; - L : Count_Type := 0; - C : Count_Type := Position.Node; + Curs : Cursor := First (Container); + C : Set (Container.Capacity, Container.Modulus) := + Copy (Container, Container.Capacity); + Node : Count_Type; begin - - if C = 0 then - return (Capacity => Container.Capacity, - Modulus => Container.Modulus, - K => Part, - HT => Container.HT, - Length => 0, - First => 0, - Last => 0); - end if; - - if Container.K = Plain then - Lst := 0; - else - Lst := HT_Ops.Next (Container.HT.all, Container.Last); + if Curs = No_Element then + Clear (C); + return C; end if; - - if C = Lst then - raise Constraint_Error with - "Position cursor has no element"; + if Position /= No_Element and not Has_Element (Container, Position) then + raise Constraint_Error; end if; - while C /= Lst loop - if C = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - Last := C; - C := HT_Ops.Next (Container.HT.all, C); - L := L + 1; + while Curs.Node /= Position.Node loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); end loop; - - return (Capacity => Container.Capacity, - Modulus => Container.Modulus, - K => Part, - HT => Container.HT, - Length => L, - First => Position.Node, - Last => Last); + return C; end Right; ------------------ @@ -1776,12 +1322,12 @@ package body Ada.Containers.Formal_Hashed_Sets is while CuL.Node /= 0 or CuR.Node /= 0 loop if CuL.Node /= CuR.Node or else - Left.HT.Nodes (CuL.Node).Element /= - Right.HT.Nodes (CuR.Node).Element then + Left.Nodes (CuL.Node).Element /= + Right.Nodes (CuR.Node).Element then return False; end if; - CuL := Next_Unchecked (Left, CuL); - CuR := Next_Unchecked (Right, CuR); + CuL := Next (Left, CuL); + CuR := Next (Right, CuR); end loop; return True; @@ -1806,15 +1352,15 @@ package body Ada.Containers.Formal_Hashed_Sets is ------------- procedure Process (Source_Node : Count_Type) is - N : Node_Type renames Source.HT.Nodes (Source_Node); + N : Node_Type renames Source.Nodes (Source_Node); X : Count_Type; B : Boolean; begin - if Is_In (Target.HT.all, N) then + if Is_In (Target, N) then Delete (Target, N.Element); else - Insert (Target.HT.all, N.Element, X, B); + Insert (Target, N.Element, X, B); pragma Assert (B); end if; end Process; @@ -1822,10 +1368,6 @@ package body Ada.Containers.Formal_Hashed_Sets is -- Start of processing for Symmetric_Difference begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Target'Address = Source'Address then Clear (Target); @@ -1837,28 +1379,11 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (set is busy)"; end if; - - if Source.K = Plain then - Iterate (Source.HT.all); - else - - if Source.Length = 0 then - return; - end if; - - declare - Node : Count_Type := Source.First; - begin - while Node /= Source.HT.Nodes (Source.Last).Next loop - Process (Node); - Node := HT_Ops.Next (Source.HT.all, Node); - end loop; - end; - end if; + Iterate (Source); end Symmetric_Difference; @@ -1882,8 +1407,8 @@ package body Ada.Containers.Formal_Hashed_Sets is C := Length (Left) + Length (Right); H := Default_Modulus (C); return S : Set (C, H) do - Difference (Left, Right, S.HT.all); - Difference (Right, Left, S.HT.all); + Difference (Left, Right, S); + Difference (Right, Left, S); end return; end Symmetric_Difference; @@ -1897,7 +1422,7 @@ package body Ada.Containers.Formal_Hashed_Sets is begin return S : Set (Capacity => 1, Modulus => 1) do - Insert (S.HT.all, New_Item, X, B); + Insert (S, New_Item, X, B); pragma Assert (B); end return; end To_Set; @@ -1920,51 +1445,29 @@ package body Ada.Containers.Formal_Hashed_Sets is ------------- procedure Process (Src_Node : Count_Type) is - N : Node_Type renames Source.HT.Nodes (Src_Node); + N : Node_Type renames Source.Nodes (Src_Node); E : Element_Type renames N.Element; X : Count_Type; B : Boolean; begin - Insert (Target.HT.all, E, X, B); + Insert (Target, E, X, B); end Process; -- Start of processing for Union begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Target'Address = Source'Address then return; end if; - if Target.HT.Busy > 0 then + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (set is busy)"; end if; - - if Source.K = Plain then - Iterate (Source.HT.all); - else - - if Source.Length = 0 then - return; - end if; - - declare - Node : Count_Type := Source.First; - begin - while Node /= Source.HT.Nodes (Source.Last).Next loop - Process (Node); - Node := HT_Ops.Next (Source.HT.all, Node); - end loop; - end; - end if; + Iterate (Source); end Union; function Union (Left, Right : Set) return Set is @@ -2004,7 +1507,7 @@ package body Ada.Containers.Formal_Hashed_Sets is declare S : Set renames Container; - N : Nodes_Type renames S.HT.Nodes; + N : Nodes_Type renames S.Nodes; X : Count_Type; begin @@ -2020,7 +1523,7 @@ package body Ada.Containers.Formal_Hashed_Sets is return False; end if; - X := S.HT.Buckets (Element_Keys.Index (S.HT.all, + X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element)); for J in 1 .. S.Length loop @@ -2074,7 +1577,7 @@ package body Ada.Containers.Formal_Hashed_Sets is -- Start of processing for Write begin - Write_Nodes (Stream, Container.HT.all); + Write_Nodes (Stream, Container); end Write; procedure Write @@ -2131,18 +1634,14 @@ package body Ada.Containers.Formal_Hashed_Sets is X : Count_Type; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - Key_Keys.Delete_Key_Sans_Free (Container.HT.all, Key, X); + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); if X = 0 then raise Constraint_Error with "attempt to delete key not in set"; end if; - Free (Container.HT.all, X); + Free (Container, X); end Delete; ------------- @@ -2160,7 +1659,7 @@ package body Ada.Containers.Formal_Hashed_Sets is raise Constraint_Error with "key not in map"; end if; - return Container.HT.Nodes (Node).Element; + return Container.Nodes (Node).Element; end Element; ------------------------- @@ -2185,13 +1684,9 @@ package body Ada.Containers.Formal_Hashed_Sets is is X : Count_Type; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - Key_Keys.Delete_Key_Sans_Free (Container.HT.all, Key, X); - Free (Container.HT.all, X); + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + Free (Container, X); end Exclude; ---------- @@ -2202,82 +1697,16 @@ package body Ada.Containers.Formal_Hashed_Sets is (Container : Set; Key : Key_Type) return Cursor is - begin - if Container.K = Plain then - declare - Node : constant Count_Type := - Key_Keys.Find (Container.HT.all, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - else - declare - function Find_Between - (HT : Hash_Table_Type; - Key : Key_Type; - From : Count_Type; - To : Count_Type) return Count_Type; - - function Find_Between - (HT : Hash_Table_Type; - Key : Key_Type; - From : Count_Type; - To : Count_Type) return Count_Type is - - Indx : Hash_Type; - Indx_From : constant Hash_Type := - Key_Keys.Index (HT, Generic_Keys.Key - (HT.Nodes (From).Element)); - Indx_To : constant Hash_Type := - Key_Keys.Index (HT, Generic_Keys.Key - (HT.Nodes (To).Element)); - Node : Count_Type; - To_Node : Count_Type; - - begin - - Indx := Key_Keys.Index (HT, Key); - - if Indx < Indx_From or Indx > Indx_To then - return 0; - end if; - - if Indx = Indx_From then - Node := From; - else - Node := HT.Buckets (Indx); - end if; - - if Indx = Indx_To then - To_Node := HT.Nodes (To).Next; - else - To_Node := 0; - end if; - - while Node /= To_Node loop - if Equivalent_Key_Node (Key, HT.Nodes (Node)) then - return Node; - end if; - Node := HT.Nodes (Node).Next; - end loop; + Node : constant Count_Type := + Key_Keys.Find (Container, Key); - return 0; - end Find_Between; + begin + if Node = 0 then + return No_Element; + end if; - begin - if Container.Length = 0 then - return No_Element; - end if; + return (Node => Node); - return (Node => Find_Between (Container.HT.all, Key, - Container.First, Container.Last)); - end; - end if; end Find; --------- @@ -2295,8 +1724,7 @@ package body Ada.Containers.Formal_Hashed_Sets is "bad cursor in function Key"); declare - HT : Hash_Table_Type renames Container.HT.all; - N : Node_Type renames HT.Nodes (Position.Node); + N : Node_Type renames Container.Nodes (Position.Node); begin return Key (N.Element); end; @@ -2311,24 +1739,16 @@ package body Ada.Containers.Formal_Hashed_Sets is Key : Key_Type; New_Item : Element_Type) is + Node : constant Count_Type := + Key_Keys.Find (Container, Key); + begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; + if Node = 0 then + raise Constraint_Error with + "attempt to replace key not in set"; end if; - declare - Node : constant Count_Type := - Key_Keys.Find (Container.HT.all, Key); - - begin - if Node = 0 then - raise Constraint_Error with - "attempt to replace key not in set"; - end if; - - Replace_Element (Container.HT.all, Node, New_Item); - end; + Replace_Element (Container, Node, New_Item); end Replace; ----------------------------------- @@ -2342,43 +1762,28 @@ package body Ada.Containers.Formal_Hashed_Sets is procedure (Element : in out Element_Type)) is Indx : Hash_Type; - N : Nodes_Type renames Container.HT.Nodes; + N : Nodes_Type renames Container.Nodes; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - -- ??? - -- if HT.Buckets = null - -- or else HT.Buckets'Length = 0 - -- or else HT.Length = 0 - -- or else Position.Node.Next = Position.Node - -- then - -- raise Program_Error with - -- "Position cursor is bad (set is empty)"; - -- end if; - pragma Assert (Vet (Container, Position), "bad cursor in Update_Element_Preserving_Key"); -- Record bucket now, in case key is changed. - Indx := HT_Ops.Index (Container.HT.Buckets, N (Position.Node)); + Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); declare E : Element_Type renames N (Position.Node).Element; K : constant Key_Type := Key (E); - B : Natural renames Container.HT.Busy; - L : Natural renames Container.HT.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; @@ -2404,12 +1809,12 @@ package body Ada.Containers.Formal_Hashed_Sets is -- Key was modified, so remove this node from set. - if Container.HT.Buckets (Indx) = Position.Node then - Container.HT.Buckets (Indx) := N (Position.Node).Next; + if Container.Buckets (Indx) = Position.Node then + Container.Buckets (Indx) := N (Position.Node).Next; else declare - Prev : Count_Type := Container.HT.Buckets (Indx); + Prev : Count_Type := Container.Buckets (Indx); begin while N (Prev).Next /= Position.Node loop @@ -2426,7 +1831,7 @@ package body Ada.Containers.Formal_Hashed_Sets is end if; Container.Length := Container.Length - 1; - Free (Container.HT.all, Position.Node); + Free (Container, Position.Node); raise Program_Error with "key was modified"; end Update_Element_Preserving_Key; diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index ecc70e4e5d2..ea77968afea 100644 --- a/gcc/ada/a-cfhase.ads +++ b/gcc/ada/a-cfhase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -257,19 +257,8 @@ private package HT_Types is new Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); - type HT_Access is access all HT_Types.Hash_Table_Type; - - type Kind is (Plain, Part); - - type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged record - HT : HT_Access := - new HT_Types.Hash_Table_Type'(Capacity, Modulus, - others => <>); - K : Kind := Plain; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - end record; + type Set (Capacity : Count_Type; Modulus : Hash_Type) is + new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; use HT_Types; use Ada.Streams; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index 705fd618e9f..ecd8de5f87c 100644 --- a/gcc/ada/a-cforma.adb +++ b/gcc/ada/a-cforma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-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- -- @@ -80,7 +80,7 @@ package body Ada.Containers.Formal_Ordered_Maps is (Tree : in out Tree_Types.Tree_Type'Class; Node : out Count_Type); - procedure Free (Tree : in out Tree_Types.Tree_Type; X : Count_Type); + procedure Free (Tree : in out Map; X : Count_Type); function Is_Greater_Key_Node (Left : Key_Type; @@ -92,10 +92,6 @@ package body Ada.Containers.Formal_Ordered_Maps is Right : Node_Type) return Boolean; pragma Inline (Is_Less_Key_Node); - function Next_Unchecked - (Container : Map; - Position : Count_Type) return Count_Type; - -------------------------- -- Local Instantiations -- -------------------------- @@ -133,15 +129,15 @@ package body Ada.Containers.Formal_Ordered_Maps is return True; end if; - Lst := Next (Left.Tree.all, Last (Left).Node); + Lst := Next (Left, Last (Left).Node); while Node /= Lst loop - ENode := Find (Right, Left.Tree.Nodes (Node).Key).Node; + ENode := Find (Right, Left.Nodes (Node).Key).Node; if ENode = 0 or else - Left.Tree.Nodes (Node).Element /= Right.Tree.Nodes (ENode).Element + Left.Nodes (Node).Element /= Right.Nodes (ENode).Element then return False; end if; - Node := Next (Left.Tree.all, Node); + Node := Next (Left, Node); end loop; return True; @@ -163,7 +159,7 @@ package body Ada.Containers.Formal_Ordered_Maps is -------------------- procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Tree.Nodes (Source_Node); + SN : Node_Type renames Source.Nodes (Source_Node); procedure Set_Element (Node : in out Node_Type); pragma Inline (Set_Element); @@ -193,7 +189,7 @@ package body Ada.Containers.Formal_Ordered_Maps is Result : Count_Type; begin - Allocate (Target.Tree.all, Result); + Allocate (Target, Result); return Result; end New_Node; @@ -213,7 +209,7 @@ package body Ada.Containers.Formal_Ordered_Maps is begin Unconditional_Insert_Avec_Hint - (Tree => Target.Tree.all, + (Tree => Target, Hint => 0, Key => SN.Key, Node => Target_Node); @@ -222,10 +218,6 @@ package body Ada.Containers.Formal_Ordered_Maps is -- Start of processing for Assign begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Target'Address = Source'Address then return; @@ -235,21 +227,8 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Storage_Error with "not enough capacity"; -- SE or CE? ??? end if; - Tree_Operations.Clear_Tree (Target.Tree.all); - - if Source.K = Plain then - Append_Elements (Source.Tree.all); - else - declare - X : Count_Type; - begin - X := Source.First; - while X /= Next (Source.Tree.all, Source.Last) loop - Append_Element (X); - X := Next (Source.Tree.all, X); - end loop; - end; - end if; + Tree_Operations.Clear_Tree (Target); + Append_Elements (Source); end Assign; ------------- @@ -257,33 +236,16 @@ package body Ada.Containers.Formal_Ordered_Maps is ------------- function Ceiling (Container : Map; Key : Key_Type) return Cursor is - begin - if Container.K = Part then - if Container.Length = 0 then - return No_Element; - end if; + Node : constant Count_Type := + Key_Ops.Ceiling (Container, Key); - if Key < Container.Tree.Nodes (Container.First).Key then - return (Node => Container.First); - end if; - - if Container.Tree.Nodes (Container.Last).Key < Key then - return No_Element; - end if; + begin + if Node = 0 then + return No_Element; end if; - declare - Node : constant Count_Type := - Key_Ops.Ceiling (Container.Tree.all, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; + return (Node => Node); end Ceiling; ----------- @@ -292,12 +254,8 @@ package body Ada.Containers.Formal_Ordered_Maps is procedure Clear (Container : in out Map) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - Tree_Operations.Clear_Tree (Container.Tree.all); + Tree_Operations.Clear_Tree (Container); end Clear; ----------- @@ -325,56 +283,38 @@ package body Ada.Containers.Formal_Ordered_Maps is function Copy (Source : Map; Capacity : Count_Type := 0) return Map is Node : Count_Type := 1; N : Count_Type; - Cu : Cursor; begin return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do if Length (Source) > 0 then - Target.Tree.Length := Source.Tree.Length; - Target.Tree.Root := Source.Tree.Root; - Target.Tree.First := Source.Tree.First; - Target.Tree.Last := Source.Tree.Last; - Target.Tree.Free := Source.Tree.Free; + Target.Length := Source.Length; + Target.Root := Source.Root; + Target.First := Source.First; + Target.Last := Source.Last; + Target.Free := Source.Free; while Node <= Source.Capacity loop - Target.Tree.Nodes (Node).Element := - Source.Tree.Nodes (Node).Element; - Target.Tree.Nodes (Node).Key := - Source.Tree.Nodes (Node).Key; - Target.Tree.Nodes (Node).Parent := - Source.Tree.Nodes (Node).Parent; - Target.Tree.Nodes (Node).Left := - Source.Tree.Nodes (Node).Left; - Target.Tree.Nodes (Node).Right := - Source.Tree.Nodes (Node).Right; - Target.Tree.Nodes (Node).Color := - Source.Tree.Nodes (Node).Color; - Target.Tree.Nodes (Node).Has_Element := - Source.Tree.Nodes (Node).Has_Element; + Target.Nodes (Node).Element := + Source.Nodes (Node).Element; + Target.Nodes (Node).Key := + Source.Nodes (Node).Key; + Target.Nodes (Node).Parent := + Source.Nodes (Node).Parent; + Target.Nodes (Node).Left := + Source.Nodes (Node).Left; + Target.Nodes (Node).Right := + Source.Nodes (Node).Right; + Target.Nodes (Node).Color := + Source.Nodes (Node).Color; + Target.Nodes (Node).Has_Element := + Source.Nodes (Node).Has_Element; Node := Node + 1; end loop; while Node <= Target.Capacity loop N := Node; - Formal_Ordered_Maps.Free (Tree => Target.Tree.all, X => N); + Formal_Ordered_Maps.Free (Tree => Target, X => N); Node := Node + 1; end loop; - - if Source.K = Part then - Node := Target.Tree.First; - while Node /= Source.First loop - Cu := (Node => Node); - Node := Next (Target.Tree.all, Node); - Delete (Target, Cu); - end loop; - - Node := Next (Target.Tree.all, Source.Last); - - while Node /= 0 loop - Cu := (Node => Node); - Node := Next (Target.Tree.all, Node); - Delete (Target, Cu); - end loop; - end if; end if; end return; end Copy; @@ -385,41 +325,31 @@ package body Ada.Containers.Formal_Ordered_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Delete has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "Position cursor of Delete is bad"); - Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, + Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); - Formal_Ordered_Maps.Free (Container.Tree.all, Position.Node); + Formal_Ordered_Maps.Free (Container, Position.Node); end Delete; procedure Delete (Container : in out Map; Key : Key_Type) is + + X : constant Node_Access := Key_Ops.Find (Container, Key); + begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; + if X = 0 then + raise Constraint_Error with "key not in map"; end if; - declare - X : constant Node_Access := Key_Ops.Find (Container.Tree.all, Key); - - begin - if X = 0 then - raise Constraint_Error with "key not in map"; - end if; - Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X); - Formal_Ordered_Maps.Free (Container.Tree.all, X); - end; + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Maps.Free (Container, X); end Delete; ------------------ @@ -430,14 +360,10 @@ package body Ada.Containers.Formal_Ordered_Maps is X : constant Node_Access := First (Container).Node; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X); - Formal_Ordered_Maps.Free (Container.Tree.all, X); + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Maps.Free (Container, X); end if; end Delete_First; @@ -449,14 +375,10 @@ package body Ada.Containers.Formal_Ordered_Maps is X : constant Node_Access := Last (Container).Node; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X); - Formal_Ordered_Maps.Free (Container.Tree.all, X); + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Maps.Free (Container, X); end if; end Delete_Last; @@ -471,10 +393,10 @@ package body Ada.Containers.Formal_Ordered_Maps is "Position cursor of function Element has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "Position cursor of function Element is bad"); - return Container.Tree.Nodes (Position.Node).Element; + return Container.Nodes (Position.Node).Element; end Element; @@ -486,7 +408,7 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error with "key not in map"; end if; - return Container.Tree.Nodes (Node).Element; + return Container.Nodes (Node).Element; end Element; --------------------- @@ -509,17 +431,13 @@ package body Ada.Containers.Formal_Ordered_Maps is ------------- procedure Exclude (Container : in out Map; Key : Key_Type) is - X : constant Node_Access := Key_Ops.Find (Container.Tree.all, Key); + X : constant Node_Access := Key_Ops.Find (Container, Key); begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X); - Formal_Ordered_Maps.Free (Container.Tree.all, X); + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Maps.Free (Container, X); end if; end Exclude; @@ -528,29 +446,16 @@ package body Ada.Containers.Formal_Ordered_Maps is ---------- function Find (Container : Map; Key : Key_Type) return Cursor is - begin - if Container.K = Part then - if Container.Length = 0 then - return No_Element; - end if; - if Key < Container.Tree.Nodes (Container.First).Key or - Container.Tree.Nodes (Container.Last).Key < Key then - return No_Element; - end if; - end if; - - declare - Node : constant Count_Type := - Key_Ops.Find (Container.Tree.all, Key); + Node : constant Count_Type := + Key_Ops.Find (Container, Key); - begin - if Node = 0 then - return No_Element; - end if; + begin + if Node = 0 then + return No_Element; + end if; - return (Node => Node); - end; + return (Node => Node); end Find; ----------- @@ -563,11 +468,7 @@ package body Ada.Containers.Formal_Ordered_Maps is return No_Element; end if; - if Container.K = Plain then - return (Node => Container.Tree.First); - else - return (Node => Container.First); - end if; + return (Node => Container.First); end First; @@ -581,7 +482,7 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error with "map is empty"; end if; - return Container.Tree.Nodes (First (Container).Node).Element; + return Container.Nodes (First (Container).Node).Element; end First_Element; --------------- @@ -594,7 +495,7 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error with "map is empty"; end if; - return Container.Tree.Nodes (First (Container).Node).Key; + return Container.Nodes (First (Container).Node).Key; end First_Key; ----------- @@ -602,33 +503,16 @@ package body Ada.Containers.Formal_Ordered_Maps is ----------- function Floor (Container : Map; Key : Key_Type) return Cursor is - begin - - if Container.K = Part then - if Container.Length = 0 then - return No_Element; - end if; - if Key < Container.Tree.Nodes (Container.First).Key then - return No_Element; - end if; + Node : constant Count_Type := + Key_Ops.Floor (Container, Key); - if Container.Tree.Nodes (Container.Last).Key < Key then - return (Node => Container.Last); - end if; + begin + if Node = 0 then + return No_Element; end if; - declare - Node : constant Count_Type := - Key_Ops.Floor (Container.Tree.all, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; + return (Node => Node); end Floor; ---------- @@ -636,7 +520,7 @@ package body Ada.Containers.Formal_Ordered_Maps is ---------- procedure Free - (Tree : in out Tree_Types.Tree_Type; + (Tree : in out Map; X : Count_Type) is begin @@ -671,25 +555,7 @@ package body Ada.Containers.Formal_Ordered_Maps is return False; end if; - if not Container.Tree.Nodes (Position.Node).Has_Element then - return False; - end if; - - if Container.K = Plain then - return True; - end if; - - declare - Key : constant Key_Type := Container.Tree.Nodes (Position.Node).Key; - begin - - if Key < Container.Tree.Nodes (Container.First).Key or - Container.Tree.Nodes (Container.Last).Key < Key then - return False; - end if; - - return True; - end; + return Container.Nodes (Position.Node).Has_Element; end Has_Element; ------------- @@ -708,13 +574,13 @@ package body Ada.Containers.Formal_Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (map is locked)"; end if; declare - N : Node_Type renames Container.Tree.Nodes (Position.Node); + N : Node_Type renames Container.Nodes (Position.Node); begin N.Key := Key; N.Element := New_Item; @@ -729,51 +595,43 @@ package body Ada.Containers.Formal_Ordered_Maps is Position : out Cursor; Inserted : out Boolean) is - begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; + function New_Node return Node_Access; - declare - function New_Node return Node_Access; - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); - function New_Node return Node_Access is - procedure Initialize (Node : in out Node_Type); - procedure Allocate_Node is new Generic_Allocate (Initialize); + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); - procedure Initialize (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Initialize; + -------------- + -- New_Node -- + -------------- - X : Node_Access; + function New_Node return Node_Access is + procedure Initialize (Node : in out Node_Type); + procedure Allocate_Node is new Generic_Allocate (Initialize); + procedure Initialize (Node : in out Node_Type) is begin - Allocate_Node (Container.Tree.all, X); - return X; - end New_Node; + Node.Key := Key; + Node.Element := New_Item; + end Initialize; - -- Start of processing for Insert + X : Node_Access; begin - Insert_Sans_Hint - (Container.Tree.all, - Key, - Position.Node, - Inserted); - end; + Allocate_Node (Container, X); + return X; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container, + Key, + Position.Node, + Inserted); end Insert; procedure Insert @@ -802,50 +660,42 @@ package body Ada.Containers.Formal_Ordered_Maps is Position : out Cursor; Inserted : out Boolean) is - begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - declare - function New_Node return Node_Access; - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); + function New_Node return Node_Access; - -------------- - -- New_Node -- - -------------- + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); - function New_Node return Node_Access is - procedure Initialize (Node : in out Node_Type); - procedure Allocate_Node is new Generic_Allocate (Initialize); + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); - procedure Initialize (Node : in out Node_Type) is - begin - Node.Key := Key; - end Initialize; + -------------- + -- New_Node -- + -------------- - X : Node_Access; + function New_Node return Node_Access is + procedure Initialize (Node : in out Node_Type); + procedure Allocate_Node is new Generic_Allocate (Initialize); + procedure Initialize (Node : in out Node_Type) is begin - Allocate_Node (Container.Tree.all, X); - return X; - end New_Node; + Node.Key := Key; + end Initialize; - -- Start of processing for Insert + X : Node_Access; begin - Insert_Sans_Hint - (Container.Tree.all, - Key, - Position.Node, - Inserted); - end; + Allocate_Node (Container, X); + return X; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container, + Key, + Position.Node, + Inserted); end Insert; -------------- @@ -907,7 +757,7 @@ package body Ada.Containers.Formal_Ordered_Maps is Process (Container, (Node => Node)); end Process_Node; - B : Natural renames Container.Tree.all.Busy; + B : Natural renames Container'Unrestricted_Access.Busy; -- Start of processing for Iterate @@ -915,44 +765,7 @@ package body Ada.Containers.Formal_Ordered_Maps is B := B + 1; begin - - if Container.K = Plain then - Local_Iterate (Container.Tree.all); - return; - end if; - - if Container.Length = 0 then - return; - end if; - - declare - FElt : constant Key_Type := - Container.Tree.Nodes (Container.First).Key; - TElt : constant Key_Type := - Container.Tree.Nodes (Container.Last).Key; - - procedure Iterate (P : Count_Type); - - procedure Iterate (P : Count_Type) is - X : Count_Type := P; - begin - while X /= 0 loop - if Container.Tree.Nodes (X).Key < FElt then - X := Container.Tree.Nodes (X).Right; - elsif TElt < Container.Tree.Nodes (X).Key then - X := Container.Tree.Nodes (X).Left; - else - Iterate (Container.Tree.Nodes (X).Left); - Process_Node (X); - X := Container.Tree.Nodes (X).Right; - end if; - end loop; - end Iterate; - - begin - Iterate (Container.Tree.Root); - end; - + Local_Iterate (Container); exception when others => B := B - 1; @@ -973,10 +786,10 @@ package body Ada.Containers.Formal_Ordered_Maps is "Position cursor of function Key has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "Position cursor of function Key is bad"); - return Container.Tree.Nodes (Position.Node).Key; + return Container.Nodes (Position.Node).Key; end Key; ---------- @@ -988,11 +801,6 @@ package body Ada.Containers.Formal_Ordered_Maps is if Length (Container) = 0 then return No_Element; end if; - - if Container.K = Plain then - return (Node => Container.Tree.Last); - end if; - return (Node => Container.Last); end Last; @@ -1006,7 +814,7 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error with "map is empty"; end if; - return Container.Tree.Nodes (Last (Container).Node).Element; + return Container.Nodes (Last (Container).Node).Element; end Last_Element; -------------- @@ -1019,7 +827,7 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error with "map is empty"; end if; - return Container.Tree.Nodes (Last (Container).Node).Key; + return Container.Nodes (Last (Container).Node).Key; end Last_Key; ---------- @@ -1027,35 +835,24 @@ package body Ada.Containers.Formal_Ordered_Maps is ---------- function Left (Container : Map; Position : Cursor) return Map is - Lst : Count_Type; - Fst : constant Count_Type := First (Container).Node; - L : Count_Type := 0; - C : Count_Type := Fst; + Curs : Cursor := Position; + C : Map (Container.Capacity) := + Copy (Container, Container.Capacity); + Node : Count_Type; begin - while C /= Position.Node loop - if C = Last (Container).Node or C = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - Lst := C; - C := Next (Container.Tree.all, C); - L := L + 1; - end loop; - if L = 0 then - return (Capacity => Container.Capacity, - K => Part, - Tree => Container.Tree, - Length => 0, - First => 0, - Last => 0); - else - return (Capacity => Container.Capacity, - K => Part, - Tree => Container.Tree, - Length => L, - First => Fst, - Last => Lst); + if Curs = No_Element then + return C; end if; + if not Has_Element (Container, Curs) then + raise Constraint_Error; + end if; + + while Curs.Node /= 0 loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); + end loop; + return C; end Left; -------------- @@ -1073,11 +870,7 @@ package body Ada.Containers.Formal_Ordered_Maps is function Length (Container : Map) return Count_Type is begin - if Container.K = Plain then - return Container.Tree.Length; - else - return Container.Length; - end if; + return Container.Length; end Length; ---------- @@ -1085,14 +878,10 @@ package body Ada.Containers.Formal_Ordered_Maps is ---------- procedure Move (Target : in out Map; Source : in out Map) is - NN : Tree_Types.Nodes_Type renames Source.Tree.Nodes; + NN : Tree_Types.Nodes_Type renames Source.Nodes; X : Node_Access; begin - if Target.K /= Plain or Source.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Target'Address = Source'Address then return; @@ -1103,7 +892,7 @@ package body Ada.Containers.Formal_Ordered_Maps is "Source length exceeds Target capacity"; end if; - if Source.Tree.Busy > 0 then + if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; @@ -1121,8 +910,8 @@ package body Ada.Containers.Formal_Ordered_Maps is Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? - Tree_Operations.Delete_Node_Sans_Free (Source.Tree.all, X); - Formal_Ordered_Maps.Free (Source.Tree.all, X); + Tree_Operations.Delete_Node_Sans_Free (Source, X); + Formal_Ordered_Maps.Free (Source, X); end loop; end Move; @@ -1130,19 +919,6 @@ package body Ada.Containers.Formal_Ordered_Maps is -- Next -- ---------- - function Next_Unchecked - (Container : Map; - Position : Count_Type) return Count_Type is - begin - - if Container.K = Part and then - (Container.Length = 0 or Position = Container.Last) then - return 0; - end if; - - return Tree_Operations.Next (Container.Tree.all, Position); - end Next_Unchecked; - procedure Next (Container : Map; Position : in out Cursor) is begin Position := Next (Container, Position); @@ -1158,10 +934,10 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Next"); - return (Node => Next_Unchecked (Container, Position.Node)); + return (Node => Tree_Operations.Next (Container, Position.Node)); end Next; ------------- @@ -1181,9 +957,9 @@ package body Ada.Containers.Formal_Ordered_Maps is R_Node : Count_Type := First (Right).Node; L_Last : constant Count_Type := - Next (Left.Tree.all, Last (Left).Node); + Next (Left, Last (Left).Node); R_Last : constant Count_Type := - Next (Right.Tree.all, Last (Right).Node); + Next (Right, Last (Right).Node); begin if Left'Address = Right'Address then @@ -1197,12 +973,12 @@ package body Ada.Containers.Formal_Ordered_Maps is return False; end if; - if Left.Tree.Nodes (L_Node).Key - < Right.Tree.Nodes (R_Node).Key then - L_Node := Next (Left.Tree.all, L_Node); - elsif Right.Tree.Nodes (R_Node).Key - < Left.Tree.Nodes (L_Node).Key then - R_Node := Next (Right.Tree.all, R_Node); + if Left.Nodes (L_Node).Key + < Right.Nodes (R_Node).Key then + L_Node := Next (Left, L_Node); + elsif Right.Nodes (R_Node).Key + < Left.Nodes (L_Node).Key then + R_Node := Next (Right, R_Node); else return True; @@ -1239,18 +1015,12 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Previous"); - if Container.K = Part and then - (Container.Length = 0 or Position.Node = Container.First) then - return No_Element; - end if; - declare - Tree : Tree_Types.Tree_Type renames Container.Tree.all; Node : constant Count_Type := - Tree_Operations.Previous (Tree, Position.Node); + Tree_Operations.Previous (Container, Position.Node); begin if Node = 0 then @@ -1272,31 +1042,26 @@ package body Ada.Containers.Formal_Ordered_Maps is Element : Element_Type)) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Query_Element has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "Position cursor of Query_Element is bad"); declare - T : Tree_Types.Tree_Type renames Container.Tree.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; L := L + 1; declare - N : Node_Type renames T.Nodes (Position.Node); + N : Node_Type renames Container.Nodes (Position.Node); K : Key_Type renames N.Key; E : Element_Type renames N.Element; @@ -1342,20 +1107,9 @@ package body Ada.Containers.Formal_Ordered_Maps is end Read_Element; -- Start of processing for Read - Result : Tree_Type_Access; begin - if Container.K /= Plain then - raise Constraint_Error; - end if; - - if Container.Tree = null then - Result := new Tree_Types.Tree_Type (Container.Capacity); - else - Result := Container.Tree; - end if; - Read_Elements (Stream, Result.all); - Container.Tree := Result; + Read_Elements (Stream, Container); end Read; procedure Read @@ -1377,26 +1131,21 @@ package body Ada.Containers.Formal_Ordered_Maps is is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - declare - Node : constant Node_Access := Key_Ops.Find (Container.Tree.all, Key); + Node : constant Node_Access := Key_Ops.Find (Container, Key); begin if Node = 0 then raise Constraint_Error with "key not in map"; end if; - if Container.Tree.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (map is locked)"; end if; declare - N : Node_Type renames Container.Tree.Nodes (Node); + N : Node_Type renames Container.Nodes (Node); begin N.Key := Key; N.Element := New_Item; @@ -1414,25 +1163,21 @@ package body Ada.Containers.Formal_Ordered_Maps is New_Item : Element_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Replace_Element has no element"; end if; - if Container.Tree.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (map is locked)"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "Position cursor of Replace_Element is bad"); - Container.Tree.Nodes (Position.Node).Element := New_Item; + Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; --------------------- @@ -1459,7 +1204,7 @@ package body Ada.Containers.Formal_Ordered_Maps is Process (Container, (Node => Node)); end Process_Node; - B : Natural renames Container.Tree.Busy; + B : Natural renames Container'Unrestricted_Access.Busy; -- Start of processing for Reverse_Iterate @@ -1467,43 +1212,7 @@ package body Ada.Containers.Formal_Ordered_Maps is B := B + 1; begin - - if Container.K = Plain then - Local_Reverse_Iterate (Container.Tree.all); - return; - end if; - - if Container.Length = 0 then - return; - end if; - - declare - FElt : constant Key_Type := - Container.Tree.Nodes (Container.First).Key; - TElt : constant Key_Type := - Container.Tree.Nodes (Container.Last).Key; - - procedure Iterate (P : Count_Type); - - procedure Iterate (P : Count_Type) is - X : Count_Type := P; - begin - while X /= 0 loop - if Container.Tree.Nodes (X).Key < FElt then - X := Container.Tree.Nodes (X).Right; - elsif TElt < Container.Tree.Nodes (X).Key then - X := Container.Tree.Nodes (X).Left; - else - Iterate (Container.Tree.Nodes (X).Right); - Process_Node (X); - X := Container.Tree.Nodes (X).Left; - end if; - end loop; - end Iterate; - - begin - Iterate (Container.Tree.Root); - end; + Local_Reverse_Iterate (Container); exception when others => @@ -1519,46 +1228,25 @@ package body Ada.Containers.Formal_Ordered_Maps is ----------- function Right (Container : Map; Position : Cursor) return Map is - Lst : Count_Type; - L : Count_Type := 0; - C : Count_Type := Position.Node; + Curs : Cursor := First (Container); + C : Map (Container.Capacity) := + Copy (Container, Container.Capacity); + Node : Count_Type; begin - - if C = 0 then - return (Capacity => Container.Capacity, - K => Part, - Tree => Container.Tree, - Length => 0, - First => 0, - Last => 0); - end if; - - if Container.K = Plain then - Lst := 0; - else - Lst := Next (Container.Tree.all, Container.Last); + if Curs = No_Element then + Clear (C); + return C; end if; - - if C = Lst then - raise Constraint_Error with - "Position cursor has no element"; + if Position /= No_Element and not Has_Element (Container, Position) then + raise Constraint_Error; end if; - while C /= Lst loop - if C = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - C := Next (Container.Tree.all, C); - L := L + 1; + while Curs.Node /= Position.Node loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); end loop; - - return (Capacity => Container.Capacity, - K => Part, - Tree => Container.Tree, - Length => L, - First => Position.Node, - Last => Last (Container).Node); + return C; end Right; --------------- @@ -1626,14 +1314,14 @@ package body Ada.Containers.Formal_Ordered_Maps is return True; end if; - if Left.Tree.Nodes (LNode).Element /= - Right.Tree.Nodes (RNode).Element or - Left.Tree.Nodes (LNode).Key /= Right.Tree.Nodes (RNode).Key then + if Left.Nodes (LNode).Element /= + Right.Nodes (RNode).Element or + Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key then exit; end if; - LNode := Next_Unchecked (Left, LNode); - RNode := Next_Unchecked (Right, RNode); + LNode := Next (Left, LNode); + RNode := Next (Right, RNode); end loop; return False; end Strict_Equal; @@ -1649,31 +1337,26 @@ package body Ada.Containers.Formal_Ordered_Maps is Element : in out Element_Type)) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Update_Element has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "Position cursor of Update_Element is bad"); declare - T : Tree_Types.Tree_Type renames Container.Tree.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; L := L + 1; declare - N : Node_Type renames T.Nodes (Position.Node); + N : Node_Type renames Container.Nodes (Position.Node); K : Key_Type renames N.Key; E : Element_Type renames N.Element; @@ -1723,7 +1406,7 @@ package body Ada.Containers.Formal_Ordered_Maps is -- Start of processing for Write begin - Write_Nodes (Stream, Container.Tree.all); + Write_Nodes (Stream, Container); end Write; procedure Write diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads index 088cf69917f..145ff513d3d 100644 --- a/gcc/ada/a-cforma.ads +++ b/gcc/ada/a-cforma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -69,7 +69,7 @@ package Ada.Containers.Formal_Ordered_Maps is function Equivalent_Keys (Left, Right : Key_Type) return Boolean; type Map (Capacity : Count_Type) is tagged private; - -- pragma Preelaborable_Initialization (Map); + pragma Preelaborable_Initialization (Map); type Cursor is private; pragma Preelaborable_Initialization (Cursor); @@ -220,34 +220,22 @@ private type Node_Type is record Has_Element : Boolean := False; - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; + Parent : Node_Access := 0; + Left : Node_Access := 0; + Right : Node_Access := 0; Color : Red_Black_Trees.Color_Type := Red; Key : Key_Type; Element : Element_Type; end record; - type Kind is (Plain, Part); - package Tree_Types is new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - type Tree_Type_Access is access all Tree_Types.Tree_Type; - - type Map (Capacity : Count_Type) is tagged record - Tree : Tree_Type_Access := new Tree_Types.Tree_Type (Capacity); - K : Kind := Plain; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - end record; + type Map (Capacity : Count_Type) is + new Tree_Types.Tree_Type (Capacity) with null record; use Ada.Streams; - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; - type Cursor is record Node : Node_Access; end record; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index 30a0f97a31d..59f4efe8230 100644 --- a/gcc/ada/a-cforse.adb +++ b/gcc/ada/a-cforse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-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- -- @@ -83,21 +83,16 @@ package body Ada.Containers.Formal_Ordered_Sets is (Tree : in out Tree_Types.Tree_Type'Class; Node : out Count_Type); - procedure Assign (Target : in out Tree_Types.Tree_Type; - Source : Tree_Types.Tree_Type); - - procedure Clear (Container : in out Tree_Types.Tree_Type); - - procedure Free (Tree : in out Tree_Types.Tree_Type; X : Count_Type); + procedure Free (Tree : in out Set; X : Count_Type); procedure Insert_Sans_Hint - (Container : in out Tree_Types.Tree_Type; + (Container : in out Set; New_Item : Element_Type; Node : out Count_Type; Inserted : out Boolean); procedure Insert_With_Hint - (Dst_Set : in out Tree_Types.Tree_Type; + (Dst_Set : in out Set; Dst_Hint : Count_Type; Src_Node : Node_Type; Dst_Node : out Count_Type); @@ -115,18 +110,8 @@ package body Ada.Containers.Formal_Ordered_Sets is function Is_Less_Node_Node (L, R : Node_Type) return Boolean; pragma Inline (Is_Less_Node_Node); - generic - with procedure Process (Node : Count_Type) is <>; - procedure Iterate_Between (Tree : Tree_Types.Tree_Type; - From : Count_Type; - To : Count_Type); - - function Next_Unchecked - (Container : Set; - Position : Count_Type) return Count_Type; - procedure Replace_Element - (Tree : in out Tree_Types.Tree_Type; + (Tree : in out Set; Node : Count_Type; Item : Element_Type); @@ -152,7 +137,7 @@ package body Ada.Containers.Formal_Ordered_Sets is package Set_Ops is new Red_Black_Trees.Generic_Bounded_Set_Operations (Tree_Operations => Tree_Operations, - Set_Type => Tree_Types.Tree_Type, + Set_Type => Set, Assign => Assign, Insert_With_Hint => Insert_With_Hint, Is_Less => Is_Less_Node_Node); @@ -175,15 +160,15 @@ package body Ada.Containers.Formal_Ordered_Sets is return True; end if; - Lst := Next (Left.Tree.all, Last (Left).Node); + Lst := Next (Left, Last (Left).Node); while Node /= Lst loop - ENode := Find (Right, Left.Tree.Nodes (Node).Element).Node; + ENode := Find (Right, Left.Nodes (Node).Element).Node; if ENode = 0 or else - Left.Tree.Nodes (Node).Element /= Right.Tree.Nodes (ENode).Element + Left.Nodes (Node).Element /= Right.Nodes (ENode).Element then return False; end if; - Node := Next (Left.Tree.all, Node); + Node := Next (Left, Node); end loop; return True; @@ -194,8 +179,7 @@ package body Ada.Containers.Formal_Ordered_Sets is -- Assign -- ------------ - procedure Assign (Target : in out Tree_Types.Tree_Type; - Source : Tree_Types.Tree_Type) is + procedure Assign (Target : in out Set; Source : Set) is procedure Append_Element (Source_Node : Count_Type); procedure Append_Elements is @@ -277,145 +261,30 @@ package body Ada.Containers.Formal_Ordered_Sets is Append_Elements (Source); end Assign; - procedure Assign (Target : in out Set; Source : Set) is - X : Count_Type; - begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Storage_Error with "not enough capacity"; -- SE or CE? ??? - end if; - - if Source.K = Plain then - Assign (Target => Target.Tree.all, Source => Source.Tree.all); - else - declare - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Tree.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Element_Keys.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is - new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - - begin - Allocate (Target.Tree.all, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := SN.Element; - end Set_Element; - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target.Tree.all, - Hint => 0, - Key => SN.Element, - Node => Target_Node); - end Append_Element; - begin - Tree_Operations.Clear_Tree (Target.Tree.all); - X := Source.First; - while X /= Next (Source.Tree.all, Source.Last) loop - Append_Element (X); - X := Next (Source.Tree.all, X); - end loop; - end; - end if; - end Assign; - ------------- -- Ceiling -- ------------- function Ceiling (Container : Set; Item : Element_Type) return Cursor is - begin - if Container.K = Part then - if Container.Length = 0 then - return No_Element; - end if; + Node : constant Count_Type := Element_Keys.Ceiling (Container, Item); - if Item < Container.Tree.Nodes (Container.First).Element then - return (Node => Container.First); - end if; - - if Container.Tree.Nodes (Container.Last).Element < Item then - return No_Element; - end if; + begin + if Node = 0 then + return No_Element; end if; - declare - Node : constant Count_Type := - Element_Keys.Ceiling (Container.Tree.all, Item); + return (Node => Node); - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; end Ceiling; ----------- -- Clear -- ----------- - procedure Clear (Container : in out Tree_Types.Tree_Type) is - begin - Tree_Operations.Clear_Tree (Container); - end Clear; - procedure Clear (Container : in out Set) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - Clear (Container.Tree.all); + Tree_Operations.Clear_Tree (Container); end Clear; ----------- @@ -446,56 +315,36 @@ package body Ada.Containers.Formal_Ordered_Sets is function Copy (Source : Set; Capacity : Count_Type := 0) return Set is Node : Count_Type := 1; N : Count_Type; - Cu : Cursor; Target : Set (Count_Type'Max (Source.Capacity, Capacity)); begin if Length (Source) > 0 then - Target.Tree.Length := Source.Tree.Length; - Target.Tree.Root := Source.Tree.Root; - Target.Tree.First := Source.Tree.First; - Target.Tree.Last := Source.Tree.Last; - Target.Tree.Free := Source.Tree.Free; + Target.Length := Source.Length; + Target.Root := Source.Root; + Target.First := Source.First; + Target.Last := Source.Last; + Target.Free := Source.Free; while Node <= Source.Capacity loop - Target.Tree.Nodes (Node).Element := - Source.Tree.Nodes (Node).Element; - Target.Tree.Nodes (Node).Parent := - Source.Tree.Nodes (Node).Parent; - Target.Tree.Nodes (Node).Left := - Source.Tree.Nodes (Node).Left; - Target.Tree.Nodes (Node).Right := - Source.Tree.Nodes (Node).Right; - Target.Tree.Nodes (Node).Color := - Source.Tree.Nodes (Node).Color; - Target.Tree.Nodes (Node).Has_Element := - Source.Tree.Nodes (Node).Has_Element; + Target.Nodes (Node).Element := + Source.Nodes (Node).Element; + Target.Nodes (Node).Parent := + Source.Nodes (Node).Parent; + Target.Nodes (Node).Left := + Source.Nodes (Node).Left; + Target.Nodes (Node).Right := + Source.Nodes (Node).Right; + Target.Nodes (Node).Color := + Source.Nodes (Node).Color; + Target.Nodes (Node).Has_Element := + Source.Nodes (Node).Has_Element; Node := Node + 1; end loop; while Node <= Target.Capacity loop N := Node; - Formal_Ordered_Sets.Free (Tree => Target.Tree.all, X => N); + Formal_Ordered_Sets.Free (Tree => Target, X => N); Node := Node + 1; end loop; - - if Source.K = Part then - Node := Target.Tree.First; - while Node /= Source.First loop - Cu := (Node => Node); - Node := Next (Target.Tree.all, Node); - Delete (Target, Cu); - end loop; - - Node := Next (Target.Tree.all, Source.Last); - - while Node /= 0 loop - Cu := (Node => Node); - Node := Next (Target.Tree.all, Node); - Delete (Target, Cu); - end loop; - end if; - Node := 1; - end if; return Target; end Copy; @@ -506,39 +355,31 @@ package body Ada.Containers.Formal_Ordered_Sets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Delete"); - Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, + Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); - Formal_Ordered_Sets.Free (Container.Tree.all, Position.Node); + Formal_Ordered_Sets.Free (Container, Position.Node); Position := No_Element; end Delete; procedure Delete (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container.Tree.all, Item); + X : constant Count_Type := Element_Keys.Find (Container, Item); begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if X = 0 then raise Constraint_Error with "attempt to delete element not in set"; end if; - Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X); - Formal_Ordered_Sets.Free (Container.Tree.all, X); + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); end Delete; ------------------ @@ -546,18 +387,13 @@ package body Ada.Containers.Formal_Ordered_Sets is ------------------ procedure Delete_First (Container : in out Set) is - Tree : Tree_Types.Tree_Type renames Container.Tree.all; - X : constant Count_Type := Tree.First; + X : constant Count_Type := Container.First; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Formal_Ordered_Sets.Free (Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); end if; end Delete_First; @@ -566,18 +402,13 @@ package body Ada.Containers.Formal_Ordered_Sets is ----------------- procedure Delete_Last (Container : in out Set) is - Tree : Tree_Types.Tree_Type renames Container.Tree.all; - X : constant Count_Type := Tree.Last; + X : constant Count_Type := Container.Last; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Formal_Ordered_Sets.Free (Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); end if; end Delete_Last; @@ -587,68 +418,8 @@ package body Ada.Containers.Formal_Ordered_Sets is procedure Difference (Target : in out Set; Source : Set) is begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - if Source.K = Plain then - Set_Ops.Set_Difference (Target.Tree.all, Source.Tree.all); - else - declare - Tgt : Count_Type := Target.Tree.First; - Src : Count_Type := Source.First; - begin - if Target'Address = Source'Address then - if Target.Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - - Clear (Target.Tree.all); - return; - end if; - - if Source.Length = 0 then - return; - end if; + Set_Ops.Set_Difference (Target, Source); - if Target.Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - - loop - if Tgt = 0 then - return; - end if; - - if Src = Next (Source.Tree.all, Source.Last) then - return; - end if; - - if Target.Tree.Nodes (Tgt).Element < - Source.Tree.Nodes (Src).Element then - Tgt := Next (Target.Tree.all, Tgt); - - elsif Source.Tree.Nodes (Src).Element < - Target.Tree.Nodes (Tgt).Element then - Src := Next (Source.Tree.all, Src); - - else - declare - X : constant Count_Type := Tgt; - begin - Tgt := Next (Target.Tree.all, Tgt); - Delete_Node_Sans_Free (Target.Tree.all, X); - Formal_Ordered_Sets.Free (Target.Tree.all, X); - end; - - Src := Next (Source.Tree.all, Src); - end if; - end loop; - end; - end if; end Difference; function Difference (Left, Right : Set) return Set is @@ -666,65 +437,9 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; return S : Set (Length (Left)) do - if Left.K = Plain and Right.K = Plain then - Assign (S.Tree.all, - Set_Ops.Set_Difference (Left.Tree.all, Right.Tree.all)); - else - declare - Tree : Tree_Types.Tree_Type renames S.Tree.all; - - L_Node : Count_Type := First (Left).Node; - R_Node : Count_Type := First (Right).Node; - - L_Last : constant Count_Type := Next (Left.Tree.all, - Last (Left).Node); - R_Last : constant Count_Type := Next (Right.Tree.all, - Last (Right).Node); + Assign (S, + Set_Ops.Set_Difference (Left, Right)); - Dst_Node : Count_Type; - - begin - loop - if L_Node = L_Last then - return; - end if; - - if R_Node = R_Last then - while L_Node /= L_Last loop - Insert_With_Hint - (Dst_Set => Tree, - Dst_Hint => 0, - Src_Node => Left.Tree.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Next (Left.Tree.all, L_Node); - - end loop; - - return; - end if; - - if Left.Tree.Nodes (L_Node).Element < - Right.Tree.Nodes (R_Node).Element then - Insert_With_Hint - (Dst_Set => Tree, - Dst_Hint => 0, - Src_Node => Left.Tree.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Next (Left.Tree.all, L_Node); - - elsif Right.Tree.Nodes (R_Node).Element < - Left.Tree.Nodes (L_Node).Element then - R_Node := Next (Right.Tree.all, R_Node); - - else - L_Node := Next (Left.Tree.all, L_Node); - R_Node := Next (Right.Tree.all, R_Node); - end if; - end loop; - end; - end if; end return; end Difference; @@ -738,11 +453,11 @@ package body Ada.Containers.Formal_Ordered_Sets is raise Constraint_Error with "Position cursor has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Element"); declare - N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + N : Tree_Types.Nodes_Type renames Container.Nodes; begin return N (Position.Node).Element; end; @@ -793,44 +508,7 @@ package body Ada.Containers.Formal_Ordered_Sets is -- Start of processing for Equivalent_Sets begin - if Left.K = Plain and Right.K = Plain then - return Is_Equivalent (Left.Tree.all, Right.Tree.all); - end if; - - if Left'Address = Right'Address then - return True; - end if; - - if Length (Left) /= Length (Right) then - return False; - end if; - - if Length (Left) = 0 then - return True; - end if; - - declare - L_Node : Count_Type; - R_Node : Count_Type; - - L_Last : constant Count_Type := Next (Left.Tree.all, - Last (Left).Node); - begin - - L_Node := First (Left).Node; - R_Node := First (Right).Node; - while L_Node /= L_Last loop - if not Is_Equivalent_Node_Node (Left.Tree.Nodes (L_Node), - Right.Tree.Nodes (R_Node)) then - return False; - end if; - - L_Node := Next (Left.Tree.all, L_Node); - R_Node := Next (Right.Tree.all, R_Node); - end loop; - - return True; - end; + return Is_Equivalent (Left, Right); end Equivalent_Sets; ------------- @@ -838,17 +516,13 @@ package body Ada.Containers.Formal_Ordered_Sets is ------------- procedure Exclude (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container.Tree.all, Item); + X : constant Count_Type := Element_Keys.Find (Container, Item); begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X); - Formal_Ordered_Sets.Free (Container.Tree.all, X); + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); end if; end Exclude; @@ -857,30 +531,17 @@ package body Ada.Containers.Formal_Ordered_Sets is ---------- function Find (Container : Set; Item : Element_Type) return Cursor is - begin - if Container.K = Part then - if Container.Length = 0 then - return No_Element; - end if; + Node : constant Count_Type := + Element_Keys.Find (Container, Item); - if Item < Container.Tree.Nodes (Container.First).Element or - Container.Tree.Nodes (Container.Last).Element < Item then - return No_Element; - end if; + begin + if Node = 0 then + return No_Element; end if; - declare - Node : constant Count_Type := - Element_Keys.Find (Container.Tree.all, Item); + return (Node => Node); - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; end Find; ----------- @@ -893,11 +554,7 @@ package body Ada.Containers.Formal_Ordered_Sets is return No_Element; end if; - if Container.K = Plain then - return (Node => Container.Tree.First); - else - return (Node => Container.First); - end if; + return (Node => Container.First); end First; @@ -913,7 +570,7 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; declare - N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + N : Tree_Types.Nodes_Type renames Container.Nodes; begin return N (Fst).Element; end; @@ -926,23 +583,9 @@ package body Ada.Containers.Formal_Ordered_Sets is function Floor (Container : Set; Item : Element_Type) return Cursor is begin - if Container.K = Part then - if Container.Length = 0 then - return No_Element; - end if; - - if Item < Container.Tree.Nodes (Container.First).Element then - return No_Element; - end if; - - if Container.Tree.Nodes (Container.Last).Element < Item then - return (Node => Container.Last); - end if; - end if; - declare Node : constant Count_Type := - Element_Keys.Floor (Container.Tree.all, Item); + Element_Keys.Floor (Container, Item); begin if Node = 0 then @@ -958,7 +601,7 @@ package body Ada.Containers.Formal_Ordered_Sets is ---------- procedure Free - (Tree : in out Tree_Types.Tree_Type; + (Tree : in out Set; X : Count_Type) is begin @@ -1019,35 +662,15 @@ package body Ada.Containers.Formal_Ordered_Sets is ------------- function Ceiling (Container : Set; Key : Key_Type) return Cursor is - begin - - if Container.K = Part then - if Container.Length = 0 then - return No_Element; - end if; - - if Key < Generic_Keys.Key - (Container.Tree.Nodes (Container.First).Element) then - return (Node => Container.First); - end if; + Node : constant Count_Type := + Key_Keys.Ceiling (Container, Key); - if Generic_Keys.Key - (Container.Tree.Nodes (Container.Last).Element) < Key then - return No_Element; - end if; + begin + if Node = 0 then + return No_Element; end if; - declare - Node : constant Count_Type := - Key_Keys.Ceiling (Container.Tree.all, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; + return (Node => Node); end Ceiling; -------------- @@ -1064,23 +687,16 @@ package body Ada.Containers.Formal_Ordered_Sets is ------------ procedure Delete (Container : in out Set; Key : Key_Type) is - begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - declare - X : constant Count_Type := Key_Keys.Find (Container.Tree.all, Key); + X : constant Count_Type := Key_Keys.Find (Container, Key); - begin - if X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; + begin + if X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; - Delete_Node_Sans_Free (Container.Tree.all, X); - Formal_Ordered_Sets.Free (Container.Tree.all, X); - end; + Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); end Delete; ------------- @@ -1088,32 +704,18 @@ package body Ada.Containers.Formal_Ordered_Sets is ------------- function Element (Container : Set; Key : Key_Type) return Element_Type is - begin + Node : constant Count_Type := + Key_Keys.Find (Container, Key); - if Container.K = Part then - if Container.Length = 0 or else - (Key < Generic_Keys.Key - (Container.Tree.Nodes (Container.First).Element) or - Generic_Keys.Key - (Container.Tree.Nodes (Container.Last).Element) < Key) then - raise Constraint_Error with "key not in set"; - end if; + begin + if Node = 0 then + raise Constraint_Error with "key not in set"; end if; declare - Node : constant Count_Type := - Key_Keys.Find (Container.Tree.all, Key); - + N : Tree_Types.Nodes_Type renames Container.Nodes; begin - if Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; - begin - return N (Node).Element; - end; + return N (Node).Element; end; end Element; @@ -1137,22 +739,14 @@ package body Ada.Containers.Formal_Ordered_Sets is ------------- procedure Exclude (Container : in out Set; Key : Key_Type) is - begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - declare - X : constant Count_Type := Key_Keys.Find (Container.Tree.all, Key); + X : constant Count_Type := Key_Keys.Find (Container, Key); - begin - if X /= 0 then - Delete_Node_Sans_Free (Container.Tree.all, X); - Formal_Ordered_Sets.Free (Container.Tree.all, X); - end if; - end; + begin + if X /= 0 then + Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); + end if; end Exclude; ---------- @@ -1160,30 +754,15 @@ package body Ada.Containers.Formal_Ordered_Sets is ---------- function Find (Container : Set; Key : Key_Type) return Cursor is - begin - - if Container.K = Part then - if Container.Length = 0 or else - (Key < Generic_Keys.Key - (Container.Tree.Nodes (Container.First).Element) or - Generic_Keys.Key - (Container.Tree.Nodes (Container.Last).Element) < Key) then - return No_Element; - end if; - end if; - declare - - Node : constant Count_Type := Key_Keys.Find (Container.Tree.all, - Key); + Node : constant Count_Type := Key_Keys.Find (Container, Key); - begin - if Node = 0 then - return No_Element; - end if; + begin + if Node = 0 then + return No_Element; + end if; - return (Node => Node); - end; + return (Node => Node); end Find; ----------- @@ -1191,31 +770,17 @@ package body Ada.Containers.Formal_Ordered_Sets is ----------- function Floor (Container : Set; Key : Key_Type) return Cursor is - begin - if Container.K = Part then - if Container.Length = 0 or else - Key < Generic_Keys.Key - (Container.Tree.Nodes (Container.First).Element) then - return No_Element; - end if; - if Generic_Keys.Key - (Container.Tree.Nodes (Container.Last).Element) < Key then - return (Node => Container.Last); - end if; - end if; + Node : constant Count_Type := + Key_Keys.Floor (Container, Key); - declare - Node : constant Count_Type := - Key_Keys.Floor (Container.Tree.all, Key); + begin + if Node = 0 then + return No_Element; + end if; - begin - if Node = 0 then - return No_Element; - end if; + return (Node => Node); - return (Node => Node); - end; end Floor; ------------------------- @@ -1253,11 +818,11 @@ package body Ada.Containers.Formal_Ordered_Sets is "Position cursor has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Key"); declare - N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + N : Tree_Types.Nodes_Type renames Container.Nodes; begin return Key (N (Position.Node).Element); end; @@ -1272,20 +837,16 @@ package body Ada.Containers.Formal_Ordered_Sets is Key : Key_Type; New_Item : Element_Type) is - Node : constant Count_Type := Key_Keys.Find (Container.Tree.all, Key); + Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, (Node => Node)) then raise Constraint_Error with "attempt to replace key not in set"; end if; - Replace_Element (Container.Tree.all, Node, New_Item); + Replace_Element (Container, Node, New_Item); end Replace; ----------------------------------- @@ -1297,30 +858,24 @@ package body Ada.Containers.Formal_Ordered_Sets is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is - Tree : Tree_Types.Tree_Type renames Container.Tree.all; - begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Update_Element_Preserving_Key"); declare - N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + N : Tree_Types.Nodes_Type renames Container.Nodes; E : Element_Type renames N (Position.Node).Element; K : constant Key_Type := Key (E); - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; @@ -1346,8 +901,8 @@ package body Ada.Containers.Formal_Ordered_Sets is declare X : constant Count_Type := Position.Node; begin - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Formal_Ordered_Sets.Free (Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); end; raise Program_Error with "key was modified"; @@ -1365,26 +920,7 @@ package body Ada.Containers.Formal_Ordered_Sets is return False; end if; - if not Container.Tree.Nodes (Position.Node).Has_Element then - return False; - end if; - - if Container.K = Plain then - return True; - end if; - - declare - Elt : constant Element_Type := - Container.Tree.Nodes (Position.Node).Element; - begin - - if Elt < Container.Tree.Nodes (Container.First).Element or - Container.Tree.Nodes (Container.Last).Element < Elt then - return False; - end if; - - return True; - end; + return Container.Nodes (Position.Node).Has_Element; end Has_Element; ------------- @@ -1399,13 +935,13 @@ package body Ada.Containers.Formal_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (set is locked)"; end if; declare - N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + N : Tree_Types.Nodes_Type renames Container.Nodes; begin N (Position.Node).Element := New_Item; end; @@ -1423,13 +959,9 @@ package body Ada.Containers.Formal_Ordered_Sets is Inserted : out Boolean) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; Insert_Sans_Hint - (Container.Tree.all, + (Container, New_Item, Position.Node, Inserted); @@ -1457,7 +989,7 @@ package body Ada.Containers.Formal_Ordered_Sets is ---------------------- procedure Insert_Sans_Hint - (Container : in out Tree_Types.Tree_Type; + (Container : in out Set; New_Item : Element_Type; Node : out Count_Type; Inserted : out Boolean) @@ -1513,7 +1045,7 @@ package body Ada.Containers.Formal_Ordered_Sets is ---------------------- procedure Insert_With_Hint - (Dst_Set : in out Tree_Types.Tree_Type; + (Dst_Set : in out Set; Dst_Hint : Count_Type; Src_Node : Node_Type; Dst_Node : out Count_Type) @@ -1578,70 +1110,7 @@ package body Ada.Containers.Formal_Ordered_Sets is procedure Intersection (Target : in out Set; Source : Set) is begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - if Source.K = Plain then - Set_Ops.Set_Intersection (Target.Tree.all, Source.Tree.all); - else - declare - Tgt : Count_Type := Target.First; - Src : Count_Type := Source.First; - - S_Last : constant Count_Type := - Next (Source.Tree.all, Source.Last); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - - if Source.Length = 0 then - Clear (Target); - return; - end if; - - while Tgt /= 0 - and then Src /= S_Last - loop - if Target.Tree.Nodes (Tgt).Element < - Source.Tree.Nodes (Src).Element then - declare - X : constant Count_Type := Tgt; - begin - Tgt := Next (Target.Tree.all, Tgt); - Delete_Node_Sans_Free (Target.Tree.all, X); - Formal_Ordered_Sets.Free (Target.Tree.all, X); - end; - - elsif Source.Tree.Nodes (Src).Element < - Target.Tree.Nodes (Tgt).Element then - Src := Next (Source.Tree.all, Src); - - else - Tgt := Next (Target.Tree.all, Tgt); - Src := Next (Source.Tree.all, Src); - end if; - end loop; - - while Tgt /= 0 loop - declare - X : constant Count_Type := Tgt; - begin - Tgt := Next (Target.Tree.all, Tgt); - Delete_Node_Sans_Free (Target.Tree.all, X); - Formal_Ordered_Sets.Free (Target.Tree.all, X); - end; - end loop; - end; - end if; + Set_Ops.Set_Intersection (Target, Source); end Intersection; function Intersection (Left, Right : Set) return Set is @@ -1651,55 +1120,8 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; return S : Set (Count_Type'Min (Length (Left), Length (Right))) do - if Left.K = Plain and Right.K = Plain then - Assign (S.Tree.all, Set_Ops.Set_Intersection - (Left.Tree.all, Right.Tree.all)); - return; - end if; - - if Length (Left) = 0 or Length (Right) = 0 then - return; - end if; - - declare - - L_Node : Count_Type := First (Left).Node; - R_Node : Count_Type := First (Right).Node; - - L_Last : constant Count_Type := - Next (Left.Tree.all, Last (Left).Node); - R_Last : constant Count_Type := - Next (Right.Tree.all, Last (Right).Node); - - Dst_Node : Count_Type; - - begin - loop - - if L_Node = L_Last or R_Node = R_Last then - return; - end if; - - if Left.Tree.Nodes (L_Node).Element < - Right.Tree.Nodes (R_Node).Element then - L_Node := Next (Left.Tree.all, L_Node); - - elsif Right.Tree.Nodes (R_Node).Element < - Left.Tree.Nodes (L_Node).Element then - R_Node := Next (Right.Tree.all, R_Node); - - else - Insert_With_Hint - (Dst_Set => S.Tree.all, - Dst_Hint => 0, - Src_Node => Left.Tree.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Next (Left.Tree.all, L_Node); - R_Node := Next (Right.Tree.all, R_Node); - end if; - end loop; - end; + Assign (S, Set_Ops.Set_Intersection + (Left, Right)); end return; end Intersection; @@ -1753,52 +1175,8 @@ package body Ada.Containers.Formal_Ordered_Sets is function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is begin - if Subset.K = Plain and Of_Set.K = Plain then - return Set_Ops.Set_Subset (Subset.Tree.all, - Of_Set => Of_Set.Tree.all); - end if; - - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Length (Subset) > Length (Of_Set) then - return False; - end if; - - declare - Subset_Node : Count_Type := First (Subset).Node; - Set_Node : Count_Type := First (Of_Set).Node; - - Subset_Last : constant Count_Type := - Next (Subset.Tree.all, Last (Subset).Node); - Set_Last : constant Count_Type := - Next (Of_Set.Tree.all, Last (Of_Set).Node); - - begin - loop - if Set_Node = Set_Last then - return Subset_Node = 0; - end if; - - if Subset_Node = Subset_Last then - return True; - end if; - - if Subset.Tree.Nodes (Subset_Node).Element < - Of_Set.Tree.Nodes (Set_Node).Element then - return False; - end if; - - if Of_Set.Tree.Nodes (Set_Node).Element < - Subset.Tree.Nodes (Subset_Node).Element then - Set_Node := Next (Of_Set.Tree.all, Set_Node); - else - Set_Node := Next (Of_Set.Tree.all, Set_Node); - Subset_Node := Next (Subset.Tree.all, Subset_Node); - end if; - end loop; - end; + return Set_Ops.Set_Subset (Subset, + Of_Set => Of_Set); end Is_Subset; ------------- @@ -1816,9 +1194,6 @@ package body Ada.Containers.Formal_Ordered_Sets is procedure Local_Iterate is new Tree_Operations.Generic_Iteration (Process_Node); - procedure Local_Iterate_Between is - new Iterate_Between (Process_Node); - ------------------ -- Process_Node -- ------------------ @@ -1828,8 +1203,7 @@ package body Ada.Containers.Formal_Ordered_Sets is Process (Container, (Node => Node)); end Process_Node; - T : Tree_Types.Tree_Type renames Container.Tree.all; - B : Natural renames T.Busy; + B : Natural renames Container'Unrestricted_Access.Busy; -- Start of prccessing for Iterate @@ -1837,17 +1211,7 @@ package body Ada.Containers.Formal_Ordered_Sets is B := B + 1; begin - if Container.K = Plain then - Local_Iterate (T); - return; - end if; - - if Container.Length = 0 then - return; - end if; - - Local_Iterate_Between (T, Container.First, Container.Last); - + Local_Iterate (Container); exception when others => B := B - 1; @@ -1857,42 +1221,6 @@ package body Ada.Containers.Formal_Ordered_Sets is B := B - 1; end Iterate; - --------------------- - -- Iterate_Between -- - --------------------- - - procedure Iterate_Between (Tree : Tree_Types.Tree_Type; - From : Count_Type; - To : Count_Type) is - - FElt : constant Element_Type := Tree.Nodes (From).Element; - TElt : constant Element_Type := Tree.Nodes (To).Element; - procedure Iterate (P : Count_Type); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (P : Count_Type) is - X : Count_Type := P; - begin - while X /= 0 loop - if Tree.Nodes (X).Element < FElt then - X := Tree.Nodes (X).Right; - elsif TElt < Tree.Nodes (X).Element then - X := Tree.Nodes (X).Left; - else - Iterate (Tree.Nodes (X).Left); - Process (X); - X := Tree.Nodes (X).Right; - end if; - end loop; - end Iterate; - - begin - Iterate (Tree.Root); - end Iterate_Between; - ---------- -- Last -- ---------- @@ -1903,11 +1231,8 @@ package body Ada.Containers.Formal_Ordered_Sets is return No_Element; end if; - if Container.K = Plain then - return (Node => Container.Tree.Last); - end if; - return (Node => Container.Last); + end Last; ------------------ @@ -1921,7 +1246,7 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; declare - N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + N : Tree_Types.Nodes_Type renames Container.Nodes; begin return N (Last (Container).Node).Element; end; @@ -1932,35 +1257,24 @@ package body Ada.Containers.Formal_Ordered_Sets is ---------- function Left (Container : Set; Position : Cursor) return Set is - Lst : Count_Type; - Fst : constant Count_Type := First (Container).Node; - L : Count_Type := 0; - C : Count_Type := Fst; + Curs : Cursor := Position; + C : Set (Container.Capacity) := + Copy (Container, Container.Capacity); + Node : Count_Type; begin - while C /= Position.Node loop - if C = Last (Container).Node or C = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - Lst := C; - C := Next (Container.Tree.all, C); - L := L + 1; - end loop; - if L = 0 then - return (Capacity => Container.Capacity, - K => Part, - Tree => Container.Tree, - Length => 0, - First => 0, - Last => 0); - else - return (Capacity => Container.Capacity, - K => Part, - Tree => Container.Tree, - Length => L, - First => Fst, - Last => Lst); + if Curs = No_Element then + return C; + end if; + if not Has_Element (Container, Curs) then + raise Constraint_Error; end if; + + while Curs.Node /= 0 loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); + end loop; + return C; end Left; -------------- @@ -1978,11 +1292,7 @@ package body Ada.Containers.Formal_Ordered_Sets is function Length (Container : Set) return Count_Type is begin - if Container.K = Plain then - return Container.Tree.Length; - else - return Container.Length; - end if; + return Container.Length; end Length; ---------- @@ -1990,15 +1300,10 @@ package body Ada.Containers.Formal_Ordered_Sets is ---------- procedure Move (Target : in out Set; Source : in out Set) is - S : Tree_Types.Tree_Type renames Source.Tree.all; - N : Tree_Types.Nodes_Type renames S.Nodes; + N : Tree_Types.Nodes_Type renames Source.Nodes; X : Count_Type; begin - if Target.K /= Plain or Source.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Target'Address = Source'Address then return; @@ -2009,7 +1314,7 @@ package body Ada.Containers.Formal_Ordered_Sets is "Source length exceeds Target capacity"; end if; - if S.Busy > 0 then + if Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; @@ -2017,13 +1322,13 @@ package body Ada.Containers.Formal_Ordered_Sets is Clear (Target); loop - X := S.First; + X := Source.First; exit when X = 0; Insert (Target, N (X).Element); -- optimize??? - Tree_Operations.Delete_Node_Sans_Free (S, X); - Formal_Ordered_Sets.Free (S, X); + Tree_Operations.Delete_Node_Sans_Free (Source, X); + Formal_Ordered_Sets.Free (Source, X); end loop; end Move; @@ -2031,19 +1336,6 @@ package body Ada.Containers.Formal_Ordered_Sets is -- Next -- ---------- - function Next_Unchecked - (Container : Set; - Position : Count_Type) return Count_Type is - begin - - if Container.K = Part and then - (Container.Length = 0 or Position = Container.Last) then - return 0; - end if; - - return Tree_Operations.Next (Container.Tree.all, Position); - end Next_Unchecked; - function Next (Container : Set; Position : Cursor) return Cursor is begin if Position = No_Element then @@ -2054,9 +1346,9 @@ package body Ada.Containers.Formal_Ordered_Sets is raise Constraint_Error; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Next"); - return (Node => Next_Unchecked (Container, Position.Node)); + return (Node => Tree_Operations.Next (Container, Position.Node)); end Next; procedure Next (Container : Set; Position : in out Cursor) is @@ -2070,49 +1362,8 @@ package body Ada.Containers.Formal_Ordered_Sets is function Overlap (Left, Right : Set) return Boolean is begin - if Left.K = Plain and Right.K = Plain then - return Set_Ops.Set_Overlap (Left.Tree.all, Right.Tree.all); - end if; - - if Length (Left) = 0 or Length (Right) = 0 then - return False; - end if; - - declare - - L_Node : Count_Type := First (Left).Node; - R_Node : Count_Type := First (Right).Node; + return Set_Ops.Set_Overlap (Left, Right); - L_Last : constant Count_Type := - Next (Left.Tree.all, Last (Left).Node); - R_Last : constant Count_Type := - Next (Right.Tree.all, Last (Right).Node); - - begin - if Left'Address = Right'Address then - return True; - end if; - - loop - if L_Node = L_Last - or else R_Node = R_Last - then - return False; - end if; - - if Left.Tree.Nodes (L_Node).Element < - Right.Tree.Nodes (R_Node).Element then - L_Node := Next (Left.Tree.all, L_Node); - - elsif Right.Tree.Nodes (R_Node).Element < - Left.Tree.Nodes (L_Node).Element then - R_Node := Next (Right.Tree.all, R_Node); - - else - return True; - end if; - end loop; - end; end Overlap; ------------ @@ -2138,18 +1389,12 @@ package body Ada.Containers.Formal_Ordered_Sets is raise Constraint_Error; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Previous"); - if Container.K = Part and then - (Container.Length = 0 or Position.Node = Container.First) then - return No_Element; - end if; - declare - Tree : Tree_Types.Tree_Type renames Container.Tree.all; Node : constant Count_Type := - Tree_Operations.Previous (Tree, Position.Node); + Tree_Operations.Previous (Container, Position.Node); begin if Node = 0 then @@ -2175,30 +1420,25 @@ package body Ada.Containers.Formal_Ordered_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Query_Element"); declare - T : Tree_Types.Tree_Type renames Container.Tree.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; L := L + 1; begin - Process (T.Nodes (Position.Node).Element); + Process (Container.Nodes (Position.Node).Element); exception when others => L := L - 1; @@ -2238,20 +1478,9 @@ package body Ada.Containers.Formal_Ordered_Sets is end Read_Element; -- Start of processing for Read - Result : Tree_Type_Access; begin - if Container.K /= Plain then - raise Constraint_Error; - end if; - if Container.Tree = null then - Result := new Tree_Types.Tree_Type (Container.Capacity); - else - Result := Container.Tree; - end if; - - Read_Elements (Stream, Result.all); - Container.Tree := Result; + Read_Elements (Stream, Container); end Read; procedure Read @@ -2267,29 +1496,22 @@ package body Ada.Containers.Formal_Ordered_Sets is ------------- procedure Replace (Container : in out Set; New_Item : Element_Type) is - begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - declare - Node : constant Count_Type := - Element_Keys.Find (Container.Tree.all, New_Item); + Node : constant Count_Type := + Element_Keys.Find (Container, New_Item); - begin - if Node = 0 then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is locked)"; + end if; - Container.Tree.Nodes (Node).Element := New_Item; - end; + Container.Nodes (Node).Element := New_Item; end Replace; --------------------- @@ -2297,7 +1519,7 @@ package body Ada.Containers.Formal_Ordered_Sets is --------------------- procedure Replace_Element - (Tree : in out Tree_Types.Tree_Type; + (Tree : in out Set; Node : Count_Type; Item : Element_Type) is @@ -2398,20 +1620,16 @@ package body Ada.Containers.Formal_Ordered_Sets is New_Item : Element_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor has no element"; end if; - pragma Assert (Vet (Container.Tree.all, Position.Node), + pragma Assert (Vet (Container, Position.Node), "bad cursor in Replace_Element"); - Replace_Element (Container.Tree.all, Position.Node, New_Item); + Replace_Element (Container, Position.Node, New_Item); end Replace_Element; --------------------- @@ -2438,8 +1656,7 @@ package body Ada.Containers.Formal_Ordered_Sets is Process (Container, (Node => Node)); end Process_Node; - T : Tree_Types.Tree_Type renames Container.Tree.all; - B : Natural renames T.Busy; + B : Natural renames Container'Unrestricted_Access.Busy; -- Start of processing for Reverse_Iterate @@ -2447,29 +1664,7 @@ package body Ada.Containers.Formal_Ordered_Sets is B := B + 1; begin - if Container.K = Plain then - Local_Reverse_Iterate (T); - return; - end if; - - if Container.Length = 0 then - return; - end if; - - declare - Node : Count_Type := Container.Last; - First : constant Count_Type := - Previous (Container.Tree.all, Container.First); - - begin - - while Node /= First loop - Process_Node (Node); - Node := Previous (Container.Tree.all, Node); - end loop; - - end; - + Local_Reverse_Iterate (Container); exception when others => B := B - 1; @@ -2484,46 +1679,25 @@ package body Ada.Containers.Formal_Ordered_Sets is ----------- function Right (Container : Set; Position : Cursor) return Set is - Lst : Count_Type; - L : Count_Type := 0; - C : Count_Type := Position.Node; - begin - - if C = 0 then - return (Capacity => Container.Capacity, - K => Part, - Tree => Container.Tree, - Length => 0, - First => 0, - Last => 0); - end if; - - if Container.K = Plain then - Lst := 0; - else - Lst := Next (Container.Tree.all, Container.Last); + Curs : Cursor := First (Container); + C : Set (Container.Capacity) := + Copy (Container, Container.Capacity); + Node : Count_Type; + begin + if Curs = No_Element then + Clear (C); + return C; end if; - - if C = Lst then - raise Constraint_Error with - "Position cursor has no element"; + if Position /= No_Element and not Has_Element (Container, Position) then + raise Constraint_Error; end if; - while C /= Lst loop - if C = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - C := Next (Container.Tree.all, C); - L := L + 1; + while Curs.Node /= Position.Node loop + Node := Curs.Node; + Delete (C, Curs); + Curs := Next (Container, (Node => Node)); end loop; - - return (Capacity => Container.Capacity, - K => Part, - Tree => Container.Tree, - Length => L, - First => Position.Node, - Last => Last (Container).Node); + return C; end Right; --------------- @@ -2591,13 +1765,13 @@ package body Ada.Containers.Formal_Ordered_Sets is return True; end if; - if Left.Tree.Nodes (LNode).Element /= - Right.Tree.Nodes (RNode).Element then + if Left.Nodes (LNode).Element /= + Right.Nodes (RNode).Element then exit; end if; - LNode := Next_Unchecked (Left, LNode); - RNode := Next_Unchecked (Right, RNode); + LNode := Next (Left, LNode); + RNode := Next (Right, RNode); end loop; return False; @@ -2609,86 +1783,7 @@ package body Ada.Containers.Formal_Ordered_Sets is procedure Symmetric_Difference (Target : in out Set; Source : Set) is begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - if Source.K = Plain then - Set_Ops.Set_Symmetric_Difference (Target.Tree.all, Source.Tree.all); - return; - end if; - - if Source.Length = 0 then - return; - end if; - - declare - - Tgt : Count_Type := Target.First; - Src : Count_Type := Source.First; - - SLast : constant Count_Type := Next (Source.Tree.all, Source.Last); - - New_Tgt_Node : Count_Type; - - begin - if Target.Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - loop - if Tgt = 0 then - while Src /= SLast loop - Insert_With_Hint - (Dst_Set => Target.Tree.all, - Dst_Hint => 0, - Src_Node => Source.Tree.Nodes (Src), - Dst_Node => New_Tgt_Node); - - Src := Next (Source.Tree.all, Src); - end loop; - - return; - end if; - - if Src = SLast then - return; - end if; - - if Target.Tree.Nodes (Tgt).Element < - Source.Tree.Nodes (Src).Element then - Tgt := Next (Target.Tree.all, Tgt); - - elsif Source.Tree.Nodes (Src).Element < - Target.Tree.Nodes (Tgt).Element then - Insert_With_Hint - (Dst_Set => Target.Tree.all, - Dst_Hint => Tgt, - Src_Node => Source.Tree.Nodes (Src), - Dst_Node => New_Tgt_Node); - - Src := Next (Source.Tree.all, Src); - - else - declare - X : constant Count_Type := Tgt; - begin - Tgt := Next (Target.Tree.all, Tgt); - Delete_Node_Sans_Free (Target.Tree.all, X); - Formal_Ordered_Sets.Free (Target.Tree.all, X); - end; - - Src := Next (Source.Tree.all, Src); - end if; - end loop; - end; + Set_Ops.Set_Symmetric_Difference (Target, Source); end Symmetric_Difference; function Symmetric_Difference (Left, Right : Set) return Set is @@ -2706,84 +1801,9 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; return S : Set (Length (Left) + Length (Right)) do - if Left.K = Plain and Right.K = Plain then - Assign (S.Tree.all, - Set_Ops.Set_Symmetric_Difference (Left.Tree.all, - Right.Tree.all)); - return; - end if; - - declare - - Tree : Tree_Types.Tree_Type renames S.Tree.all; - - L_Node : Count_Type := First (Left).Node; - R_Node : Count_Type := First (Right).Node; - - L_Last : constant Count_Type := - Next (Left.Tree.all, Last (Left).Node); - R_Last : constant Count_Type := - Next (Right.Tree.all, Last (Right).Node); - - Dst_Node : Count_Type; - - begin - loop - if L_Node = L_Last then - while R_Node /= R_Last loop - Insert_With_Hint - (Dst_Set => Tree, - Dst_Hint => 0, - Src_Node => Right.Tree.Nodes (R_Node), - Dst_Node => Dst_Node); - - R_Node := Next (Right.Tree.all, R_Node); - end loop; - - return; - end if; - - if R_Node = R_Last then - while L_Node /= L_Last loop - Insert_With_Hint - (Dst_Set => Tree, - Dst_Hint => 0, - Src_Node => Left.Tree.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Next (Left.Tree.all, L_Node); - end loop; - - return; - end if; - - if Left.Tree.Nodes (L_Node).Element < - Right.Tree.Nodes (R_Node).Element then - Insert_With_Hint - (Dst_Set => Tree, - Dst_Hint => 0, - Src_Node => Left.Tree.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Next (Left.Tree.all, L_Node); - - elsif Right.Tree.Nodes (R_Node).Element < - Left.Tree.Nodes (L_Node).Element then - Insert_With_Hint - (Dst_Set => Tree, - Dst_Hint => 0, - Src_Node => Right.Tree.Nodes (R_Node), - Dst_Node => Dst_Node); - - R_Node := Next (Right.Tree.all, R_Node); - - else - L_Node := Next (Left.Tree.all, L_Node); - R_Node := Next (Right.Tree.all, R_Node); - end if; - end loop; - end; - + Assign (S, + Set_Ops.Set_Symmetric_Difference (Left, + Right)); end return; end Symmetric_Difference; @@ -2797,7 +1817,7 @@ package body Ada.Containers.Formal_Ordered_Sets is begin return S : Set (Capacity => 1) do - Insert_Sans_Hint (S.Tree.all, New_Item, Node, Inserted); + Insert_Sans_Hint (S, New_Item, Node, Inserted); pragma Assert (Inserted); end return; end To_Set; @@ -2808,55 +1828,7 @@ package body Ada.Containers.Formal_Ordered_Sets is procedure Union (Target : in out Set; Source : Set) is begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - if Source.K = Plain then - Set_Ops.Set_Union (Target.Tree.all, Source.Tree.all); - return; - end if; - - if Source.Length = 0 then - return; - end if; - - declare - Hint : Count_Type := 0; - - procedure Process (Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is new Iterate_Between (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Count_Type) is - begin - Insert_With_Hint - (Dst_Set => Target.Tree.all, - Dst_Hint => Hint, - Src_Node => Source.Tree.Nodes (Node), - Dst_Node => Hint); - end Process; - - -- Start of processing for Union - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - - Iterate (Source.Tree.all, Source.First, Source.Last); - end; + Set_Ops.Set_Union (Target, Source); end Union; function Union (Left, Right : Set) return Set is @@ -2910,7 +1882,7 @@ package body Ada.Containers.Formal_Ordered_Sets is -- Start of processing for Write begin - Write_Elements (Stream, Container.Tree.all); + Write_Elements (Stream, Container); end Write; procedure Write diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index b942ba49e92..acca6b94726 100644 --- a/gcc/ada/a-cforse.ads +++ b/gcc/ada/a-cforse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -265,27 +265,18 @@ private type Node_Type is record Has_Element : Boolean := False; - Parent : Count_Type; - Left : Count_Type; - Right : Count_Type; + Parent : Count_Type := 0; + Left : Count_Type := 0; + Right : Count_Type := 0; Color : Red_Black_Trees.Color_Type; Element : Element_Type; end record; - type Kind is (Plain, Part); - package Tree_Types is new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - type Tree_Type_Access is access all Tree_Types.Tree_Type; - - type Set (Capacity : Count_Type) is tagged record - Tree : Tree_Type_Access := new Tree_Types.Tree_Type (Capacity); - K : Kind := Plain; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - end record; + type Set (Capacity : Count_Type) is + new Tree_Types.Tree_Type (Capacity) with null record; use Red_Black_Trees; use Ada.Streams; diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index fd30ca9cda7..86b827f421d 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-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- -- @@ -44,30 +44,8 @@ package body Ada.Containers.Formal_Vectors is function "&" (Left, Right : Vector) return Vector is LN : constant Count_Type := Length (Left); RN : constant Count_Type := Length (Right); - - RFst : Count_Type; - RLst : Count_Type; - LFst : Count_Type; - LLst : Count_Type; - begin - if Right.K = Plain then - RFst := 1; - RLst := RN; - else - RFst := Right.First; - RLst := Right.First + RN - 1; - end if; - - if Left.K = Plain then - LFst := 1; - LLst := LN; - else - LFst := Left.First; - LLst := Left.First + LN - 1; - end if; - if LN = 0 then if RN = 0 then return Empty_Vector; @@ -75,24 +53,20 @@ package body Ada.Containers.Formal_Vectors is declare E : constant Elements_Array (1 .. Length (Right)) := - Right.Plain.Elements (RFst .. RLst); + Right.Elements (1 .. RN); begin - return (Length (Right), - new Plain_Vector'(Length (Right), E, - Last => Right.Plain.Last, others => <>), - others => <>); + return (Length (Right), E, + Last => Right.Last, others => <>); end; end if; if RN = 0 then declare E : constant Elements_Array (1 .. Length (Left)) := - Left.Plain.Elements (LFst .. LLst); + Left.Elements (1 .. LN); begin - return (Length (Left), - new Plain_Vector'(Length (Left), E, - Last => Left.Plain.Last, others => <>), - others => <>); + return (Length (Left), E, + Last => Left.Last, others => <>); end; end if; @@ -117,18 +91,16 @@ package body Ada.Containers.Formal_Vectors is declare Last : constant Index_Type := Index_Type (Last_As_Int); - LE : constant Elements_Array (1 .. Length (Left)) := - Left.Plain.Elements (LFst .. LLst); + LE : constant Elements_Array (1 .. LN) := + Left.Elements (1 .. LN); - RE : Elements_Array renames Right.Plain.Elements (RFst .. RLst); + RE : Elements_Array renames Right.Elements (1 .. RN); Capacity : constant Count_Type := Length (Left) + Length (Right); begin - return (Capacity, - new Plain_Vector'(Capacity, LE & RE, - Last => Last, others => <>), - others => <>); + return (Capacity, LE & RE, + Last => Last, others => <>); end; end; end "&"; @@ -136,15 +108,11 @@ package body Ada.Containers.Formal_Vectors is function "&" (Left : Vector; Right : Element_Type) return Vector is LN : constant Count_Type := Length (Left); Last_As_Int : Int'Base; - LFst : Count_Type; - LLst : Count_Type; begin if LN = 0 then - return (1, - new Plain_Vector'(1, (1 .. 1 => Right), - Index_Type'First, others => <>), - others => <>); + return (1, (1 .. 1 => Right), + Index_Type'First, others => <>); end if; if Int (Index_Type'First) > Int'Last - Int (LN) then @@ -157,27 +125,17 @@ package body Ada.Containers.Formal_Vectors is raise Constraint_Error with "new length is out of range"; end if; - if Left.K = Plain then - LFst := 1; - LLst := LN; - else - LFst := Left.First; - LLst := Left.First + LN - 1; - end if; - declare Last : constant Index_Type := Index_Type (Last_As_Int); LE : constant Elements_Array (1 .. LN) := - Left.Plain.Elements (LFst .. LLst); + Left.Elements (1 .. LN); Capacity : constant Count_Type := Length (Left) + 1; begin - return (Capacity, - new Plain_Vector'(Capacity, LE & Right, - Last => Last, others => <>), - others => <>); + return (Capacity, LE & Right, + Last => Last, others => <>); end; end "&"; @@ -186,15 +144,10 @@ package body Ada.Containers.Formal_Vectors is RN : constant Count_Type := Length (Right); Last_As_Int : Int'Base; - RFst : Count_Type; - RLst : Count_Type; - begin if RN = 0 then - return (1, - new Plain_Vector'(1, (1 .. 1 => Left), - Index_Type'First, others => <>), - others => <>); + return (1, (1 .. 1 => Left), + Index_Type'First, others => <>); end if; if Int (Index_Type'First) > Int'Last - Int (RN) then @@ -207,26 +160,16 @@ package body Ada.Containers.Formal_Vectors is raise Constraint_Error with "new length is out of range"; end if; - if Right.K = Plain then - RFst := 1; - RLst := RN; - else - RFst := Right.First; - RLst := Right.First + RN - 1; - end if; - declare Last : constant Index_Type := Index_Type (Last_As_Int); - RE : Elements_Array renames Right.Plain.Elements (RFst .. RLst); + RE : Elements_Array renames Right.Elements (1 .. RN); Capacity : constant Count_Type := 1 + Length (Right); begin - return (Capacity, - new Plain_Vector'(Capacity, Left & RE, - Last => Last, others => <>), - others => <>); + return (Capacity, Left & RE, + Last => Last, others => <>); end; end "&"; @@ -240,10 +183,8 @@ package body Ada.Containers.Formal_Vectors is Last : constant Index_Type := Index_Type'First + 1; begin - return (2, - new Plain_Vector'(2, (Left, Right), - Last => Last, others => <>), - others => <>); + return (2, (Left, Right), + Last => Last, others => <>); end; end "&"; @@ -277,22 +218,17 @@ package body Ada.Containers.Formal_Vectors is procedure Append (Container : in out Vector; New_Item : Vector) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Is_Empty (New_Item) then return; end if; - if Container.Plain.Last = Index_Type'Last then + if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; Insert (Container, - Container.Plain.Last + 1, + Container.Last + 1, New_Item); end Append; @@ -303,16 +239,11 @@ package body Ada.Containers.Formal_Vectors is is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Count = 0 then return; end if; - if Container.Plain.Last = Index_Type'Last then + if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -320,7 +251,7 @@ package body Ada.Containers.Formal_Vectors is Insert (Container, - Container.Plain.Last + 1, + Container.Last + 1, New_Item, Count); end Append; @@ -333,11 +264,6 @@ package body Ada.Containers.Formal_Vectors is LS : constant Count_Type := Length (Source); begin - if Target.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Target'Address = Source'Address then return; end if; @@ -348,15 +274,9 @@ package body Ada.Containers.Formal_Vectors is Target.Clear; - if Source.K = Plain then - Target.Plain.Elements (1 .. LS) := - Source.Plain.Elements (1 .. LS); - Target.Plain.Last := Source.Plain.Last; - else - Target.Plain.Elements (1 .. LS) := - Source.Plain.Elements (Source.First .. (Source.First + LS - 1)); - Target.Plain.Last := Source.Last; - end if; + Target.Elements (1 .. LS) := + Source.Elements (1 .. LS); + Target.Last := Source.Last; end Assign; @@ -366,7 +286,7 @@ package body Ada.Containers.Formal_Vectors is function Capacity (Container : Vector) return Capacity_Subtype is begin - return Container.Plain.Elements'Length; + return Container.Elements'Length; end Capacity; ----------- @@ -376,17 +296,12 @@ package body Ada.Containers.Formal_Vectors is procedure Clear (Container : in out Vector) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - Container.Plain.Last := No_Index; + Container.Last := No_Index; end Clear; -------------- @@ -424,15 +339,9 @@ package body Ada.Containers.Formal_Vectors is end if; return Target : Vector (C) do - if Source.K = Plain then - Target.Plain.Elements (1 .. LS) := - Source.Plain.Elements (1 .. LS); - Target.Plain.Last := Source.Plain.Last; - else - Target.Plain.Elements (1 .. LS) := - Source.Plain.Elements (Source.First .. (Source.First + LS - 1)); - Target.Plain.Last := Source.Last; - end if; + Target.Elements (1 .. LS) := + Source.Elements (1 .. LS); + Target.Last := Source.Last; end return; end Copy; @@ -448,17 +357,12 @@ package body Ada.Containers.Formal_Vectors is is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; - if Index > Container.Plain.Last then - if Index > Container.Plain.Last + 1 then + if Index > Container.Last then + if Index > Container.Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; @@ -469,7 +373,7 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; @@ -477,7 +381,7 @@ package body Ada.Containers.Formal_Vectors is declare I_As_Int : constant Int := Int (Index); Old_Last_As_Int : constant Int := - Index_Type'Pos (Container.Plain.Last); + Index_Type'Pos (Container.Last); Count1 : constant Int'Base := Count_Type'Pos (Count); Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; @@ -487,11 +391,11 @@ package body Ada.Containers.Formal_Vectors is begin if J_As_Int > Old_Last_As_Int then - Container.Plain.Last := Index - 1; + Container.Last := Index - 1; else declare - EA : Elements_Array renames Container.Plain.Elements; + EA : Elements_Array renames Container.Elements; II : constant Int'Base := I_As_Int - Int (No_Index); I : constant Count_Type := Count_Type (II); @@ -508,7 +412,7 @@ package body Ada.Containers.Formal_Vectors is begin EA (I .. K) := EA (J .. Length (Container)); - Container.Plain.Last := New_Last; + Container.Last := New_Last; end; end if; end; @@ -521,16 +425,11 @@ package body Ada.Containers.Formal_Vectors is is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Index > Container.Plain.Last then + if Position.Index > Container.Last then raise Program_Error with "Position index is out of range"; end if; @@ -548,11 +447,6 @@ package body Ada.Containers.Formal_Vectors is is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Count = 0 then return; end if; @@ -577,26 +471,21 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Count = 0 then return; end if; - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - Index := Int'Base (Container.Plain.Last) - Int'Base (Count); + Index := Int'Base (Container.Last) - Int'Base (Count); if Index < Index_Type'Pos (Index_Type'First) then - Container.Plain.Last := No_Index; + Container.Last := No_Index; else - Container.Plain.Last := Index_Type (Index); + Container.Last := Index_Type (Index); end if; end Delete_Last; @@ -609,7 +498,7 @@ package body Ada.Containers.Formal_Vectors is Index : Index_Type) return Element_Type is begin - if Index > Container.Plain.Last then + if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; @@ -619,11 +508,6 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K = Part and then - (I > Length (Container)) then - raise Constraint_Error with "Index is out of range"; - end if; - return Get_Element (Container, I); end; end Element; @@ -760,7 +644,7 @@ package body Ada.Containers.Formal_Vectors is Last : constant Index_Type := Last_Index (Container); begin - if Container.Plain.Last <= Last then + if Container.Last <= Last then return True; end if; @@ -786,14 +670,9 @@ package body Ada.Containers.Formal_Vectors is procedure Merge (Target, Source : in out Vector) is begin - if Target.K /= Plain or Source.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - declare - TA : Elements_Array renames Target.Plain.Elements; - SA : Elements_Array renames Source.Plain.Elements; + TA : Elements_Array renames Target.Elements; + SA : Elements_Array renames Source.Elements; I, J : Count_Type; @@ -808,17 +687,17 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Source.Plain.Last < Index_Type'First then + if Source.Last < Index_Type'First then return; end if; -- I think we're missing this check in a-convec.adb... ??? - if Target.Plain.Busy > 0 then + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - if Source.Plain.Busy > 0 then + if Source.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; @@ -834,7 +713,7 @@ package body Ada.Containers.Formal_Vectors is if I = 0 then TA (1 .. J) := SA (1 .. Length (Source)); - Source.Plain.Last := No_Index; + Source.Last := No_Index; return; end if; @@ -847,7 +726,7 @@ package body Ada.Containers.Formal_Vectors is else TA (J) := SA (Length (Source)); - Source.Plain.Last := Source.Plain.Last - 1; + Source.Last := Source.Last - 1; end if; J := J - 1; @@ -867,24 +746,18 @@ package body Ada.Containers.Formal_Vectors is Element_Type => Element_Type, Array_Type => Elements_Array, "<" => "<"); - begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - - if Container.Plain.Last <= Index_Type'First then + if Container.Last <= Index_Type'First then return; end if; - if Container.Plain.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (vector is locked)"; end if; - Sort (Container.Plain.Elements (1 .. Length (Container))); + Sort (Container.Elements (1 .. Length (Container))); end Sort; end Generic_Sorting; @@ -897,11 +770,9 @@ package body Ada.Containers.Formal_Vectors is (Container : Vector; Position : Count_Type) return Element_Type is begin - if Container.K = Plain then - return Container.Plain.Elements (Position); - end if; - return Container.Plain.Elements (Position + Container.First - 1); + return Container.Elements (Position); + end Get_Element; ----------------- @@ -939,18 +810,13 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; - if Before > Container.Plain.Last - and then Before > Container.Plain.Last + 1 + if Before > Container.Last + and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; @@ -961,7 +827,7 @@ package body Ada.Containers.Formal_Vectors is end if; declare - Old_Last_As_Int : constant Int := Int (Container.Plain.Last); + Old_Last_As_Int : constant Int := Int (Container.Last); begin if Old_Last_As_Int > Int'Last - N then @@ -985,13 +851,13 @@ package body Ada.Containers.Formal_Vectors is -- Resolve issue of capacity vs. max index ??? end; - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; declare - EA : Elements_Array renames Container.Plain.Elements; + EA : Elements_Array renames Container.Elements; BB : constant Int'Base := Int (Before) - Int (No_Index); B : constant Count_Type := Count_Type (BB); @@ -1000,7 +866,7 @@ package body Ada.Containers.Formal_Vectors is L : constant Count_Type := Count_Type (LL); begin - if Before <= Container.Plain.Last then + if Before <= Container.Last then declare II : constant Int'Base := BB + N; I : constant Count_Type := Count_Type (II); @@ -1015,7 +881,7 @@ package body Ada.Containers.Formal_Vectors is end if; end; - Container.Plain.Last := New_Last; + Container.Last := New_Last; end Insert; procedure Insert @@ -1027,18 +893,13 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; - if Before > Container.Plain.Last - and then Before > Container.Plain.Last + 1 + if Before > Container.Last + and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; @@ -1056,37 +917,26 @@ package body Ada.Containers.Formal_Vectors is Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int); - Src_Fst : Count_Type; - Src_Lst : Count_Type; - BB : constant Int'Base := Int (Before) - Int (No_Index); B : constant Count_Type := Count_Type (BB); begin - if Container.K = Plain then - Src_Fst := 1; - Src_Lst := N; - else - Src_Fst := New_Item.First; - Src_Lst := N + New_Item.First - 1; - end if; - if Container'Address /= New_Item'Address then - Container.Plain.Elements (B .. Dst_Last) := - New_Item.Plain.Elements (Src_Fst .. Src_Lst); + Container.Elements (B .. Dst_Last) := + New_Item.Elements (1 .. N); return; end if; declare - Src : Elements_Array renames Container.Plain.Elements (1 .. B - 1); + Src : Elements_Array renames Container.Elements (1 .. B - 1); Index_As_Int : constant Int'Base := BB + Src'Length - 1; Index : constant Count_Type := Count_Type (Index_As_Int); - Dst : Elements_Array renames Container.Plain.Elements (B .. Index); + Dst : Elements_Array renames Container.Elements (B .. Index); begin Dst := Src; @@ -1098,7 +948,7 @@ package body Ada.Containers.Formal_Vectors is declare Src : Elements_Array renames - Container.Plain.Elements + Container.Elements (Dst_Last + 1 .. Length (Container)); Index_As_Int : constant Int'Base := @@ -1107,7 +957,7 @@ package body Ada.Containers.Formal_Vectors is Index : constant Count_Type := Count_Type (Index_As_Int); Dst : Elements_Array renames - Container.Plain.Elements (Index .. Dst_Last); + Container.Elements (Index .. Dst_Last); begin Dst := Src; @@ -1124,24 +974,19 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Is_Empty (New_Item) then return; end if; if not Before.Valid - or else Before.Index > Container.Plain.Last + or else Before.Index > Container.Last then - if Container.Plain.Last = Index_Type'Last then + if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; - Index := Container.Plain.Last + 1; + Index := Container.Last + 1; else Index := Before.Index; @@ -1160,14 +1005,9 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Is_Empty (New_Item) then if not Before.Valid - or else Before.Index > Container.Plain.Last + or else Before.Index > Container.Last then Position := No_Element; else @@ -1178,14 +1018,14 @@ package body Ada.Containers.Formal_Vectors is end if; if not Before.Valid - or else Before.Index > Container.Plain.Last + or else Before.Index > Container.Last then - if Container.Plain.Last = Index_Type'Last then + if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; - Index := Container.Plain.Last + 1; + Index := Container.Last + 1; else Index := Before.Index; @@ -1206,24 +1046,19 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Count = 0 then return; end if; if not Before.Valid - or else Before.Index > Container.Plain.Last + or else Before.Index > Container.Last then - if Container.Plain.Last = Index_Type'Last then + if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; - Index := Container.Plain.Last + 1; + Index := Container.Last + 1; else Index := Before.Index; @@ -1243,14 +1078,9 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Count = 0 then if not Before.Valid - or else Before.Index > Container.Plain.Last + or else Before.Index > Container.Last then Position := No_Element; else @@ -1261,14 +1091,14 @@ package body Ada.Containers.Formal_Vectors is end if; if not Before.Valid - or else Before.Index > Container.Plain.Last + or else Before.Index > Container.Last then - if Container.Plain.Last = Index_Type'Last then + if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; - Index := Container.Plain.Last + 1; + Index := Container.Last + 1; else Index := Before.Index; @@ -1323,18 +1153,13 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; - if Before > Container.Plain.Last - and then Before > Container.Plain.Last + 1 + if Before > Container.Last + and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; @@ -1345,7 +1170,7 @@ package body Ada.Containers.Formal_Vectors is end if; declare - Old_Last_As_Int : constant Int := Int (Container.Plain.Last); + Old_Last_As_Int : constant Int := Int (Container.Last); begin if Old_Last_As_Int > Int'Last - N then @@ -1369,13 +1194,13 @@ package body Ada.Containers.Formal_Vectors is -- Resolve issue of capacity vs. max index ??? end; - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; declare - EA : Elements_Array renames Container.Plain.Elements; + EA : Elements_Array renames Container.Elements; BB : constant Int'Base := Int (Before) - Int (No_Index); B : constant Count_Type := Count_Type (BB); @@ -1384,7 +1209,7 @@ package body Ada.Containers.Formal_Vectors is L : constant Count_Type := Count_Type (LL); begin - if Before <= Container.Plain.Last then + if Before <= Container.Last then declare II : constant Int'Base := BB + N; I : constant Count_Type := Count_Type (II); @@ -1395,7 +1220,7 @@ package body Ada.Containers.Formal_Vectors is end if; end; - Container.Plain.Last := New_Last; + Container.Last := New_Last; end Insert_Space; procedure Insert_Space @@ -1408,14 +1233,9 @@ package body Ada.Containers.Formal_Vectors is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Count = 0 then if not Before.Valid - or else Before.Index > Container.Plain.Last + or else Before.Index > Container.Last then Position := No_Element; else @@ -1426,14 +1246,14 @@ package body Ada.Containers.Formal_Vectors is end if; if not Before.Valid - or else Before.Index > Container.Plain.Last + or else Before.Index > Container.Last then - if Container.Plain.Last = Index_Type'Last then + if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; - Index := Container.Plain.Last + 1; + Index := Container.Last + 1; else Index := Before.Index; @@ -1463,7 +1283,7 @@ package body Ada.Containers.Formal_Vectors is not null access procedure (Container : Vector; Position : Cursor)) is V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Plain.Busy; + B : Natural renames V.Busy; begin B := B + 1; @@ -1513,11 +1333,7 @@ package body Ada.Containers.Formal_Vectors is function Last_Index (Container : Vector) return Extended_Index is begin - if Container.K = Plain then - return Container.Plain.Last; - else - return Container.Last; - end if; + return Container.Last; end Last_Index; ------------ @@ -1538,26 +1354,20 @@ package body Ada.Containers.Formal_Vectors is ---------- function Left (Container : Vector; Position : Cursor) return Vector is - Fst : Count_Type; + C : Vector (Container.Capacity) := + Copy (Container, Container.Capacity); begin - if Container.K = Plain then - Fst := 1; - else - Fst := Container.First; - end if; - - if not Position.Valid then - return (Container.Capacity, Container.Plain, Part, Fst, - Last_Index (Container)); + if Position = No_Element then + return C; end if; - - if Position.Index > Last_Index (Container) then - raise Constraint_Error with - "Before index is out of range (too large)"; + if not Has_Element (Container, Position) then + raise Constraint_Error; end if; - return (Container.Capacity, Container.Plain, Part, Fst, - (Position.Index - 1)); + while C.Last /= Position.Index - 1 loop + Delete_Last (C); + end loop; + return C; end Left; ---------- @@ -1572,21 +1382,16 @@ package body Ada.Containers.Formal_Vectors is begin - if Target.K /= Plain or Source.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Target'Address = Source'Address then return; end if; - if Target.Plain.Busy > 0 then + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (Target is busy)"; end if; - if Source.Plain.Busy > 0 then + if Source.Busy > 0 then raise Program_Error with "attempt to tamper with elements (Source is busy)"; end if; @@ -1599,11 +1404,11 @@ package body Ada.Containers.Formal_Vectors is -- We could also write this as a loop, and incrementally -- copy elements from source to target. - Target.Plain.Last := No_Index; -- in case array assignment files - Target.Plain.Elements (1 .. N) := Source.Plain.Elements (1 .. N); + Target.Last := No_Index; -- in case array assignment files + Target.Elements (1 .. N) := Source.Elements (1 .. N); - Target.Plain.Last := Source.Plain.Last; - Source.Plain.Last := No_Index; + Target.Last := Source.Last; + Source.Last := No_Index; end Move; ---------- @@ -1703,8 +1508,8 @@ package body Ada.Containers.Formal_Vectors is Process : not null access procedure (Element : Element_Type)) is V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Plain.Busy; - L : Natural renames V.Plain.Lock; + B : Natural renames V.Busy; + L : Natural renames V.Lock; begin if Index > Last_Index (Container) then @@ -1770,8 +1575,8 @@ package body Ada.Containers.Formal_Vectors is for J in Count_Type range 1 .. Length loop Last := Last + 1; - Element_Type'Read (Stream, Container.Plain.Elements (J)); - Container.Plain.Last := Last; + Element_Type'Read (Stream, Container.Elements (J)); + Container.Last := Last; end loop; end Read; @@ -1793,16 +1598,12 @@ package body Ada.Containers.Formal_Vectors is New_Item : Element_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Index > Container.Plain.Last then + if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - if Container.Plain.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (vector is locked)"; end if; @@ -1812,7 +1613,7 @@ package body Ada.Containers.Formal_Vectors is I : constant Count_Type := Count_Type (II); begin - Container.Plain.Elements (I) := New_Item; + Container.Elements (I) := New_Item; end; end Replace_Element; @@ -1822,20 +1623,16 @@ package body Ada.Containers.Formal_Vectors is New_Item : Element_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Index > Container.Plain.Last then + if Position.Index > Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; - if Container.Plain.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (vector is locked)"; end if; @@ -1845,7 +1642,7 @@ package body Ada.Containers.Formal_Vectors is I : constant Count_Type := Count_Type (II); begin - Container.Plain.Elements (I) := New_Item; + Container.Elements (I) := New_Item; end; end Replace_Element; @@ -1858,10 +1655,6 @@ package body Ada.Containers.Formal_Vectors is Capacity : Capacity_Subtype) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Capacity > Container.Capacity then raise Constraint_Error; -- ??? @@ -1874,23 +1667,19 @@ package body Ada.Containers.Formal_Vectors is procedure Reverse_Elements (Container : in out Vector) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Length (Container) <= 1 then return; end if; - if Container.Plain.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (vector is locked)"; end if; declare I, J : Count_Type; - E : Elements_Array renames Container.Plain.Elements; + E : Elements_Array renames Container.Elements; begin I := 1; @@ -1983,7 +1772,7 @@ package body Ada.Containers.Formal_Vectors is not null access procedure (Container : Vector; Position : Cursor)) is V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Plain.Busy; + B : Natural renames V.Busy; begin B := B + 1; @@ -2006,27 +1795,21 @@ package body Ada.Containers.Formal_Vectors is ----------- function Right (Container : Vector; Position : Cursor) return Vector is - Fst : Count_Type; + C : Vector (Container.Capacity) := + Copy (Container, Container.Capacity); begin - if Container.K = Plain then - Fst := 1; - else - Fst := Container.First; + if Position = No_Element then + Clear (C); + return C; end if; - - if not Position.Valid then - return (Container.Capacity, Container.Plain, Part, Fst, No_Index); - end if; - - if Position.Index > Last_Index (Container) then - raise Constraint_Error with - "Position index is out of range (too large)"; + if not Has_Element (Container, Position) then + raise Constraint_Error; end if; - Fst := Fst + Count_Type (Int (Position.Index) - Int (No_Index)) - 1; - - return (Container.Capacity, Container.Plain, Part, Fst, - (Last_Index (Container) - Position.Index + 1)); + while C.Last /= Container.Last - Position.Index + 1 loop + Delete_First (C); + end loop; + return C; end Right; ---------------- @@ -2038,16 +1821,12 @@ package body Ada.Containers.Formal_Vectors is Length : Capacity_Subtype) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if Length = Formal_Vectors.Length (Container) then return; end if; - if Container.Plain.Busy > 0 then + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; @@ -2060,7 +1839,7 @@ package body Ada.Containers.Formal_Vectors is Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (Length) - 1; begin - Container.Plain.Last := Index_Type'Base (Last_As_Int); + Container.Last := Index_Type'Base (Last_As_Int); end; end Set_Length; @@ -2070,16 +1849,12 @@ package body Ada.Containers.Formal_Vectors is procedure Swap (Container : in out Vector; I, J : Index_Type) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if I > Container.Plain.Last then + if I > Container.Last then raise Constraint_Error with "I index is out of range"; end if; - if J > Container.Plain.Last then + if J > Container.Last then raise Constraint_Error with "J index is out of range"; end if; @@ -2087,7 +1862,7 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Plain.Lock > 0 then + if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (vector is locked)"; end if; @@ -2096,8 +1871,8 @@ package body Ada.Containers.Formal_Vectors is II : constant Int'Base := Int (I) - Int (No_Index); JJ : constant Int'Base := Int (J) - Int (No_Index); - EI : Element_Type renames Container.Plain.Elements (Count_Type (II)); - EJ : Element_Type renames Container.Plain.Elements (Count_Type (JJ)); + EI : Element_Type renames Container.Elements (Count_Type (II)); + EJ : Element_Type renames Container.Elements (Count_Type (JJ)); EI_Copy : constant Element_Type := EI; @@ -2109,10 +1884,6 @@ package body Ada.Containers.Formal_Vectors is procedure Swap (Container : in out Vector; I, J : Cursor) is begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; if not I.Valid then raise Constraint_Error with "I cursor has no element"; @@ -2176,9 +1947,7 @@ package body Ada.Containers.Formal_Vectors is Last := Index_Type (Last_As_Int); - return (Length, - new Plain_Vector'(Length, (others => <>), Last => Last, - others => <>), + return (Length, (others => <>), Last => Last, others => <>); end; end To_Vector; @@ -2204,9 +1973,7 @@ package body Ada.Containers.Formal_Vectors is Last := Index_Type (Last_As_Int); - return (Length, - new Plain_Vector'(Length, (others => New_Item), Last => Last, - others => <>), + return (Length, (others => New_Item), Last => Last, others => <>); end; end To_Vector; @@ -2220,16 +1987,12 @@ package body Ada.Containers.Formal_Vectors is Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - B : Natural renames Container.Plain.Busy; - L : Natural renames Container.Plain.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin - if Container.K /= Plain then - raise Constraint_Error - with "Can't modify part of container"; - end if; - if Index > Container.Plain.Last then + if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; @@ -2241,7 +2004,7 @@ package body Ada.Containers.Formal_Vectors is I : constant Count_Type := Count_Type (II); begin - Process (Container.Plain.Elements (I)); + Process (Container.Elements (I)); exception when others => L := L - 1; @@ -2278,7 +2041,7 @@ package body Ada.Containers.Formal_Vectors is Count_Type'Base'Write (Stream, Length (Container)); for J in 1 .. Length (Container) loop - Element_Type'Write (Stream, Container.Plain.Elements (J)); + Element_Type'Write (Stream, Container.Elements (J)); end loop; end Write; diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 1b52325682a..8dcb7475163 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -366,24 +366,13 @@ private type Elements_Array is array (Count_Type range <>) of Element_Type; function "=" (L, R : Elements_Array) return Boolean is abstract; - type Kind is (Plain, Part); - - type Plain_Vector (Capacity : Capacity_Subtype) is record + type Vector (Capacity : Capacity_Subtype) is tagged record Elements : Elements_Array (1 .. Capacity); Last : Extended_Index := No_Index; Busy : Natural := 0; Lock : Natural := 0; end record; - type Plain_Access is access all Plain_Vector; - - type Vector (Capacity : Capacity_Subtype) is tagged record - Plain : Plain_Access := new Plain_Vector (Capacity); - K : Kind := Formal_Vectors.Plain; - First : Count_Type := 0; - Last : Index_Type'Base := No_Index; - end record; - use Ada.Streams; procedure Write diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 5f6180bdc21..0b25f1a8c0f 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -8280,9 +8280,9 @@ package body Exp_Dist is function Find_Numeric_Representation (Typ : Entity_Id) return Entity_Id; - -- Given a numeric type Typ, return the smallest integer or floating - -- point type from Standard, or the smallest unsigned (modular) type - -- from System.Unsigned_Types, whose range encompasses that of Typ. + -- Given a numeric type Typ, return the smallest integer or modular + -- type from Interfaces, or the smallest floating point type from + -- Standard whose range encompasses that of Typ. function Make_Helper_Function_Name (Loc : Source_Ptr; @@ -8583,37 +8583,31 @@ package body Exp_Dist is -- Integer types - elsif U_Type = Etype (Standard_Short_Short_Integer) then - Lib_RE := RE_FA_SSI; + elsif U_Type = RTE (RE_Integer_8) then + Lib_RE := RE_FA_I8; - elsif U_Type = Etype (Standard_Short_Integer) then - Lib_RE := RE_FA_SI; + elsif U_Type = RTE (RE_Integer_16) then + Lib_RE := RE_FA_I16; - elsif U_Type = Etype (Standard_Integer) then - Lib_RE := RE_FA_I; + elsif U_Type = RTE (RE_Integer_32) then + Lib_RE := RE_FA_I32; - elsif U_Type = Etype (Standard_Long_Integer) then - Lib_RE := RE_FA_LI; - - elsif U_Type = Etype (Standard_Long_Long_Integer) then - Lib_RE := RE_FA_LLI; + elsif U_Type = RTE (RE_Integer_64) then + Lib_RE := RE_FA_I64; -- Unsigned integer types - elsif U_Type = RTE (RE_Short_Short_Unsigned) then - Lib_RE := RE_FA_SSU; - - elsif U_Type = RTE (RE_Short_Unsigned) then - Lib_RE := RE_FA_SU; + elsif U_Type = RTE (RE_Unsigned_8) then + Lib_RE := RE_FA_U8; - elsif U_Type = RTE (RE_Unsigned) then - Lib_RE := RE_FA_U; + elsif U_Type = RTE (RE_Unsigned_16) then + Lib_RE := RE_FA_U16; - elsif U_Type = RTE (RE_Long_Unsigned) then - Lib_RE := RE_FA_LU; + elsif U_Type = RTE (RE_Unsigned_32) then + Lib_RE := RE_FA_U32; - elsif U_Type = RTE (RE_Long_Long_Unsigned) then - Lib_RE := RE_FA_LLU; + elsif U_Type = RTE (RE_Unsigned_64) then + Lib_RE := RE_FA_U64; elsif Is_RTE (U_Type, RE_Unbounded_String) then Lib_RE := RE_FA_String; @@ -9213,7 +9207,7 @@ package body Exp_Dist is Make_Object_Declaration (Loc, Defining_Identifier => Counter, Object_Definition => - New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc), + New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), Expression => Make_Integer_Literal (Loc, Initial_Counter_Value))); @@ -9398,37 +9392,31 @@ package body Exp_Dist is -- Integer types - elsif U_Type = Etype (Standard_Short_Short_Integer) then - Lib_RE := RE_TA_SSI; - - elsif U_Type = Etype (Standard_Short_Integer) then - Lib_RE := RE_TA_SI; + elsif U_Type = RTE (RE_Integer_8) then + Lib_RE := RE_TA_I8; - elsif U_Type = Etype (Standard_Integer) then - Lib_RE := RE_TA_I; + elsif U_Type = RTE (RE_Integer_16) then + Lib_RE := RE_TA_I16; - elsif U_Type = Etype (Standard_Long_Integer) then - Lib_RE := RE_TA_LI; + elsif U_Type = RTE (RE_Integer_32) then + Lib_RE := RE_TA_I32; - elsif U_Type = Etype (Standard_Long_Long_Integer) then - Lib_RE := RE_TA_LLI; + elsif U_Type = RTE (RE_Integer_64) then + Lib_RE := RE_TA_I64; -- Unsigned integer types - elsif U_Type = RTE (RE_Short_Short_Unsigned) then - Lib_RE := RE_TA_SSU; + elsif U_Type = RTE (RE_Unsigned_8) then + Lib_RE := RE_TA_U8; - elsif U_Type = RTE (RE_Short_Unsigned) then - Lib_RE := RE_TA_SU; + elsif U_Type = RTE (RE_Unsigned_16) then + Lib_RE := RE_TA_U16; - elsif U_Type = RTE (RE_Unsigned) then - Lib_RE := RE_TA_U; + elsif U_Type = RTE (RE_Unsigned_32) then + Lib_RE := RE_TA_U32; - elsif U_Type = RTE (RE_Long_Unsigned) then - Lib_RE := RE_TA_LU; - - elsif U_Type = RTE (RE_Long_Long_Unsigned) then - Lib_RE := RE_TA_LLU; + elsif U_Type = RTE (RE_Unsigned_64) then + Lib_RE := RE_TA_U64; elsif Is_RTE (U_Type, RE_Unbounded_String) then Lib_RE := RE_TA_String; @@ -10176,37 +10164,31 @@ package body Exp_Dist is -- Integer types (walk back to the base type) - elsif U_Type = Etype (Standard_Short_Short_Integer) then - Lib_RE := RE_TC_SSI; - - elsif U_Type = Etype (Standard_Short_Integer) then - Lib_RE := RE_TC_SI; + elsif U_Type = RTE (RE_Integer_8) then + Lib_RE := RE_TC_I8; - elsif U_Type = Etype (Standard_Integer) then - Lib_RE := RE_TC_I; + elsif U_Type = RTE (RE_Integer_16) then + Lib_RE := RE_TC_I16; - elsif U_Type = Etype (Standard_Long_Integer) then - Lib_RE := RE_TC_LI; + elsif U_Type = RTE (RE_Integer_32) then + Lib_RE := RE_TC_I32; - elsif U_Type = Etype (Standard_Long_Long_Integer) then - Lib_RE := RE_TC_LLI; + elsif U_Type = RTE (RE_Integer_64) then + Lib_RE := RE_TC_I64; -- Unsigned integer types - elsif U_Type = RTE (RE_Short_Short_Unsigned) then - Lib_RE := RE_TC_SSU; + elsif U_Type = RTE (RE_Unsigned_8) then + Lib_RE := RE_TC_U8; - elsif U_Type = RTE (RE_Short_Unsigned) then - Lib_RE := RE_TC_SU; + elsif U_Type = RTE (RE_Unsigned_16) then + Lib_RE := RE_TC_U16; - elsif U_Type = RTE (RE_Unsigned) then - Lib_RE := RE_TC_U; + elsif U_Type = RTE (RE_Unsigned_32) then + Lib_RE := RE_TC_U32; - elsif U_Type = RTE (RE_Long_Unsigned) then - Lib_RE := RE_TC_LU; - - elsif U_Type = RTE (RE_Long_Long_Unsigned) then - Lib_RE := RE_TC_LLU; + elsif U_Type = RTE (RE_Unsigned_64) then + Lib_RE := RE_TC_U64; elsif Is_RTE (U_Type, RE_Unbounded_String) then Lib_RE := RE_TC_String; @@ -10339,7 +10321,7 @@ package body Exp_Dist is begin Append_To (Parameter_List, Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc), + Name => New_Occurrence_Of (RTE (RE_TA_I32), Loc), Parameter_Associations => New_List (Expr_Node))); end Add_Long_Parameter; @@ -10584,7 +10566,7 @@ package body Exp_Dist is Make_Function_Call (Loc, Name => New_Occurrence_Of - (RTE (RE_TA_LI), Loc), + (RTE (RE_TA_I32), Loc), Parameter_Associations => New_List ( Make_Integer_Literal @@ -10795,7 +10777,7 @@ package body Exp_Dist is Inner_TypeCode := Make_Constructed_TypeCode (RTE (RE_TC_Array), New_List ( Build_To_Any_Call ( - OK_Convert_To (RTE (RE_Long_Unsigned), + OK_Convert_To (RTE (RE_Unsigned_32), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Length, @@ -10821,7 +10803,7 @@ package body Exp_Dist is Inner_TypeCode := Make_Constructed_TypeCode (RTE (RE_TC_Sequence), New_List ( Build_To_Any_Call ( - OK_Convert_To (RTE (RE_Long_Unsigned), + OK_Convert_To (RTE (RE_Unsigned_32), Make_Integer_Literal (Loc, 0)), Decls), Build_To_Any_Call (Inner_TypeCode, Decls))); @@ -10867,37 +10849,31 @@ package body Exp_Dist is begin if Is_Unsigned_Type (Typ) then - if P_Size <= Standard_Short_Short_Integer_Size then - return RTE (RE_Short_Short_Unsigned); + if P_Size <= 8 then + return RTE (RE_Unsigned_8); - elsif P_Size <= Standard_Short_Integer_Size then - return RTE (RE_Short_Unsigned); + elsif P_Size <= 16 then + return RTE (RE_Unsigned_16); - elsif P_Size <= Standard_Integer_Size then - return RTE (RE_Unsigned); - - elsif P_Size <= Standard_Long_Integer_Size then - return RTE (RE_Long_Unsigned); + elsif P_Size <= 32 then + return RTE (RE_Unsigned_32); else - return RTE (RE_Long_Long_Unsigned); + return RTE (RE_Unsigned_64); end if; elsif Is_Integer_Type (Typ) then - if P_Size <= Standard_Short_Short_Integer_Size then - return Standard_Short_Short_Integer; + if P_Size <= 8 then + return RTE (RE_Integer_8); elsif P_Size <= Standard_Short_Integer_Size then - return Standard_Short_Integer; + return RTE (RE_Integer_16); elsif P_Size <= Standard_Integer_Size then - return Standard_Integer; - - elsif P_Size <= Standard_Long_Integer_Size then - return Standard_Long_Integer; + return RTE (RE_Integer_32); else - return Standard_Long_Long_Integer; + return RTE (RE_Integer_64); end if; elsif Is_Floating_Point_Type (Typ) then @@ -11086,7 +11062,7 @@ package body Exp_Dist is Make_Object_Declaration (Loc, Defining_Identifier => Inner_Counter, Object_Definition => - New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc), + New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), Expression => Make_Integer_Literal (Loc, 0))); end if; @@ -11097,7 +11073,7 @@ package body Exp_Dist is Attribute_Name => Name_Length, Expressions => New_List (Make_Integer_Literal (Loc, Depth))); - Set_Etype (Length_Node, RTE (RE_Long_Unsigned)); + Set_Etype (Length_Node, RTE (RE_Unsigned_32)); Add_Process_Element (Dimen_Stmts, Datum => Length_Node, diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index 382f77a02cb..49b96a8d03e 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,7 @@ package Exp_Dist is PCS_Version_Number : constant array (PCS_Names) of Int := (Name_No_DSA => 1, Name_GARLIC_DSA => 1, - Name_PolyORB_DSA => 4); + Name_PolyORB_DSA => 5); -- PCS interface version. This is used to check for consistency between the -- compiler used to generate distribution stubs and the PCS implementation. -- It must be incremented whenever a change is made to the generated code diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 9220837ed9b..1be16c1d2d5 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3568,9 +3568,12 @@ package body Exp_Util is function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is begin return VM_Target /= No_VM - and then Nkind (N) = N_Identifier - and then Present (Renamed_Object (Entity (N))) - and then Nkind (Renamed_Object (Entity (N))) = N_Slice; + and then (Nkind (N) = N_Slice + or else + (Nkind (N) = N_Identifier + and then Present (Renamed_Object (Entity (N))) + and then Nkind (Renamed_Object (Entity (N))) + = N_Slice)); end Is_VM_By_Copy_Actual; -------------------- diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index af994c1decd..fe89cb1b375 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -2256,31 +2256,33 @@ ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_atag.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_dist.adb ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hlo.ads \ - ada/hostparm.ads ada/inline.ads ada/inline.adb ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem.adb \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \ + ada/erroutc.ads ada/erroutc.adb ada/exp_atag.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_dist.adb ada/exp_strm.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads \ + ada/inline.ads ada/inline.adb ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads \ + ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads \ + ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dist.ads \ + ada/sem_eval.ads ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -2872,14 +2874,14 @@ ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ ada/sem_ch9.ads ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/instpar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3329,13 +3331,13 @@ ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/restrict.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \ - ada/erroutc.ads ada/erroutc.adb ada/fname.ads ada/fname-uf.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/atree.adb ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/err_vars.ads ada/errout.ads \ + ada/errout.adb ada/erroutc.ads ada/erroutc.adb ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/scans.ads \ ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index dfa085bdf31..fa153f6de92 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -529,6 +529,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) s-vxwext.adb<s-vxwext-kernel-smp.adb \ system.ads<system-vxworks-ppc-kernel.ads + EH_MECHANISM=-gcc EXTRA_GNATRTL_TASKING_OBJS=affinity.o else LIBGNAT_TARGET_PAIRS += \ @@ -536,6 +537,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) s-tpopsp.adb<s-tpopsp-vxworks.adb ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),) + EH_MECHANISM=-gcc LIBGNAT_TARGET_PAIRS += \ s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel.adb \ @@ -1072,7 +1074,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) g-bytswa.adb<g-bytswa-x86.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ - s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ + s-tpopsp.adb<s-tpopsp-tls.adb \ g-sercom.adb<g-sercom-linux.adb ifeq ($(strip $(filter-out marte,$(THREAD_KIND))),) @@ -1383,7 +1385,7 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),) endif THREADSLIB = -lpthreads - + EH_MECHANISM=-gcc TOOLS_TARGET_PAIRS = \ mlib-tgt-specific.adb<mlib-tgt-specific-aix.adb \ indepsw.adb<indepsw-aix.adb @@ -1800,7 +1802,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),) s-intman.adb<s-intman-posix.adb \ s-linux.ads<s-linux.ads \ s-osinte.adb<s-osinte-posix.adb \ - s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ + s-tpopsp.adb<s-tpopsp-tls.adb \ g-sercom.adb<g-sercom-linux.adb \ $(ATOMICS_TARGET_PAIRS) @@ -1898,7 +1900,7 @@ ifeq ($(strip $(filter-out sparc% linux%,$(arch) $(osys))),) s-tasinf.ads<s-tasinf-linux.ads \ s-tasinf.adb<s-tasinf-linux.adb \ s-taspri.ads<s-taspri-posix-noaltstack.ads \ - s-tpopsp.adb<s-tpopsp-posix-foreign.adb + s-tpopsp.adb<s-tpopsp-tls.adb LIBGNAT_TARGET_PAIRS_32 = \ g-trasym.ads<g-trasym-unimplemented.ads \ @@ -2002,7 +2004,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) s-taprop.adb<s-taprop-linux.adb \ s-tasinf.ads<s-tasinf-linux.ads \ s-tasinf.adb<s-tasinf-linux.adb \ - s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ + s-tpopsp.adb<s-tpopsp-tls.adb \ s-taspri.ads<s-taspri-posix-noaltstack.ads \ g-sercom.adb<g-sercom-linux.adb \ system.ads<system-linux-ia64.ads \ @@ -2094,7 +2096,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) s-taprop.adb<s-taprop-linux.adb \ s-tasinf.ads<s-tasinf-linux.ads \ s-tasinf.adb<s-tasinf-linux.adb \ - s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ + s-tpopsp.adb<s-tpopsp-tls.adb \ s-taspri.ads<s-taspri-posix.ads \ g-sercom.adb<g-sercom-linux.adb \ system.ads<system-linux-x86_64.ads \ diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 623b188ed81..1f0ce8b5758 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -470,7 +470,7 @@ procedure GNATCmd is end if; Main := Project_Tree.Shared.String_Elements.Table - (Main).Next; + (Main).Next; end loop; if Proj.Project.Library then @@ -1241,6 +1241,7 @@ procedure GNATCmd is Libraries_Present : in out Boolean) is pragma Unreferenced (Tree); + Path_Option : constant String_Access := MLib.Linker_Library_Path_Option; @@ -2307,7 +2308,8 @@ begin Attribute_Or_Array_Name => Name_Local_Config_File, In_Package => Pkg, - Shared => Project_Tree.Shared); + Shared => + Project_Tree.Shared); end if; if Variable /= Nil_Variable_Value diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index f23291076ec..73113aebf7e 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -36,12 +36,13 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; package Makeutl is type Fail_Proc is access procedure (S : String); + Do_Fail : Fail_Proc := Osint.Fail'Access; -- Failing procedure called from procedure Test_If_Relative_Path below. May -- be redirected. Project_Tree : constant Project_Tree_Ref := - new Project_Tree_Data (Is_Root_Tree => True); + new Project_Tree_Data (Is_Root_Tree => True); -- The project tree Source_Info_Option : constant String := "--source-info="; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index af988ba78d3..9ac12e74061 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -1304,8 +1304,8 @@ package body MLib.Prj is Lib_Dirpath := new String'(Get_Name_String (For_Project.Library_Dir.Display_Name)); - Lib_Filename := new String' - (Get_Name_String (For_Project.Library_Name)); + Lib_Filename := + new String'(Get_Name_String (For_Project.Library_Name)); case For_Project.Library_Kind is when Static => diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 3c39e6190a4..c9b526340eb 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -102,8 +102,8 @@ package body Prj.Conf is -- Raises exception Invalid_Config with given message procedure Apply_Config_File - (Config_File : Prj.Project_Id; - Project_Tree : Prj.Project_Tree_Ref); + (Config_File : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref); -- Apply the configuration file settings to all the projects in the -- project tree. The Project_Tree must have been parsed first, and -- processed through the first phase so that all its projects are known. @@ -174,8 +174,8 @@ package body Prj.Conf is String_Element_Table.Increment_Last (Shared.String_Elements); - New_List := String_Element_Table.Last - (Shared.String_Elements); + New_List := + String_Element_Table.Last (Shared.String_Elements); -- Value of attribute is new list @@ -183,11 +183,10 @@ package body Prj.Conf is Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; loop - -- Get each element of configuration list Conf_Elem := Shared.String_Elements.Table (Conf_List); - New_Elem := Conf_Elem; + New_Elem := Conf_Elem; Conf_List := Conf_Elem.Next; if Conf_List = Nil_String then @@ -240,9 +239,9 @@ package body Prj.Conf is User_Decl.Arrays := Array_Table.Last (Shared.Arrays); Shared.Arrays.Table (User_Decl.Arrays) := User_Array; - else - -- Otherwise, check each array element + -- Otherwise, check each array element + else Conf_Array_Elem_Id := Conf_Array.Value; while Conf_Array_Elem_Id /= No_Array_Element loop Conf_Array_Elem := @@ -256,9 +255,8 @@ package body Prj.Conf is User_Array_Elem_Id := User_Array_Elem.Next; end loop; - -- If the array element does not exist in the user array, - -- insert a shallow copy of the conf array element in the - -- user array. + -- If the array element doesn't exist in the user array, insert + -- a shallow copy of the conf array element in the user array. if User_Array_Elem_Id = No_Array_Element then Array_Element_Table.Increment_Last (Shared.Array_Elements); @@ -270,8 +268,8 @@ package body Prj.Conf is User_Array_Elem; Shared.Arrays.Table (User_Array_Id) := User_Array; - -- Otherwise, if the value is a string list, prepend the - -- user array element with the conf array element value. + -- Otherwise, if the value is a string list, prepend the conf + -- array element value to the array element. elsif Conf_Array_Elem.Value.Kind = List then Conf_List := Conf_Array_Elem.Value.Values; @@ -351,12 +349,13 @@ package body Prj.Conf is Index : String := ""; Pkg : Project_Node_Id := Empty_Node) is - Attr : Project_Node_Id; + Attr : Project_Node_Id; pragma Unreferenced (Attr); Expr : Name_Id := No_Name; Val : Name_Id := No_Name; Parent : Project_Node_Id := Config_File; + begin if Index /= "" then Name_Len := Index'Length; @@ -456,10 +455,11 @@ package body Prj.Conf is ----------------------- procedure Apply_Config_File - (Config_File : Prj.Project_Id; - Project_Tree : Prj.Project_Tree_Ref) + (Config_File : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref) is Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; + Conf_Decl : constant Declarations := Config_File.Decl; Conf_Pack_Id : Package_Id; Conf_Pack : Package_Element; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index b5102c74f99..d58f87e540b 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -208,6 +208,7 @@ package body Prj.Env is Dummy : in out Boolean) is pragma Unreferenced (Dummy, In_Tree); + Path : constant Path_Name_Type := Get_Object_Directory (Project, @@ -509,6 +510,7 @@ package body Prj.Env is State : in out Integer) is pragma Unreferenced (State, In_Tree); + Lang : constant Language_Ptr := Get_Language_From_Name (Project, "ada"); Naming : Lang_Naming_Data; @@ -821,6 +823,7 @@ package body Prj.Env is State : in out Integer) is pragma Unreferenced (State); + Source : Source_Id; Suffix : File_Name_Type; Iter : Source_Iterator; @@ -1224,6 +1227,7 @@ package body Prj.Env is Dummy : in out Integer) is pragma Unreferenced (Dummy, Tree); + begin -- ??? Set_Ada_Paths has a different behavior for library project -- files, should we have the same ? @@ -1268,6 +1272,7 @@ package body Prj.Env is Dummy : in out Integer) is pragma Unreferenced (Dummy); + Current : String_List_Id := Prj.Source_Dirs; The_String : String_Element; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index bc6c8ec9919..0362277df5c 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -150,20 +150,9 @@ package body Prj.Nmsc is -- information which is only useful while processing the project, and can -- be discarded as soon as we have finished processing the project - package Files_Htable is new GNAT.Dynamic_HTables.Simple_HTable - (Header_Num => Header_Num, - Element => Source_Id, - No_Element => No_Source, - Key => File_Name_Type, - Hash => Hash, - Equal => "="); - -- Mapping from base file names to Source_Id (containing full info about - -- the source). - type Tree_Processing_Data is record Tree : Project_Tree_Ref; Node_Tree : Prj.Tree.Project_Node_Tree_Ref; - File_To_Source : Files_Htable.Instance; Flags : Prj.Processing_Flags; end record; -- Temporary data which is needed while parsing a project. It does not need @@ -673,7 +662,8 @@ package body Prj.Nmsc is Source := Prev_Unit.File_Names (Kind); else - Source := Files_Htable.Get (Data.File_To_Source, File_Name); + Source := Source_Files_Htable.Get + (Data.Tree.Source_Files_HT, File_Name); if Source /= No_Source and then Source.Index = Index @@ -900,8 +890,6 @@ package body Prj.Nmsc is Data.Tree.Replaced_Source_Number := Data.Tree.Replaced_Source_Number - 1; end if; - - Files_Htable.Set (Data.File_To_Source, File_Name, Id); end Add_Source; ------------------------------ @@ -932,7 +920,6 @@ package body Prj.Nmsc is Data : Tree_Processing_Data := (Tree => Tree, Node_Tree => Node_Tree, - File_To_Source => Files_Htable.Nil, Flags => Flags); Project_Files : constant Prj.Variable_Value := @@ -6366,7 +6353,6 @@ package body Prj.Nmsc is Source : Source_Id; Iter : Source_Iterator; Found : Boolean := False; - Path : Path_Information; begin Iter := For_Each_Source (Data.Tree, Project.Project); @@ -6374,23 +6360,45 @@ package body Prj.Nmsc is Source := Prj.Element (Iter); exit when Source = No_Source; + -- If the full source path is unknown for this source_id, there + -- could be several reasons: + -- * we simply did not find the file itself, this is an error + -- * we have a multi-unit source file. Another Source_Id from + -- the same file has received the full path, so we need to + -- propagate it. + if Source.Naming_Exception and then Source.Path = No_Path_Information then if Source.Unit /= No_Unit_Index then Found := False; - -- For multi-unit source files, source_id gets duplicated - -- once for every unit. Only the first source_id got its - -- full path set. + if Source.Index /= 0 then -- Only multi-unit files + declare + S : Source_Id := + Source_Files_Htable.Get + (Data.Tree.Source_Files_HT, Source.File); + begin + while S /= null loop + if S.Path /= No_Path_Information then + Source.Path := S.Path; + Found := True; - if Source.Index /= 0 then - Path := Files_Htable.Get - (Data.File_To_Source, Source.File).Path; + if Current_Verbosity = High then + Debug_Output + ("Setting full path for " + & Get_Name_String (Source.File) + & " at" & Source.Index'Img + & " to " + & Get_Name_String (Source.Path.Name)); + end if; - if Path /= No_Path_Information then - Found := True; - end if; + exit; + end if; + + S := S.Next_With_File_Name; + end loop; + end; end if; if not Found then @@ -6400,21 +6408,6 @@ package body Prj.Nmsc is (Data.Flags, Data.Flags.Missing_Source_Files, "source file %% for unit %% not found", No_Location, Project.Project); - - else - Source.Path := Path; - - if Current_Verbosity = High then - Debug_Indent; - - if Source.Path /= No_Path_Information then - Write_Line ("Setting full path for " - & Get_Name_String (Source.File) - & " at" & Source.Index'Img - & " to " - & Get_Name_String (Path.Name)); - end if; - end if; end if; end if; @@ -6472,7 +6465,6 @@ package body Prj.Nmsc is Flags : Prj.Processing_Flags) is begin - Files_Htable.Reset (Data.File_To_Source); Data.Tree := Tree; Data.Node_Tree := Node_Tree; Data.Flags := Flags; @@ -6483,8 +6475,9 @@ package body Prj.Nmsc is ---------- procedure Free (Data : in out Tree_Processing_Data) is + pragma Unreferenced (Data); begin - Files_Htable.Reset (Data.File_To_Source); + null; end Free; ---------------- @@ -6666,6 +6659,7 @@ package body Prj.Nmsc is then Debug_Output ("Override kind for " & Get_Name_String (Source.File) + & " idx=" & Source.Index'Img & " kind=" & Source.Kind'Img); end if; @@ -6736,12 +6730,20 @@ package body Prj.Nmsc is Check_Name := True; else + -- Set the full path for the source_id (which might have been + -- created when parsing the naming exceptions, and therefore + -- might not have the full path). + -- We only set this for this source_id, but not for other + -- source_id in the same file (case of multi-unit source files) + -- For the latter, they will be set in Find_Sources when we + -- check that all source_id have known full paths. + -- Doing this later saves one htable lookup per file in the + -- common case where the user is not using multi-unit files. + Name_Loc.Source.Path := (Path, Display_Path); Source_Paths_Htable.Set - (Data.Tree.Source_Paths_HT, - Path, - Name_Loc.Source); + (Data.Tree.Source_Paths_HT, Path, Name_Loc.Source); -- Check if this is a subunit @@ -6755,9 +6757,6 @@ package body Prj.Nmsc is Override_Kind (Name_Loc.Source, Sep); end if; end if; - - Files_Htable.Set - (Data.File_To_Source, File_Name, Name_Loc.Source); end if; end if; end if; @@ -7427,7 +7426,7 @@ package body Prj.Nmsc is procedure Get_Sources_From_Source_Info; -- Get the source information from the tables that were created when a - -- source info fie was read. + -- source info file was read. --------------------------- -- Check_Missing_Sources -- @@ -7720,7 +7719,6 @@ package body Prj.Nmsc is Id.Language := Lang_Id; Id.Kind := Src.Kind; - Id.Index := Src.Index; Id.Path := @@ -7783,8 +7781,6 @@ package body Prj.Nmsc is Id.Next_In_Lang := Id.Language.First_Source; Id.Language.First_Source := Id; - Files_Htable.Set (Data.File_To_Source, Id.File, Id); - Next (Iter); end loop; end Get_Sources_From_Source_Info; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 15491996cad..366dfced32d 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -154,6 +154,7 @@ package body Prj.Proc is -- as processed, call itself recursively for all imported projects and a -- extended project, if any. Then process the declarative items of the -- project. + -- -- Is_Root_Project should be true only for the project that the user -- explicitly loaded. In the context of aggregate projects, only that -- project is allowed to modify the environment that will be used to load @@ -268,8 +269,9 @@ package body Prj.Proc is (Next => Decl.Attributes, Name => Attribute_Name_Of (The_Attribute), Value => New_Attribute); - Decl.Attributes := Variable_Element_Table.Last - (Shared.Variable_Elements); + Decl.Attributes := + Variable_Element_Table.Last + (Shared.Variable_Elements); end; end if; @@ -610,16 +612,17 @@ package body Prj.Proc is -- This literal string list is the first term in a -- string list expression - Result.Values := String_Element_Table.Last - (Shared.String_Elements); + Result.Values := + String_Element_Table.Last + (Shared.String_Elements); else Shared.String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); end if; - Last := String_Element_Table.Last - (Shared.String_Elements); + Last := + String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Last) := (Value => Value.Value, @@ -706,8 +709,8 @@ package body Prj.Proc is The_Name := Name_Of (Term_Package, From_Project_Node_Tree); - The_Package := The_Project.Decl.Packages; + The_Package := The_Project.Decl.Packages; while The_Package /= No_Package and then Shared.Packages.Table (The_Package).Name /= The_Name @@ -760,10 +763,11 @@ package body Prj.Proc is while The_Variable_Id /= No_Variable and then Shared.Variable_Elements.Table - (The_Variable_Id).Name /= The_Name + (The_Variable_Id).Name /= The_Name loop - The_Variable_Id := Shared.Variable_Elements.Table - (The_Variable_Id).Next; + The_Variable_Id := + Shared.Variable_Elements.Table + (The_Variable_Id).Next; end loop; end if; @@ -808,15 +812,15 @@ package body Prj.Proc is begin if The_Package /= No_Package then - The_Array := Shared.Packages.Table - (The_Package).Decl.Arrays; + The_Array := + Shared.Packages.Table (The_Package).Decl.Arrays; else The_Array := The_Project.Decl.Arrays; end if; while The_Array /= No_Array and then Shared.Arrays.Table (The_Array).Name /= - The_Name + The_Name loop The_Array := Shared.Arrays.Table (The_Array).Next; end loop; @@ -835,19 +839,18 @@ package body Prj.Proc is (The_Element).Index /= Array_Index loop The_Element := - Shared.Array_Elements.Table - (The_Element).Next; + Shared.Array_Elements.Table (The_Element).Next; end loop; end if; if The_Element /= No_Array_Element then - The_Variable := Shared.Array_Elements.Table - (The_Element).Value; + The_Variable := + Shared.Array_Elements.Table (The_Element).Value; else if Expression_Kind_Of - (The_Current_Term, From_Project_Node_Tree) = + (The_Current_Term, From_Project_Node_Tree) = List then The_Variable := @@ -1085,12 +1088,13 @@ package body Prj.Proc is end if; if not Done then - -- Count the number of string + + -- Count the number of strings declare Saved : constant Positive := First; - begin + begin Nmb := 1; loop Lst := @@ -1479,11 +1483,13 @@ package body Prj.Proc is Error_Msg (Env.Flags, "value %% is illegal for typed string %%", Loc, Project); + when Warning => Error_Msg (Env.Flags, "?value %% is illegal for typed string %%", Loc, Project); Reset_Value := True; + when Silent => Reset_Value := True; end case; diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index 42f08ab3a64..deec6769e24 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -1025,7 +1025,7 @@ package body Prj.Util is function Value_Of (Variable_Name : Name_Id; In_Variables : Variable_Id; - Shared : Shared_Project_Tree_Data_Access) return Variable_Value + Shared : Shared_Project_Tree_Data_Access) return Variable_Value is Current : Variable_Id; The_Variable : Variable; diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads index 7c94a3c8572..cd2629db5c6 100644 --- a/gcc/ada/prj-util.ads +++ b/gcc/ada/prj-util.ads @@ -141,7 +141,7 @@ package Prj.Util is function Value_Of (Variable_Name : Name_Id; In_Variables : Variable_Id; - Shared : Shared_Project_Tree_Data_Access) return Variable_Value; + Shared : Shared_Project_Tree_Data_Access) return Variable_Value; -- Returns a specified variable in a variable list. Returns null if -- In_Variables is null or if Variable_Name is not the name of a -- variable in In_Variables. Caller must ensure that Name is lower case. diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 58160e61d48..86a864266b4 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -413,7 +413,8 @@ package body Prj is Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil; procedure Recursive_Check - (Project : Project_Id; Tree : Project_Tree_Ref); + (Project : Project_Id; + Tree : Project_Tree_Ref); -- Check if a project has already been seen. If not seen, mark it as -- Seen, Call Action, and check all its imported projects. @@ -422,7 +423,8 @@ package body Prj is --------------------- procedure Recursive_Check - (Project : Project_Id; Tree : Project_Tree_Ref) + (Project : Project_Id; + Tree : Project_Tree_Ref) is List : Project_List; Agg : Aggregated_Project_List; @@ -937,23 +939,25 @@ package body Prj is -- Visible tables if Tree.Is_Root_Tree then + -- We cannot use 'Access here: -- "illegal attribute for discriminant-dependent component" -- However, we know this is valid since Shared and Shared_Data have -- the same lifetime and will always exist concurrently. + Tree.Shared := Tree.Shared_Data'Unrestricted_Access; - Name_List_Table.Init (Tree.Shared.Name_Lists); - Number_List_Table.Init (Tree.Shared.Number_Lists); - String_Element_Table.Init (Tree.Shared.String_Elements); - Variable_Element_Table.Init (Tree.Shared.Variable_Elements); - Array_Element_Table.Init (Tree.Shared.Array_Elements); - Array_Table.Init (Tree.Shared.Arrays); - Package_Table.Init (Tree.Shared.Packages); + Name_List_Table.Init (Tree.Shared.Name_Lists); + Number_List_Table.Init (Tree.Shared.Number_Lists); + String_Element_Table.Init (Tree.Shared.String_Elements); + Variable_Element_Table.Init (Tree.Shared.Variable_Elements); + Array_Element_Table.Init (Tree.Shared.Array_Elements); + Array_Table.Init (Tree.Shared.Arrays); + Package_Table.Init (Tree.Shared.Packages); end if; - Source_Paths_Htable.Reset (Tree.Source_Paths_HT); - Source_Files_Htable.Reset (Tree.Source_Files_HT); - Replaced_Source_HTable.Reset (Tree.Replaced_Sources); + Source_Paths_Htable.Reset (Tree.Source_Paths_HT); + Source_Files_Htable.Reset (Tree.Source_Files_HT); + Replaced_Source_HTable.Reset (Tree.Replaced_Sources); Tree.Replaced_Source_Number := 0; @@ -962,7 +966,7 @@ package body Prj is -- Private part table - Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); Tree.Private_Part.Current_Source_Path_File := No_Path; Tree.Private_Part.Current_Object_Path_File := No_Path; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 9928bd3b205..670e690ec72 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1442,6 +1442,8 @@ package Prj is Source_Paths_HT : Source_Paths_Htable.Instance; -- Full path to Source_Id + -- ??? What is behavior for multi-unit source files, where there are + -- several source_id per file ? Source_Info_File_Name : String_Access := null; -- The name of the source info file, if specified by the builder diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index e4fb3830ae7..29257dc4c25 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -639,6 +639,9 @@ package Rtsfind is RE_Current_Task, -- Ada.Task_Identification RO_AT_Task_Id, -- Ada.Task_Identification + RE_Integer_8, -- Interfaces + RE_Integer_16, -- Interfaces + RE_Integer_32, -- Interfaces RE_Integer_64, -- Interfaces RE_Unsigned_8, -- Interfaces RE_Unsigned_16, -- Interfaces @@ -1210,19 +1213,17 @@ package Rtsfind is RE_FA_B, -- System.Partition_Interface RE_FA_C, -- System.Partition_Interface RE_FA_F, -- System.Partition_Interface - RE_FA_I, -- System.Partition_Interface + RE_FA_I8, -- System.Partition_Interface + RE_FA_I16, -- System.Partition_Interface + RE_FA_I32, -- System.Partition_Interface + RE_FA_I64, -- System.Partition_Interface RE_FA_LF, -- System.Partition_Interface - RE_FA_LI, -- System.Partition_Interface RE_FA_LLF, -- System.Partition_Interface - RE_FA_LLI, -- System.Partition_Interface - RE_FA_LLU, -- System.Partition_Interface - RE_FA_LU, -- System.Partition_Interface RE_FA_SF, -- System.Partition_Interface - RE_FA_SI, -- System.Partition_Interface - RE_FA_SSI, -- System.Partition_Interface - RE_FA_SSU, -- System.Partition_Interface - RE_FA_SU, -- System.Partition_Interface - RE_FA_U, -- System.Partition_Interface + RE_FA_U8, -- System.Partition_Interface + RE_FA_U16, -- System.Partition_Interface + RE_FA_U32, -- System.Partition_Interface + RE_FA_U64, -- System.Partition_Interface RE_FA_WC, -- System.Partition_Interface RE_FA_WWC, -- System.Partition_Interface RE_FA_String, -- System.Partition_Interface @@ -1232,19 +1233,17 @@ package Rtsfind is RE_TA_B, -- System.Partition_Interface RE_TA_C, -- System.Partition_Interface RE_TA_F, -- System.Partition_Interface - RE_TA_I, -- System.Partition_Interface + RE_TA_I8, -- System.Partition_Interface + RE_TA_I16, -- System.Partition_Interface + RE_TA_I32, -- System.Partition_Interface + RE_TA_I64, -- System.Partition_Interface RE_TA_LF, -- System.Partition_Interface - RE_TA_LI, -- System.Partition_Interface RE_TA_LLF, -- System.Partition_Interface - RE_TA_LLI, -- System.Partition_Interface - RE_TA_LLU, -- System.Partition_Interface - RE_TA_LU, -- System.Partition_Interface RE_TA_SF, -- System.Partition_Interface - RE_TA_SI, -- System.Partition_Interface - RE_TA_SSI, -- System.Partition_Interface - RE_TA_SSU, -- System.Partition_Interface - RE_TA_SU, -- System.Partition_Interface - RE_TA_U, -- System.Partition_Interface + RE_TA_U8, -- System.Partition_Interface + RE_TA_U16, -- System.Partition_Interface + RE_TA_U32, -- System.Partition_Interface + RE_TA_U64, -- System.Partition_Interface RE_TA_WC, -- System.Partition_Interface RE_TA_WWC, -- System.Partition_Interface RE_TA_String, -- System.Partition_Interface @@ -1260,19 +1259,17 @@ package Rtsfind is RE_TC_B, -- System.Partition_Interface RE_TC_C, -- System.Partition_Interface RE_TC_F, -- System.Partition_Interface - RE_TC_I, -- System.Partition_Interface + RE_TC_I8, -- System.Partition_Interface + RE_TC_I16, -- System.Partition_Interface + RE_TC_I32, -- System.Partition_Interface + RE_TC_I64, -- System.Partition_Interface RE_TC_LF, -- System.Partition_Interface - RE_TC_LI, -- System.Partition_Interface RE_TC_LLF, -- System.Partition_Interface - RE_TC_LLI, -- System.Partition_Interface - RE_TC_LLU, -- System.Partition_Interface - RE_TC_LU, -- System.Partition_Interface RE_TC_SF, -- System.Partition_Interface - RE_TC_SI, -- System.Partition_Interface - RE_TC_SSI, -- System.Partition_Interface - RE_TC_SSU, -- System.Partition_Interface - RE_TC_SU, -- System.Partition_Interface - RE_TC_U, -- System.Partition_Interface + RE_TC_U8, -- System.Partition_Interface + RE_TC_U16, -- System.Partition_Interface + RE_TC_U32, -- System.Partition_Interface + RE_TC_U64, -- System.Partition_Interface RE_TC_Void, -- System.Partition_Interface RE_TC_Opaque, -- System.Partition_Interface RE_TC_WC, -- System.Partition_Interface @@ -1819,6 +1816,9 @@ package Rtsfind is RE_Current_Task => Ada_Task_Identification, RO_AT_Task_Id => Ada_Task_Identification, + RE_Integer_8 => Interfaces, + RE_Integer_16 => Interfaces, + RE_Integer_32 => Interfaces, RE_Integer_64 => Interfaces, RE_Unsigned_8 => Interfaces, RE_Unsigned_16 => Interfaces, @@ -2381,19 +2381,17 @@ package Rtsfind is RE_FA_B => System_Partition_Interface, RE_FA_C => System_Partition_Interface, RE_FA_F => System_Partition_Interface, - RE_FA_I => System_Partition_Interface, + RE_FA_I8 => System_Partition_Interface, + RE_FA_I16 => System_Partition_Interface, + RE_FA_I32 => System_Partition_Interface, + RE_FA_I64 => System_Partition_Interface, RE_FA_LF => System_Partition_Interface, - RE_FA_LI => System_Partition_Interface, RE_FA_LLF => System_Partition_Interface, - RE_FA_LLI => System_Partition_Interface, - RE_FA_LLU => System_Partition_Interface, - RE_FA_LU => System_Partition_Interface, RE_FA_SF => System_Partition_Interface, - RE_FA_SI => System_Partition_Interface, - RE_FA_SSI => System_Partition_Interface, - RE_FA_SSU => System_Partition_Interface, - RE_FA_SU => System_Partition_Interface, - RE_FA_U => System_Partition_Interface, + RE_FA_U8 => System_Partition_Interface, + RE_FA_U16 => System_Partition_Interface, + RE_FA_U32 => System_Partition_Interface, + RE_FA_U64 => System_Partition_Interface, RE_FA_WC => System_Partition_Interface, RE_FA_WWC => System_Partition_Interface, RE_FA_String => System_Partition_Interface, @@ -2403,19 +2401,17 @@ package Rtsfind is RE_TA_B => System_Partition_Interface, RE_TA_C => System_Partition_Interface, RE_TA_F => System_Partition_Interface, - RE_TA_I => System_Partition_Interface, + RE_TA_I8 => System_Partition_Interface, + RE_TA_I16 => System_Partition_Interface, + RE_TA_I32 => System_Partition_Interface, + RE_TA_I64 => System_Partition_Interface, RE_TA_LF => System_Partition_Interface, - RE_TA_LI => System_Partition_Interface, RE_TA_LLF => System_Partition_Interface, - RE_TA_LLI => System_Partition_Interface, - RE_TA_LLU => System_Partition_Interface, - RE_TA_LU => System_Partition_Interface, RE_TA_SF => System_Partition_Interface, - RE_TA_SI => System_Partition_Interface, - RE_TA_SSI => System_Partition_Interface, - RE_TA_SSU => System_Partition_Interface, - RE_TA_SU => System_Partition_Interface, - RE_TA_U => System_Partition_Interface, + RE_TA_U8 => System_Partition_Interface, + RE_TA_U16 => System_Partition_Interface, + RE_TA_U32 => System_Partition_Interface, + RE_TA_U64 => System_Partition_Interface, RE_TA_WC => System_Partition_Interface, RE_TA_WWC => System_Partition_Interface, RE_TA_String => System_Partition_Interface, @@ -2431,19 +2427,17 @@ package Rtsfind is RE_TC_B => System_Partition_Interface, RE_TC_C => System_Partition_Interface, RE_TC_F => System_Partition_Interface, - RE_TC_I => System_Partition_Interface, + RE_TC_I8 => System_Partition_Interface, + RE_TC_I16 => System_Partition_Interface, + RE_TC_I32 => System_Partition_Interface, + RE_TC_I64 => System_Partition_Interface, RE_TC_LF => System_Partition_Interface, - RE_TC_LI => System_Partition_Interface, RE_TC_LLF => System_Partition_Interface, - RE_TC_LLI => System_Partition_Interface, - RE_TC_LLU => System_Partition_Interface, - RE_TC_LU => System_Partition_Interface, RE_TC_SF => System_Partition_Interface, - RE_TC_SI => System_Partition_Interface, - RE_TC_SSI => System_Partition_Interface, - RE_TC_SSU => System_Partition_Interface, - RE_TC_SU => System_Partition_Interface, - RE_TC_U => System_Partition_Interface, + RE_TC_U8 => System_Partition_Interface, + RE_TC_U16 => System_Partition_Interface, + RE_TC_U32 => System_Partition_Interface, + RE_TC_U64 => System_Partition_Interface, RE_TC_Void => System_Partition_Interface, RE_TC_Opaque => System_Partition_Interface, RE_TC_WC => System_Partition_Interface, diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index db6ac9ff571..8d46cbd98c1 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -81,9 +81,6 @@ package body System.Task_Primitives.Operations is -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_Id associated with a thread - Environment_Task_Id : Task_Id; -- A variable to hold Task_Id for the environment task diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index d05bb1cd2d4..705e8a51434 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -83,9 +83,6 @@ package body System.Task_Primitives.Operations is -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_Id associated with a thread - Environment_Task_Id : Task_Id; -- A variable to hold Task_Id for the environment task diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index cd23f16d9ca..cd6daca128f 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -77,9 +77,6 @@ package body System.Task_Primitives.Operations is -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_Id associated with a thread - Environment_Task_Id : Task_Id; -- A variable to hold Task_Id for the environment task diff --git a/gcc/ada/s-tpopsp-posix-foreign.adb b/gcc/ada/s-tpopsp-posix-foreign.adb index c987f6e27f3..485abc5c953 100644 --- a/gcc/ada/s-tpopsp-posix-foreign.adb +++ b/gcc/ada/s-tpopsp-posix-foreign.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,12 +32,12 @@ -- This is a POSIX version of this package where foreign threads are -- recognized. --- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and --- GNU/Linux threads use this version. - separate (System.Task_Primitives.Operations) package body Specific is + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/s-tpopsp-posix.adb b/gcc/ada/s-tpopsp-posix.adb index e7273a586fc..af068e0bc22 100644 --- a/gcc/ada/s-tpopsp-posix.adb +++ b/gcc/ada/s-tpopsp-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,6 +34,9 @@ separate (System.Task_Primitives.Operations) package body Specific is + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/s-tpopsp-tls.adb b/gcc/ada/s-tpopsp-tls.adb new file mode 100644 index 00000000000..a82f7f38d3e --- /dev/null +++ b/gcc/ada/s-tpopsp-tls.adb @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a version of this package using TLS and where foreign threads are +-- recognized. + +separate (System.Task_Primitives.Operations) +package body Specific is + + ATCB : aliased Task_Id := null; + pragma Thread_Local_Storage (ATCB); + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + begin + ATCB := Environment_Task; + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return ATCB /= null; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_Id) is + begin + ATCB := Self_Id; + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come from + -- recognized Ada tasks, and create an ATCB for the calling thread. + + -- The new ATCB will be "detached" from the normal Ada task master + -- hierarchy, much like the existing implicitly created signal-server + -- tasks. + + function Self return Task_Id is + Result : constant Task_Id := ATCB; + begin + if Result /= null then + return Result; + else + -- If the value is Null then it is a non-Ada task + + return Register_Foreign_Thread; + end if; + end Self; + +end Specific; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ac065414375..15689c33344 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2841,6 +2841,7 @@ package body Sem_Ch13 is Choice : Node_Id; Val : Uint; Err : Boolean := False; + -- Set True to avoid cascade errors and crashes on incorrect source code Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); @@ -2985,45 +2986,51 @@ package body Sem_Ch13 is else Analyze_And_Resolve (Choice, Enumtype); - - if Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - then - Error_Msg_N ("subtype name not allowed here", Choice); + if Error_Posted (Choice) then Err := True; - -- ??? should allow static subtype with zero/one entry + end if; - elsif Etype (Choice) = Base_Type (Enumtype) then - if not Is_Static_Expression (Choice) then - Flag_Non_Static_Expr - ("non-static expression used for choice!", Choice); + if not Err then + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Error_Msg_N ("subtype name not allowed here", Choice); Err := True; + -- ??? should allow static subtype with zero/one entry - else - Elit := Expr_Value_E (Choice); - - if Present (Enumeration_Rep_Expr (Elit)) then - Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit)); - Error_Msg_NE - ("representation for& previously given#", - Choice, Elit); + elsif Etype (Choice) = Base_Type (Enumtype) then + if not Is_Static_Expression (Choice) then + Flag_Non_Static_Expr + ("non-static expression used for choice!", Choice); Err := True; - end if; - Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); + else + Elit := Expr_Value_E (Choice); + + if Present (Enumeration_Rep_Expr (Elit)) then + Error_Msg_Sloc := + Sloc (Enumeration_Rep_Expr (Elit)); + Error_Msg_NE + ("representation for& previously given#", + Choice, Elit); + Err := True; + end if; - Expr := Expression (Assoc); - Val := Static_Integer (Expr); + Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); - if Val = No_Uint then - Err := True; + Expr := Expression (Assoc); + Val := Static_Integer (Expr); - elsif Val < Lo or else Hi < Val then - Error_Msg_N ("value outside permitted range", Expr); - Err := True; - end if; + if Val = No_Uint then + Err := True; + + elsif Val < Lo or else Hi < Val then + Error_Msg_N ("value outside permitted range", Expr); + Err := True; + end if; - Set_Enumeration_Rep (Elit, Val); + Set_Enumeration_Rep (Elit, Val); + end if; end if; end if; end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 633d975758e..62f4abd0f0a 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1516,8 +1516,8 @@ package body Sem_Ch7 is procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean; - -- Check whether an inherited subprogram is an operation of an untagged - -- derived type. + -- Check whether an inherited subprogram S is an operation of an + -- untagged derived type T. --------------------- -- Is_Primitive_Of -- diff --git a/gcc/ada/system-aix.ads b/gcc/ada/system-aix.ads index f76edfa2aa7..a24b1f08902 100644 --- a/gcc/ada/system-aix.ads +++ b/gcc/ada/system-aix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (AIX/PPC Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -149,7 +149,7 @@ private Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := True; -- Post GCC 4 only + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; end System; diff --git a/gcc/ada/system-aix64.ads b/gcc/ada/system-aix64.ads index c32125281da..8b2a4e91e47 100644 --- a/gcc/ada/system-aix64.ads +++ b/gcc/ada/system-aix64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (PPC/AIX64 Version) -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2011, 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 -- @@ -149,7 +149,7 @@ private Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := True; -- Post GCC 4 only + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; end System; |