diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 22 | ||||
| -rw-r--r-- | gcc/ada/Makefile.rtl | 6 | ||||
| -rw-r--r-- | gcc/ada/a-cfdlli.adb | 2291 | ||||
| -rw-r--r-- | gcc/ada/a-cfdlli.ads | 288 | ||||
| -rw-r--r-- | gcc/ada/a-cfhama.adb | 1558 | ||||
| -rw-r--r-- | gcc/ada/a-cfhama.ads | 259 | ||||
| -rw-r--r-- | gcc/ada/a-cfhase.adb | 2436 | ||||
| -rw-r--r-- | gcc/ada/a-cfhase.ads | 284 | ||||
| -rw-r--r-- | gcc/ada/a-cforma.adb | 1737 | ||||
| -rw-r--r-- | gcc/ada/a-cforma.ads | 252 | ||||
| -rw-r--r-- | gcc/ada/a-cforse.adb | 2924 | ||||
| -rw-r--r-- | gcc/ada/a-cforse.ads | 301 | ||||
| -rw-r--r-- | gcc/ada/a-cofove.adb | 2293 | ||||
| -rw-r--r-- | gcc/ada/a-cofove.ads | 396 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/errout.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/restrict.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/restrict.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 1 |
23 files changed, 15152 insertions, 40 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 51e6e20fcad..b50d02af143 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,7 +1,23 @@ -2011-08-02 Vincent Celier <celier@adacore.com> +2011-08-02 Yannick Moy <moy@adacore.com> + + * errout.adb, errout.ads (Check_Formal_Restriction): move procedure + from here... + * restrict.adb, restrict.ads (Check_Formal_Restriction): ...to here + * sem_aggr.adb, sem_ch5.adb, sem_util.adb: + Add with/use clauses to make Check_Formal_Restriction visible + +2011-08-02 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Check_Generic_Actuals): handle properly actual + in-parameters when type of the generic formal is private in the generic + spec and non-private in the body. + +2011-08-02 Claire Dross <dross@adacore.com> - * prj-nmsc.adb (Check_Library_Attributes): For virtual library project, - inherit library kind. + * a-cfdlli.adb, a-cfdlli.ads, a-cfhase.adb, a-cfhase.ads, a-cfhama.adb, + a-cfhama.ads, a-cforse.adb, a-cforse.ads, a-cforma.adb, a-cforma.ads, + a-cofove.adb, a-cofove.ads: New files implementing formal containers. + * impunit.adb, Makefile.rtl: Take new files into account. 2011-08-02 Robert Dewar <dewar@adacore.com> diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 78f585536bc..3617bea7b77 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -92,6 +92,11 @@ GNATRTL_NONTASKING_OBJS= \ a-cbdlli$(objext) \ a-cborma$(objext) \ a-cdlili$(objext) \ + a-cfhama$(objext) \ + a-cfhase$(objext) \ + a-cforse$(objext) \ + a-cfdlli$(objext) \ + a-cforma$(objext) \ a-cgaaso$(objext) \ a-cgarso$(objext) \ a-cgcaso$(objext) \ @@ -123,6 +128,7 @@ GNATRTL_NONTASKING_OBJS= \ a-contai$(objext) \ a-convec$(objext) \ a-cobove$(objext) \ + a-cofove$(objext) \ a-coorma$(objext) \ a-coormu$(objext) \ a-coorse$(objext) \ diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb new file mode 100644 index 00000000000..4f70f8174f6 --- /dev/null +++ b/gcc/ada/a-cfdlli.adb @@ -0,0 +1,2291 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Formal_Doubly_Linked_Lists is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Allocate + (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; + 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); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + LI, RI : Count_Type; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + LI := Left.First; + RI := Right.First; + while LI /= 0 loop + if Element_Unchecked (Left, LI) /= Element_Unchecked (Right, LI) then + return False; + end if; + + LI := Next_Unchecked (Left, LI); + RI := Next_Unchecked (Right, RI); + end loop; + + return True; + end "="; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Container : in out List; + 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; + + begin + if ContainerP.Free >= 0 then + New_Node := ContainerP.Free; + N (New_Node).Element := New_Item; + ContainerP.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; + 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; + + begin + if ContainerP.Free >= 0 then + New_Node := ContainerP.Free; + ContainerP.Free := N (New_Node).Next; + + else + New_Node := abs ContainerP.Free; + ContainerP.Free := ContainerP.Free - 1; + end if; + end; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + begin + if Target.K /= Plain or Source.K /= Plain then + raise Program_Error with "cannot modify part of container"; + 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; + + Clear (Target); + + J := Source.First; + while J /= 0 loop + Append (Target, N (J).Element); + J := N (J).Next; + end loop; + end; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + begin + if Container.K /= Plain then + raise Constraint_Error; + 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); + + 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; + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container.Plain.all, X); + end loop; + + X := Container.First; + + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + + Free (Container.Plain.all, X); + end; + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Plain_List; + Capacity : Count_Type := 0) return PList_Access + is + C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity); + P : PList_Access; + N : Count_Type := 1; + 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; + P.Nodes (N).Element := Source.Nodes (N).Element; + N := N + 1; + end loop; + P.Free := Source.Free; + if P.Free >= 0 then + N := Source.Capacity + 1; + while N <= C loop + Free (P.all, 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 -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + 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; + X : Count_Type; + + 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 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; + + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); + + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Free (Container.Plain.all, X); + return; + end if; + + 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; + + Free (Container.Plain.all, X); + end loop; + Position := No_Element; + end; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1) + 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; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + 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; + + 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.Length := Container.Length - 1; + + Free (Container.Plain.all, X); + end loop; + end; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1) + 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; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + 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; + + for I in 1 .. Count loop + X := Container.Last; + pragma Assert (N (N (X).Prev).Next = Container.Last); + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Container.Length := Container.Length - 1; + + Free (Container.Plain.all, X); + end loop; + end; + 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 + begin + if not Has_Element (Container => Container, Position => Position) then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + return Element_Unchecked (Container => Container, + Position => Position.Node); + 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; + Position : Cursor := No_Element) return Cursor + is + From : Count_Type := Position.Node; + begin + if From = 0 and Container.Length = 0 then + return No_Element; + end if; + if From = 0 then + From := Container.First; + end if; + if Position.Node /= 0 and then + not Has_Element_Base (Container.Plain.all, 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); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = 0 then + return No_Element; + end if; + return (Node => Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + F : constant Count_Type := Container.First; + begin + if F = 0 then + raise Constraint_Error with "list is empty"; + else + return Element_Unchecked (Container, F); + end if; + end First_Element; + + ---------- + -- Free -- + ---------- + + procedure Free + (Container : in out Plain_List; + X : Count_Type) + is + pragma Assert (X > 0); + pragma Assert (X <= Container.Capacity); + + N : Node_Array renames Container.Nodes; + + begin + N (X).Prev := -1; -- Node is deallocated (not on active list) + + if Container.Free >= 0 then + N (X).Next := Container.Free; + Container.Free := X; + + elsif X + 1 = abs Container.Free then + N (X).Next := 0; -- Not strictly necessary, but marginally safer + Container.Free := Container.Free + 1; + + else + Container.Free := abs Container.Free; + + if Container.Free > Container.Capacity then + Container.Free := 0; + + else + for I in Container.Free .. Container.Capacity - 1 loop + N (I).Next := I + 1; + end loop; + + N (Container.Capacity).Next := 0; + end if; + + N (X).Next := Container.Free; + Container.Free := X; + end if; + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + Nodes : Node_Array renames Container.Plain.all.Nodes; + Node : Count_Type := Container.First; + begin + for I in 2 .. Container.Length loop + if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then + return False; + end if; + + Node := Nodes (Node).Next; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge + (Target : in out List; + Source : in out List) + is + begin + if Target.K /= Plain or Source.K /= Plain then + raise Program_Error with "cannot modify part of container"; + end if; + + declare + LN : Node_Array renames Target.Plain.Nodes; + RN : Node_Array renames Source.Plain.Nodes; + LI : Cursor; + RI : Cursor; + + begin + if Target'Address = Source'Address then + return; + 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 Source.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (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 LI.Node = 0 then + Splice (Target, No_Element, Source); + return; + end if; + + 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; + end Merge; + + ---------- + -- Sort -- + ---------- + + 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 -- + --------------- + + procedure Partition (Pivot, Back : Count_Type) is + Node : Count_Type := N (Pivot).Next; + + 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; + + begin + N (Prev).Next := 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; + + N (Pivot).Prev := Node; + + if N (Node).Prev = 0 then + Container.First := Node; + else + N (N (Node).Prev).Next := Node; + end if; + + Node := Next; + end; + + else + Node := N (Node).Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Count_Type) is + Pivot : Count_Type; + + begin + if Front = 0 then + Pivot := Container.First; + else + Pivot := N (Front).Next; + end if; + + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Sort + + 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.Plain.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; + end Sort; + + end Generic_Sorting; + + ----------------- + -- 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; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + J : Count_Type; + + 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"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Container.Length > Container.Capacity - Count then + raise Constraint_Error with "new length exceeds capacity"; + end if; + + if Container.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; + + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + Position := (Node => J); + + for Index in 2 .. Count loop + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + end loop; + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + J : Count_Type; + + 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"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Container.Length > Container.Capacity - Count then + raise Constraint_Error with "new length exceeds capacity"; + end if; + + if Container.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; + + Allocate (Container, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + Position := (Node => J); + + for Index in 2 .. Count loop + Allocate (Container, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + end loop; + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + 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; + + 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; + + N (Container.First).Prev := 0; + 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; + + Container.Last := New_Node; + N (Container.Last).Next := 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; + + Container.First := New_Node; + N (Container.First).Prev := 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 (N (Before).Prev).Next := New_Node; + N (Before).Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate_Between + (Container : List; + From : Count_Type; + To : Count_Type; + Process : + not null access procedure (Container : List; Position : Cursor)) + is + C : Plain_List renames Container.Plain.all; + N : Node_Array renames C.Nodes; + B : Natural renames C.Busy; + + Node : Count_Type := From; + + 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; + end loop; + exception + when others => + B := B - 1; + raise; + 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; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + end if; + return (Node => Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + L : constant Count_Type := Container.Last; + begin + if L = 0 then + raise Constraint_Error with "list is empty"; + else + return Element_Unchecked (Container, L); + end if; + end Last_Element; + + ---------- + -- Left -- + ---------- + + 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; + 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; + end if; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out List; + Source : in out List) + is + begin + if Target.K /= Plain or Source.K /= Plain then + raise Program_Error with "cannot modify part of container"; + 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 Source.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + Clear (Target); + + 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.Length := Source.Length - 1; + Free (Source.Plain.all, X); + end loop; + end; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Container : List; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + function Next (Container : List; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + 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)); + 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 -- + ------------- + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Container : List; Position : in out Cursor) is + begin + Position := Previous (Container, Position); + end Previous; + + function Previous (Container : List; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + 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; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element_Plain + (Container : Plain_List; Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + C : Plain_List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + N : Node_Type renames C.Nodes (Position.Node); + begin + Process (N.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + 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; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List) + is + N : Count_Type'Base; + + begin + Clear (Item); + + Count_Type'Base'Read (Stream, N); + + if N < 0 then + raise Program_Error with "bad list length"; + end if; + + if N = 0 then + return; + end if; + + if N > Item.Capacity then + raise Constraint_Error with "length exceeds capacity"; + end if; + + for J in 1 .. N loop + Item.Append (Element_Type'Input (Stream)); -- ??? + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Read; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + 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 + raise Program_Error with + "attempt to tamper with cursors (list is locked)"; + end if; + + pragma Assert (Vet (Container, Position), + "bad cursor in Replace_Element"); + + declare + N : Node_Array renames Container.Plain.Nodes; + begin + N (Position.Node).Element := New_Item; + end; + end Replace_Element; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + 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; + + procedure Swap (L, R : Count_Type); + + ---------- + -- Swap -- + ---------- + + 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; + + begin + if LP /= 0 then + N (LP).Next := R; + end if; + + if RN /= 0 then + N (RN).Prev := L; + end if; + + N (L).Next := RN; + N (R).Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + N (L).Prev := R; + N (R).Next := L; + + else + N (L).Prev := RP; + N (RP).Next := L; + + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + 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.Plain.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); + + J := N (J).Next; + exit when I = J; + + I := N (I).Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := N (I).Next; + exit when I = J; + + 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; + 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; + Position : Cursor := No_Element) return Cursor + is + CFirst : Count_Type := Position.Node; + begin + if CFirst = 0 then + CFirst := Container.First; + end if; + + 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); + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate_Between + (Container : List; + From : Count_Type; + To : Count_Type; + Process : + not null access procedure (Container : List; Position : Cursor)) + is + C : Plain_List renames Container.Plain.all; + N : Node_Array renames C.Nodes; + B : Natural renames C.Busy; + + Node : Count_Type := To; + + 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; + end loop; + + exception + when others => + B := B - 1; + raise; + 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; + + ----------- + -- Right -- + ----------- + + 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; + 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)); + end if; + end Right; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Target.K /= Plain or Source.K /= Plain then + raise Program_Error with "cannot modify part of container"; + 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; + + 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 + 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 Source.Plain.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; + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + 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); + return; + end if; + + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Source, Position), "bad Position cursor in Splice"); + + if Target.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 Source.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + Insert + (Container => Target, + Before => Before, + New_Item => Source.Plain.Nodes (Position.Node).Element, + Position => Target_Position); + + Delete (Source, Position); + Position := Target_Position; + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + 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; + + begin + if Before.Node /= 0 then + null; + pragma Assert (Vet (Container, Before), + "bad Before cursor in Splice"); + end if; + + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position), + "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else N (Position.Node).Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + + if Container.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; + + if Before.Node = 0 then + pragma Assert (Position.Node /= Container.Last); + + 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; + + N (Container.Last).Next := Position.Node; + N (Position.Node).Prev := Container.Last; + + Container.Last := Position.Node; + N (Container.Last).Next := 0; + + return; + 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; + + Container.First := Position.Node; + N (Container.First).Prev := 0; + + return; + end if; + + 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; + + 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 (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; + end Splice; + + ------------------ + -- Strict_Equal -- + ------------------ + + function Strict_Equal (Left, Right : List) return Boolean is + CL : Count_Type := Left.First; + CR : Count_Type := Right.First; + begin + while CL /= 0 or CR /= 0 loop + if CL /= CR or else + Element_Unchecked (Left, CL) /= Element_Unchecked (Right, CL) then + return False; + end if; + CL := Next_Unchecked (Left, CL); + CR := Next_Unchecked (Right, CR); + end loop; + return True; + end Strict_Equal; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + 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"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Node = J.Node then + return; + end if; + + if Container.Plain.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is locked)"; + end if; + + pragma Assert (Vet (Container, I), "bad I cursor in Swap"); + pragma Assert (Vet (Container, J), "bad J cursor in Swap"); + + declare + NN : Node_Array renames Container.Plain.Nodes; + NI : Node_Type renames NN (I.Node); + NJ : Node_Type renames NN (J.Node); + + EI_Copy : constant Element_Type := NI.Element; + + begin + NI.Element := NJ.Element; + NJ.Element := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + 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"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Node = J.Node then + return; + end if; + + if Container.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (list is busy)"; + end if; + + pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links"); + + I_Next := Next (Container, I); + + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + J_Next := Next (Container, J); + + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end if; + end Swap_Links; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out List; + Position : Cursor; + 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"; + end if; + + pragma Assert (Vet (Container, Position), + "bad cursor in Update_Element"); + + declare + B : Natural renames Container.Plain.Busy; + L : Natural renames Container.Plain.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + N : Node_Type renames Container.Plain.Nodes (Position.Node); + begin + Process (N.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (L : List; Position : Cursor) return Boolean is + begin + if L.K /= Plain then + raise Program_Error with "cannot modify part of container"; + end if; + + declare + N : Node_Array renames L.Plain.Nodes; + + begin + if L.Length = 0 then + return False; + end if; + + if L.First = 0 then + return False; + end if; + + if L.Last = 0 then + return False; + end if; + + if Position.Node > 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 (Position.Node).Next > L.Capacity then + return False; + end if; + + if N (L.First).Prev /= 0 then + return False; + end if; + + if N (L.Last).Next /= 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 (Position.Node).Next = 0 + and then Position.Node /= L.Last + then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if N (L.First).Next = 0 then + return False; + end if; + + if N (L.Last).Prev = 0 then + return False; + end if; + + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; + + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if N (L.First).Next /= L.Last then + return False; + end if; + + if N (L.Last).Prev /= L.First then + return False; + end if; + + return True; + end if; + + if N (L.First).Next = L.Last then + return False; + end if; + + if N (L.Last).Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if N (Position.Node).Next = 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 then + return False; + end if; + + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; + + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + 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; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write_Between + (Stream : not null access Root_Stream_Type'Class; + Item : Plain_List; + Length : Count_Type; + From : Count_Type; + To : Count_Type) is + + N : Node_Array renames Item.Nodes; + Node : Count_Type; + + begin + Count_Type'Base'Write (Stream, Length); + + Node := From; + while Node /= N (To).Next 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 + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Write; + +end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads new file mode 100644 index 00000000000..af64ea35f8b --- /dev/null +++ b/gcc/ada/a-cfdlli.ads @@ -0,0 +1,288 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +private with Ada.Streams; +with Ada.Containers; use Ada.Containers; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Formal_Doubly_Linked_Lists is + pragma Pure; + + type List (Capacity : Count_Type) is tagged private; + -- pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + function "=" (Left, Right : List) return Boolean; + + function Length (Container : List) return Count_Type; + + function Is_Empty (Container : List) return Boolean; + + procedure Clear (Container : in out List); + + procedure Assign (Target : in out List; Source : List); + + function Copy (Source : List; Capacity : Count_Type := 0) return List; + + function Element (Container : List; Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : List; Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Move (Target : in out List; Source : in out List); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out List); + + procedure Swap + (Container : in out List; + I, J : Cursor); + + procedure Swap_Links + (Container : in out List; + I, J : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor); + + function First (Container : List) return Cursor; + + function First_Element (Container : List) return Element_Type; + + function Last (Container : List) return Cursor; + + function Last_Element (Container : List) return Element_Type; + + function Next (Container : List; Position : Cursor) return Cursor; + + procedure Next (Container : List; Position : in out Cursor); + + function Previous (Container : List; Position : Cursor) return Cursor; + + procedure Previous (Container : List; Position : in out Cursor); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + + function Has_Element (Container : List; Position : Cursor) return Boolean; + + procedure Iterate + (Container : List; + Process : + not null access procedure (Container : List; Position : Cursor)); + + procedure Reverse_Iterate + (Container : List; + Process : + not null access procedure (Container : List; Position : Cursor)); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; + + function Strict_Equal (Left, Right : List) return Boolean; + + function Left (Container : List; Position : Cursor) return List; + + function Right (Container : List; Position : Cursor) return List; + +private + + type Node_Type is record + Prev : Count_Type'Base := -1; + Next : Count_Type; + Element : Element_Type; + end record; + function "=" (L, R : Node_Type) return Boolean is abstract; + + 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 + 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; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List); + + for List'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List); + + for List'Write use Write; + + type Cursor is + record + Node : Count_Type := 0; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + Empty_List : constant List := (0, others => <>); + + No_Element : constant Cursor := (Node => 0); + +end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb new file mode 100644 index 00000000000..34a8a43f1fc --- /dev/null +++ b/gcc/ada/a-cfhama.adb @@ -0,0 +1,1558 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); + +with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); + +with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Formal_Hashed_Maps is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Keys + (Key : Key_Type; + 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; + X : Count_Type); + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (HT : in out Hash_Table_Type; + 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); + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type); + pragma Inline (Set_Next); + + function Vet (Container : Map; Position : Cursor) return Boolean; + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is + new Hash_Tables.Generic_Bounded_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next); + + package Key_Ops is + new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + begin + + if Length (Left) /= Length (Right) then + return False; + end if; + + if Length (Left) = 0 then + return True; + end if; + + 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 + ENode := Find (Container => Right, + Key => Left.HT.Nodes (Node).Key).Node; + if ENode = 0 or else + Right.HT.Nodes (ENode).Element /= Left.HT.Nodes (Node).Element + then + return False; + end if; + + Node := HT_Ops.Next (Left.HT.all, Node); + end loop; + + return True; + + end; + + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Element (Source_Node : Count_Type); + pragma Inline (Insert_Element); + + procedure Insert_Elements is + new HT_Ops.Generic_Iteration (Insert_Element); + + -------------------- + -- Insert_Element -- + -------------------- + + procedure Insert_Element (Source_Node : Count_Type) is + N : Node_Type renames Source.HT.Nodes (Source_Node); + begin + Target.Insert (N.Key, N.Element); + 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; + end if; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- correct exception ??? + "Source length exceeds Target capacity"; + end if; + + 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; + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) return Count_Type is + begin + return Container.HT.Nodes'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + 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); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Map; + Capacity : Count_Type := 0) return Map + is + C : constant Count_Type := + Count_Type'Max (Capacity, Source.Capacity); + H : Hash_Type := 1; + N : Count_Type := 1; + 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; + while H <= Source.Modulus loop + Target.HT.Buckets (H) := Source.HT.Buckets (H); + H := H + 1; + end loop; + while N <= Source.Capacity loop + Target.HT.Nodes (N) := Source.HT.Nodes (N); + N := N + 1; + end loop; + while N <= C loop + Cu := (Node => N); + Free (Target.HT.all, 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; + + --------------------- + -- Default_Modulus -- + --------------------- + + function Default_Modulus (Capacity : Count_Type) return Hash_Type is + begin + return To_Prime (Capacity); + end Default_Modulus; + + ------------ + -- Delete -- + ------------ + + procedure Delete (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); + + if X = 0 then + raise Constraint_Error with "attempt to delete key not in map"; + end if; + + Free (Container.HT.all, 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 + 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); + + Free (Container.HT.all, Position.Node); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Count_Type := Find (Container, Key).Node; + + begin + if Node = 0 then + raise Constraint_Error with + "no element available because key not in map"; + end if; + + return Container.HT.Nodes (Node).Element; + end Element; + + function Element (Container : Map; Position : Cursor) return Element_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Container, Position), + "bad cursor in function Element"); + + return Container.HT.Nodes (Position.Node).Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Type) return Boolean is + begin + return Equivalent_Keys (Key, Node.Key); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Map; CLeft : Cursor; + Right : Map; CRight : Cursor) + return Boolean is + begin + if not Has_Element (Left, CLeft) then + raise Constraint_Error with + "Left cursor of Equivalent_Keys has no element"; + end if; + + if not Has_Element (Right, CRight) then + raise Constraint_Error with + "Right cursor of Equivalent_Keys has no element"; + end if; + + pragma Assert (Vet (Left, CLeft), + "Left cursor of Equivalent_Keys is bad"); + pragma Assert (Vet (Right, CRight), + "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); + + begin + return Equivalent_Keys (LN.Key, RN.Key); + end; + end Equivalent_Keys; + + function Equivalent_Keys + (Left : Map; + CLeft : Cursor; + Right : Key_Type) return Boolean is + begin + if not Has_Element (Left, CLeft) then + raise Constraint_Error with + "Left cursor of Equivalent_Keys has no element"; + end if; + + pragma Assert (Vet (Left, CLeft), + "Left cursor in Equivalent_Keys is bad"); + + declare + LT : Hash_Table_Type renames Left.HT.all; + LN : Node_Type renames LT.Nodes (CLeft.Node); + + begin + return Equivalent_Keys (LN.Key, Right); + end; + end Equivalent_Keys; + + function Equivalent_Keys + (Left : Key_Type; + Right : Map; + CRight : Cursor) return Boolean is + begin + if Has_Element (Right, CRight) then + raise Constraint_Error with + "Right cursor of Equivalent_Keys has no element"; + end if; + + pragma Assert (Vet (Right, CRight), + "Right cursor of Equivalent_Keys is bad"); + + declare + RT : Hash_Table_Type renames Right.HT.all; + RN : Node_Type renames RT.Nodes (CRight.Node); + + begin + return Equivalent_Keys (Left, RN.Key); + end; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + 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); + 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 + 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; + + return (Node => Find_Between (Container.HT.all, Key, + Container.First, Container.Last)); + end case; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + 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; + end First; + + ---------- + -- Free -- + ---------- + + procedure Free + (HT : in out Hash_Table_Type; + X : Count_Type) + is + begin + HT.Nodes (X).Has_Element := False; + HT_Ops.Free (HT, X); + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate + (HT : in out Hash_Table_Type; + Node : out Count_Type) + is + + procedure Allocate is + new HT_Ops.Generic_Allocate (Set_Element); + + begin + Allocate (HT, Node); + HT.Nodes (Node).Has_Element := True; + end Generic_Allocate; + + ----------------- + -- Has_Element -- + ----------------- + + 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 + 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; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node + (Node : Node_Type) return Hash_Type is + begin + return Hash (Node.Key); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + if Container.HT.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); + begin + N.Key := Key; + N.Element := New_Item; + end; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + 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); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + procedure Allocate is + new Generic_Allocate (Assign_Key); + + ----------------- + -- Assign_Key -- + ----------------- + + procedure Assign_Key (Node : in out Node_Type) is + begin + Node.Key := Key; + -- Node.Element := New_Item; + end Assign_Key; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container.HT.all, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + + Local_Insert (Container.HT.all, Key, Position.Node, Inserted); + end; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + 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); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + procedure Allocate is + new Generic_Allocate (Assign_Key); + + ----------------- + -- Assign_Key -- + ----------------- + + procedure Assign_Key (Node : in out Node_Type) is + begin + Node.Key := Key; + Node.Element := New_Item; + end Assign_Key; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container.HT.all, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + + Local_Insert (Container.HT.all, Key, Position.Node, Inserted); + end; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : + not null access procedure (Container : Map; Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Container, (Node => Node)); + end Process_Node; + + B : Natural renames Container'Unrestricted_Access.HT.Busy; + + -- Start of processing for Iterate + + begin + 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; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Container : Map; Position : Cursor) return Key_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of function Key has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in function Key"); + + return Container.HT.Nodes (Position.Node).Key; + end Key; + + ---------- + -- Left -- + ---------- + + 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; + 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); + end if; + end Left; + + ------------ + -- Length -- + ------------ + + 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; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (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; + 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; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + if HT.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 + return; + end if; + + X := HT_Ops.First (HT); + while X /= 0 loop + Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? + + Y := HT_Ops.Next (HT, X); + + HT_Ops.Delete_Node_Sans_Free (HT, X); + Free (HT, X); + + X := Y; + end loop; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Type) return Count_Type is + begin + 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 + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error + with "Position has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in function Next"); + + return Next_Unchecked (Container, Position); + end Next; + + procedure Next (Container : Map; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Map) return Boolean is + Left_Node : Count_Type; + Left_Nodes : Nodes_Type renames Left.HT.Nodes; + To_Node : Count_Type; + begin + if Length (Right) = 0 or Length (Left) = 0 then + return False; + end if; + + if Left'Address = Right'Address then + return True; + end if; + + 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 + declare + N : Node_Type renames Left_Nodes (Left_Node); + E : Key_Type renames N.Key; + + begin + if Find (Right, E).Node /= 0 then + return True; + end if; + end; + + Left_Node := HT_Ops.Next (Left.HT.all, Left_Node); + end loop; + + return False; + end Overlap; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + 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 + "Position cursor of Query_Element has no element"; + end if; + + 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); + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames N.Key; + E : Element_Type renames N.Element; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type; + + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new Generic_Allocate (Read_Element); + + procedure Read_Element (Node : in out Node_Type) is + begin + Element_Type'Read (Stream, Node.Element); + end Read_Element; + + Node : Count_Type; + + -- Start of processing for Read_Node + + begin + Allocate (Container.HT.all, 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; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Ops.Find (Container.HT.all, 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 + raise Program_Error with + "Replace attempted to tamper with cursors (map is locked)"; + end if; + + declare + N : Node_Type renames Container.HT.Nodes (Node); + begin + N.Key := Key; + N.Element := New_Item; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + 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 + raise Program_Error with + "Replace_Element attempted to tamper with cursors (map is locked)"; + end if; + + pragma Assert (Vet (Container, Position), + "bad cursor in Replace_Element"); + + Container.HT.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + 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"; + end if; + end Reserve_Capacity; + + ----------- + -- Right -- + ----------- + + function Right (Container : Map; Position : Cursor) return Map is + Last : Count_Type; + Lst : Count_Type; + L : Count_Type := 0; + C : Count_Type := Position.Node; + 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); + end if; + + if C = Lst then + raise Constraint_Error with + "Position cursor has no element"; + 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; + end loop; + + return (Capacity => Container.Capacity, + Modulus => Container.Modulus, + K => Part, + HT => Container.HT, + Length => L, + First => Position.Node, + Last => Last); + end Right; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is + begin + Node.Next := Next; + end Set_Next; + + ------------------ + -- Strict_Equal -- + ------------------ + + function Strict_Equal (Left, Right : Map) return Boolean is + CuL : Cursor := First (Left); + CuR : Cursor := First (Right); + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + 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 + return False; + end if; + CuL := Next_Unchecked (Left, CuL); + CuR := Next_Unchecked (Right, CuR); + end loop; + + return True; + end Strict_Equal; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + 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, Position), + "bad cursor in Update_Element"); + + declare + HT : Hash_Table_Type renames Container.HT.all; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + N : Node_Type renames HT.Nodes (Position.Node); + K : Key_Type renames N.Key; + E : Element_Type renames N.Element; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Container : Map; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return True; + end if; + + declare + M : HT_Types.Hash_Table_Type renames Container.HT.all; + X : Count_Type; + + begin + if M.Length = 0 then + return False; + end if; + + if M.Capacity = 0 then + return False; + end if; + + if M.Buckets'Length = 0 then + return False; + end if; + + if Position.Node > M.Capacity then + return False; + end if; + + if M.Nodes (Position.Node).Next = Position.Node then + return False; + end if; + + X := M.Buckets (Key_Ops.Index (M, M.Nodes (Position.Node).Key)); + + for J in 1 .. M.Length loop + if X = Position.Node then + return True; + end if; + + if X = 0 then + return False; + end if; + + if X = M.Nodes (X).Next then -- to prevent unnecessary looping + return False; + end if; + + X := M.Nodes (X).Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Node); + + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write_Nodes (Stream, Container.HT.all); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + +end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads new file mode 100644 index 00000000000..03b6d36789d --- /dev/null +++ b/gcc/ada/a-cfhama.ads @@ -0,0 +1,259 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Hash_Tables; +private with Ada.Streams; +with Ada.Containers; use Ada.Containers; + +generic + type Key_Type is private; + type Element_Type is private; + + with function Hash (Key : Key_Type) return Hash_Type; + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Formal_Hashed_Maps is + pragma Pure; + + type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private; + -- pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + function "=" (Left, Right : Map) return Boolean; + + function Capacity (Container : Map) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type); + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + -- ??? what does clear do to active elements? + procedure Clear (Container : in out Map); + + procedure Assign (Target : in out Map; Source : Map); + + -- ??? + -- capacity=0 means use container.length as cap of tgt + -- modulos=0 means use default_modulous(container.length) + function Copy (Source : Map; + Capacity : Count_Type := 0) return Map; + + function Key (Container : Map; Position : Cursor) return Key_Type; + + function Element (Container : Map; Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); + + function First (Container : Map) return Cursor; + + function Next (Container : Map; Position : Cursor) return Cursor; + + procedure Next (Container : Map; Position : in out Cursor); + + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Has_Element (Container : Map; Position : Cursor) return Boolean; + + function Equivalent_Keys + (Left : Map; + CLeft : Cursor; + Right : Map; + CRight : Cursor) return Boolean; + + function Equivalent_Keys + (Left : Map; + CLeft : Cursor; + Right : Key_Type) return Boolean; + + function Equivalent_Keys + (Left : Key_Type; + Right : Map; + CRight : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : + not null access procedure (Container : Map; Position : Cursor)); + + function Default_Modulus (Capacity : Count_Type) return Hash_Type; + + function Strict_Equal (Left, Right : Map) return Boolean; + + function Left (Container : Map; Position : Cursor) return Map; + + function Right (Container : Map; Position : Cursor) return Map; + + function Overlap (Left, Right : Map) return Boolean; + +private + -- pragma Inline ("="); + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + -- pragma Inline (Move); ??? + pragma Inline (Contains); + pragma Inline (Capacity); + -- pragma Inline (Reserve_Capacity); ??? + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); + pragma Inline (Next); + + type Node_Type is record + Key : Key_Type; + Element : Element_Type; + Next : Count_Type; + Has_Element : Boolean := False; + end record; + + 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 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; + + use HT_Types; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + type Cursor is + record + Node : Count_Type; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>); + + No_Element : constant Cursor := (Node => 0); + +end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb new file mode 100644 index 00000000000..ed514c826d6 --- /dev/null +++ b/gcc/ada/a-cfhase.adb @@ -0,0 +1,2436 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); + +with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); + +with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Formal_Hashed_Sets is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Difference + (Left, Right : Set; + Target : in out Hash_Table_Type); + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Type) return Boolean; + pragma Inline (Equivalent_Keys); + + procedure Free + (HT : in out Hash_Table_Type; + X : Count_Type); + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (HT : in out Hash_Table_Type; + 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; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean); + + procedure Intersection + (Left : Hash_Table_Type; + Right : Set; + Target : in out Hash_Table_Type); + + function Is_In + (HT : HT_Types.Hash_Table_Type; + 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); + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type); + pragma Inline (Set_Next); + + function Vet (Container : Set; Position : Cursor) return Boolean; + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Hash_Tables.Generic_Bounded_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next); + + package Element_Keys is new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + + if Length (Left) /= Length (Right) then + return False; + end if; + + if Length (Left) = 0 then + return True; + end if; + + 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 + ENode := Find (Container => Right, + Item => Left.HT.Nodes (Node).Element).Node; + if ENode = 0 or else + Right.HT.Nodes (ENode).Element /= Left.HT.Nodes (Node).Element + then + return False; + end if; + + Node := HT_Ops.Next (Left.HT.all, Node); + end loop; + + return True; + + end; + + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + procedure Insert_Element (Source_Node : Count_Type); + + procedure Insert_Elements is + new HT_Ops.Generic_Iteration (Insert_Element); + + -------------------- + -- Insert_Element -- + -------------------- + + procedure Insert_Element (Source_Node : Count_Type) is + N : Node_Type renames Source.HT.Nodes (Source_Node); + X : Count_Type; + B : Boolean; + + begin + Insert (Target.HT.all, 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; + end if; + + if Target.Capacity < Length (Source) then + 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; + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Set) return Count_Type is + begin + return Container.HT.Nodes'Length; + end Capacity; + + ----------- + -- 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; + + HT_Ops.Clear (Container.HT.all); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Set; + Capacity : Count_Type := 0) return Set + is + C : constant Count_Type := + Count_Type'Max (Capacity, Source.Capacity); + H : Hash_Type := 1; + N : Count_Type := 1; + 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; + while H <= Source.Modulus loop + Target.HT.Buckets (H) := Source.HT.Buckets (H); + H := H + 1; + end loop; + while N <= Source.Capacity loop + Target.HT.Nodes (N) := Source.HT.Nodes (N); + N := N + 1; + end loop; + while N <= C loop + Cu := (Node => N); + Free (Target.HT.all, 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; + + --------------------- + -- Default_Modulus -- + --------------------- + + function Default_Modulus (Capacity : Count_Type) return Hash_Type is + begin + return To_Prime (Capacity); + end Default_Modulus; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Item : Element_Type) + 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); + + if X = 0 then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + Free (Container.HT.all, X); + end Delete; + + 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; + + if Container.HT.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); + + Position := No_Element; + end Delete; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference + (Target : in out Set; + Source : Set) + 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; + + 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; + + if Src_Length = 0 then + return; + end if; + + if Target.HT.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; + else + Src_Node := HT_Ops.First (Source.HT.all); + Src_Last := 0; + end if; + when Part => + Src_Node := Source.First; + Src_Last := HT_Ops.Next (Source.HT.all, Source.Last); + end case; + while Src_Node /= Src_Last loop + Tgt_Node := Element_Keys.Find + (Target.HT.all, 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); + end if; + + Src_Node := HT_Ops.Next (Source.HT.all, Src_Node); + end loop; + end Difference; + + procedure Difference + (Left, Right : Set; + Target : in out Hash_Table_Type) + is + procedure Process (L_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Count_Type) is + E : Element_Type renames Left.HT.Nodes (L_Node).Element; + X : Count_Type; + B : Boolean; + + begin + if Find (Right, E).Node = 0 then + Insert (Target, E, X, B); + pragma Assert (B); + end if; + end Process; + + -- 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; + 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; + end if; + + if Length (Left) = 0 then + return Empty_Set; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + C := Length (Left); + H := Default_Modulus (C); + Difference (Left, Right, Target => S.HT.all); + return S; + end Difference; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Position : Cursor) return Element_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + 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; + end Element; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + 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; + + -- 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; + + 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); + + if Find (R, L.Nodes (L_Node).Element).Node = 0 then + return False; + end if; + + L_Node := L.Nodes (L_Node).Next; + + if L_Node = 0 then + -- We have exhausted the nodes in this bucket + -- Find the next bucket + + 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 + return False; + end if; + if Length (Left) = 0 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; + end Equivalent_Sets; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left : Set; CLeft : Cursor; + Right : Set; CRight : Cursor) + return Boolean is + begin + if not Has_Element (Left, CLeft) then + raise Constraint_Error with + "Left cursor of Equivalent_Elements has no element"; + end if; + + if not Has_Element (Right, CRight) then + raise Constraint_Error with + "Right cursor of Equivalent_Elements has no element"; + end if; + + pragma Assert (Vet (Left, CLeft), + "bad Left cursor in Equivalent_Elements"); + pragma Assert (Vet (Right, CRight), + "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); + begin + return Equivalent_Elements (LN.Element, RN.Element); + end; + end Equivalent_Elements; + + function Equivalent_Elements + (Left : Set; + CLeft : Cursor; + Right : Element_Type) return Boolean is + begin + if not Has_Element (Left, CLeft) then + raise Constraint_Error with + "Left cursor of Equivalent_Elements has no element"; + end if; + + pragma Assert (Vet (Left, CLeft), + "Left cursor in Equivalent_Elements is bad"); + + declare + LN : Node_Type renames Left.HT.Nodes (CLeft.Node); + begin + return Equivalent_Elements (LN.Element, Right); + end; + end Equivalent_Elements; + + function Equivalent_Elements + (Left : Element_Type; + Right : Set; + CRight : Cursor) return Boolean is + begin + if not Has_Element (Right, CRight) then + raise Constraint_Error with + "Right cursor of Equivalent_Elements has no element"; + end if; + + pragma Assert + (Vet (Right, CRight), + "Right cursor of Equivalent_Elements is bad"); + + declare + RN : Node_Type renames Right.HT.Nodes (CRight.Node); + begin + return Equivalent_Elements (Left, RN.Element); + end; + end Equivalent_Elements; + + -- NOT MODIFIED + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Key : Element_Type; Node : Node_Type) + return Boolean is + begin + return Equivalent_Elements (Key, Node.Element); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Item : Element_Type) + 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); + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find + (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 + + if Container.Length = 0 then + return No_Element; + end if; + + return (Node => Find_Between (Container.HT.all, Item, + Container.First, Container.Last)); + end; + end case; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + 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; + end First; + + ---------- + -- Free -- + ---------- + + procedure Free + (HT : in out Hash_Table_Type; + X : Count_Type) + is + begin + HT.Nodes (X).Has_Element := False; + HT_Ops.Free (HT, X); + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate + (HT : in out Hash_Table_Type; + Node : out Count_Type) + is + + procedure Allocate is + new HT_Ops.Generic_Allocate (Set_Element); + + begin + Allocate (HT, Node); + HT.Nodes (Node).Has_Element := True; + end Generic_Allocate; + + ----------------- + -- Has_Element -- + ----------------- + + 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 + 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; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Type) return Hash_Type is + begin + return Hash (Node.Element); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + if Container.HT.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; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + 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; + + Insert (Container.HT.all, New_Item, Position.Node, Inserted); + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + procedure Insert + (Container : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + procedure Allocate_Set_Element (Node : in out Node_Type); + pragma Inline (Allocate_Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + procedure Allocate is + new Generic_Allocate (Allocate_Set_Element); + + --------------------------- + -- Allocate_Set_Element -- + --------------------------- + + procedure Allocate_Set_Element (Node : in out Node_Type) is + begin + Node.Element := New_Item; + end Allocate_Set_Element; + + -------------- + -- 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 + + begin + + Local_Insert (Container, New_Item, Node, Inserted); + + end Insert; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Set; + Source : Set) + is + Tgt_Node : Count_Type; + TN : Nodes_Type renames Target.HT.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 + Clear (Target); + return; + end if; + + if Target.HT.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); + 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); + + 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); + end; + end if; + end loop; + end Intersection; + + procedure Intersection + (Left : Hash_Table_Type; + Right : Set; + Target : in out Hash_Table_Type) + is + procedure Process (L_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Count_Type) is + E : Element_Type renames Left.Nodes (L_Node).Element; + X : Count_Type; + B : Boolean; + + begin + if Find (Right, E).Node /= 0 then + Insert (Target, E, X, B); + pragma Assert (B); + end if; + end Process; + + -- Start of processing for Intersection + + begin + Iterate (Left); + end Intersection; + + 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 + return Left.Copy; + end if; + + C := Count_Type'Min (Length (Left), Length (Right)); -- ??? + 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; + end if; + end return; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ----------- + -- Is_In -- + ----------- + + function Is_In (HT : HT_Types.Hash_Table_Type; + Key : Node_Type) return Boolean is + begin + return Element_Keys.Find (HT, Key.Element) /= 0; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + 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; + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Length (Subset) > Length (Of_Set) then + return False; + end if; + + 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 + declare + N : Node_Type renames Subset_Nodes (Subset_Node); + E : Element_Type renames N.Element; + + begin + if Find (Of_Set, E).Node = 0 then + return False; + end if; + end; + + Subset_Node := HT_Ops.Next (Subset.HT.all, Subset_Node); + end loop; + + return True; + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : + not null access procedure (Container : Set; Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Container, (Node => Node)); + end Process_Node; + + B : Natural renames Container'Unrestricted_Access.HT.Busy; + + -- Start of processing for Iterate + + begin + 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; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Left -- + ---------- + + 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; + 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); + end if; + end Left; + + ------------ + -- Length -- + ------------ + + 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; + end Length; + + ---------- + -- Move -- + ---------- + + 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; + 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; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + if HT.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 + return; + end if; + + X := HT_Ops.First (HT); + while X /= 0 loop + Insert (Target, NN (X).Element); -- optimize??? + + Y := HT_Ops.Next (HT, X); + + HT_Ops.Delete_Node_Sans_Free (HT, X); + Free (HT, X); + + X := Y; + end loop; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Type) return Count_Type is + begin + 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 + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error + with "Position has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in Next"); + + return Next_Unchecked (Container, Position); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + Left_Node : Count_Type; + Left_Nodes : Nodes_Type renames Left.HT.Nodes; + To_Node : Count_Type; + begin + if Length (Right) = 0 or Length (Left) = 0 then + return False; + end if; + + if Left'Address = Right'Address then + return True; + end if; + + 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 + declare + N : Node_Type renames Left_Nodes (Left_Node); + E : Element_Type renames N.Element; + + begin + if Find (Right, E).Node /= 0 then + return True; + end if; + end; + + Left_Node := HT_Ops.Next (Left.HT.all, Left_Node); + end loop; + + return False; + end Overlap; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : in out Set; + Position : Cursor; + 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"; + end if; + + 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; + + begin + B := B + 1; + L := L + 1; + + begin + Process (HT.Nodes (Position.Node).Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type; + + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new Generic_Allocate (Read_Element); + + procedure Read_Element (Node : in out Node_Type) is + begin + Element_Type'Read (Stream, Node.Element); + end Read_Element; + + Node : Count_Type; + + -- Start of processing for Read_Node + + begin + Allocate (Container.HT.all, 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; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + New_Item : Element_Type) + is + Node : constant Count_Type := + Element_Keys.Find (Container.HT.all, 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 + raise Program_Error with + "attempt to tamper with cursors (set is locked)"; + end if; + + Container.HT.Nodes (Node).Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + 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 equals No_Element"; + end if; + + pragma Assert (Vet (Container, Position), + "bad cursor in Replace_Element"); + + Replace_Element (Container.HT.all, Position.Node, New_Item); + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Set; + 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; + end Reserve_Capacity; + + ----------- + -- Right -- + ----------- + + function Right (Container : Set; Position : Cursor) return Set is + Last : Count_Type; + Lst : Count_Type; + L : Count_Type := 0; + C : Count_Type := Position.Node; + 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); + end if; + + if C = Lst then + raise Constraint_Error with + "Position cursor has no element"; + 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; + end loop; + + return (Capacity => Container.Capacity, + Modulus => Container.Modulus, + K => Part, + HT => Container.HT, + Length => L, + First => Position.Node, + Last => Last); + end Right; + + ------------------ + -- Set_Element -- + ------------------ + + procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is + begin + Node.Element := Item; + end Set_Element; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is + begin + Node.Next := Next; + end Set_Next; + + ------------------ + -- Strict_Equal -- + ------------------ + + function Strict_Equal (Left, Right : Set) return Boolean is + CuL : Cursor := First (Left); + CuR : Cursor := First (Right); + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + 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 + return False; + end if; + CuL := Next_Unchecked (Left, CuL); + CuR := Next_Unchecked (Right, CuR); + end loop; + + return True; + end Strict_Equal; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Set; + Source : Set) + is + procedure Process (Source_Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Source_Node : Count_Type) is + N : Node_Type renames Source.HT.Nodes (Source_Node); + X : Count_Type; + B : Boolean; + + begin + if Is_In (Target.HT.all, N) then + Delete (Target, N.Element); + else + Insert (Target.HT.all, N.Element, X, B); + pragma Assert (B); + end if; + end Process; + + -- 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); + return; + end if; + + if Length (Target) = 0 then + Assign (Target, Source); + return; + end if; + + if Target.HT.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; + + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + C : Count_Type; + H : Hash_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + if Length (Left) = 0 then + return Right.Copy; + end if; + + 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); + end return; + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + X : Count_Type; + B : Boolean; + + begin + return S : Set (Capacity => 1, Modulus => 1) do + Insert (S.HT.all, New_Item, X, B); + pragma Assert (B); + end return; + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union + (Target : in out Set; + Source : Set) + is + procedure Process (Src_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Count_Type) is + N : Node_Type renames Source.HT.Nodes (Src_Node); + E : Element_Type renames N.Element; + + X : Count_Type; + B : Boolean; + + begin + Insert (Target.HT.all, 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 + 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; + end Union; + + function Union (Left, Right : Set) return Set is + C : Count_Type; + H : Hash_Type; + + begin + if Left'Address = Right'Address then + return Left.Copy; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + if Length (Left) = 0 then + return Right.Copy; + end if; + + C := Length (Left) + Length (Right); + H := Default_Modulus (C); + return S : Set (C, H) do + Assign (Target => S, Source => Left); + Union (Target => S, Source => Right); + end return; + end Union; + + --------- + -- Vet -- + --------- + + function Vet (Container : Set; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return True; + end if; + + declare + S : Set renames Container; + N : Nodes_Type renames S.HT.Nodes; + X : Count_Type; + + begin + if S.Length = 0 then + return False; + end if; + + if Position.Node > N'Last then + return False; + end if; + + if N (Position.Node).Next = Position.Node then + return False; + end if; + + X := S.HT.Buckets (Element_Keys.Index (S.HT.all, + N (Position.Node).Element)); + + for J in 1 .. S.Length loop + if X = Position.Node then + return True; + end if; + + if X = 0 then + return False; + end if; + + if X = N (X).Next then -- to prevent unnecessary looping + return False; + end if; + + X := N (X).Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Node); + + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write_Nodes (Stream, Container.HT.all); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean; + pragma Inline (Equivalent_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Key : Key_Type) return Boolean + is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + 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_Keys.Delete_Key_Sans_Free (Container.HT.all, Key, X); + + if X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Free (Container.HT.all, X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + Node : constant Count_Type := Find (Container, Key).Node; + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + return Container.HT.Nodes (Node).Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean + is + begin + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); + end Equivalent_Key_Node; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + 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_Keys.Delete_Key_Sans_Free (Container.HT.all, Key, X); + Free (Container.HT.all, X); + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find + (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; + + return 0; + end Find_Between; + + begin + if Container.Length = 0 then + return No_Element; + end if; + + return (Node => Find_Between (Container.HT.all, Key, + Container.First, Container.Last)); + end; + end if; + end Find; + + --------- + -- Key -- + --------- + + function Key (Container : Set; Position : Cursor) return Key_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position), + "bad cursor in function Key"); + + declare + HT : Hash_Table_Type renames Container.HT.all; + N : Node_Type renames HT.Nodes (Position.Node); + begin + return Key (N.Element); + end; + end Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + 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 := + 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; + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)) + is + Indx : Hash_Type; + N : Nodes_Type renames Container.HT.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)); + + 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; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if Equivalent_Keys (K, Key (E)) then + pragma Assert (Hash (K) = Hash (E)); + return; + end if; + end; + + -- 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; + + else + declare + Prev : Count_Type := Container.HT.Buckets (Indx); + + begin + while N (Prev).Next /= Position.Node loop + Prev := N (Prev).Next; + + if Prev = 0 then + raise Program_Error with + "Position cursor is bad (node not found)"; + end if; + end loop; + + N (Prev).Next := N (Position.Node).Next; + end; + end if; + + Container.Length := Container.Length - 1; + Free (Container.HT.all, Position.Node); + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + end Generic_Keys; + +end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads new file mode 100644 index 00000000000..2a6a613b3da --- /dev/null +++ b/gcc/ada/a-cfhase.ads @@ -0,0 +1,284 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Hash_Tables; +private with Ada.Streams; + +with Ada.Containers; +use Ada.Containers; + +generic + type Element_Type is private; + + with function Hash (Element : Element_Type) return Hash_Type; + + with function Equivalent_Elements (Left, Right : Element_Type) + return Boolean; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Formal_Hashed_Sets is + pragma Pure; + + type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private; + -- pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Equivalent_Sets (Left, Right : Set) return Boolean; + + function To_Set (New_Item : Element_Type) return Set; + + function Capacity (Container : Set) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type); + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set; + Capacity : Count_Type := 0) return Set; + + function Element (Container : Set; Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert (Container : in out Set; New_Item : Element_Type); + + procedure Include (Container : in out Set; New_Item : Element_Type); + + procedure Replace (Container : in out Set; New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Item : Element_Type); + + procedure Delete (Container : in out Set; Item : Element_Type); + + procedure Delete (Container : in out Set; Position : in out Cursor); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set + renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function First (Container : Set) return Cursor; + + function Next (Container : Set; Position : Cursor) return Cursor; + + procedure Next (Container : Set; Position : in out Cursor); + + function Find + (Container : Set; + Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Has_Element (Container : Set; Position : Cursor) return Boolean; + + function Equivalent_Elements (Left : Set; CLeft : Cursor; + Right : Set; CRight : Cursor) return Boolean; + + function Equivalent_Elements + (Left : Set; CLeft : Cursor; + Right : Element_Type) return Boolean; + + function Equivalent_Elements + (Left : Element_Type; + Right : Set; CRight : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : + not null access procedure (Container : Set; Position : Cursor)); + + function Default_Modulus (Capacity : Count_Type) return Hash_Type; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + package Generic_Keys is + + function Key (Container : Set; Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + end Generic_Keys; + + function Strict_Equal (Left, Right : Set) return Boolean; + + function Left (Container : Set; Position : Cursor) return Set; + + function Right (Container : Set; Position : Cursor) return Set; + +private + + pragma Inline (Next); + + type Node_Type is + record + Element : Element_Type; + Next : Count_Type; + Has_Element : Boolean := False; + end record; + + 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; + + use HT_Types; + use Ada.Streams; + + type Cursor is + record + Node : Count_Type; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := (Node => 0); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>); + +end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb new file mode 100644 index 00000000000..705fd618e9f --- /dev/null +++ b/gcc/ada/a-cforma.adb @@ -0,0 +1,1737 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); + +with System; use type System.Address; + +package body Ada.Containers.Formal_Ordered_Maps is + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Type) + return Ada.Containers.Red_Black_Trees.Color_Type; + pragma Inline (Color); + + function Left_Son (Node : Node_Type) return Count_Type; + pragma Inline (Left); + + function Parent (Node : Node_Type) return Count_Type; + pragma Inline (Parent); + + function Right_Son (Node : Node_Type) return Count_Type; + pragma Inline (Right); + + procedure Set_Color + (Node : in out Node_Type; + Color : Ada.Containers.Red_Black_Trees.Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type); + pragma Inline (Set_Left); + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type); + pragma Inline (Set_Right); + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); + pragma Inline (Set_Parent); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (Tree : in out Tree_Types.Tree_Type'Class; + Node : out Count_Type); + + procedure Free (Tree : in out Tree_Types.Tree_Type; X : Count_Type); + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Key_Node); + + function Next_Unchecked + (Container : Map; + Position : Count_Type) return Count_Type; + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Bounded_Operations + (Tree_Types => Tree_Types, + Left => Left_Son, + Right => Right_Son); + + use Tree_Operations; + + package Key_Ops is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + Lst : Count_Type; + Node : Count_Type := First (Left).Node; + ENode : Count_Type; + begin + + if Length (Left) /= Length (Right) then + return False; + end if; + + if Is_Empty (Left) then + return True; + end if; + + Lst := Next (Left.Tree.all, Last (Left).Node); + while Node /= Lst loop + ENode := Find (Right, Left.Tree.Nodes (Node).Key).Node; + if ENode = 0 or else + Left.Tree.Nodes (Node).Element /= Right.Tree.Nodes (ENode).Element + then + return False; + end if; + Node := Next (Left.Tree.all, Node); + end loop; + + return True; + + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Append_Element (Source_Node : Count_Type); + + procedure Append_Elements is + new Tree_Operations.Generic_Iteration (Append_Element); + + -------------------- + -- Append_Element -- + -------------------- + + 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 Key_Ops.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Key_Ops.Generic_Unconditional_Insert (Insert_Post); + + procedure Unconditional_Insert_Avec_Hint is + new Key_Ops.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.Key := SN.Key; + 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.Key, + Node => Target_Node); + end Append_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; + end if; + + if Target.Capacity < Length (Source) then + 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; + end Assign; + + ------------- + -- Ceiling -- + ------------- + + 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; + + 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; + 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; + end Ceiling; + + ----------- + -- Clear -- + ----------- + + 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); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Type) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + 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; + + 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; + Node := Node + 1; + end loop; + + while Node <= Target.Capacity loop + N := Node; + Formal_Ordered_Maps.Free (Tree => Target.Tree.all, 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; + + ------------ + -- 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; + + pragma Assert (Vet (Container.Tree.all, Position.Node), + "Position cursor of Delete is bad"); + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, + Position.Node); + Formal_Ordered_Maps.Free (Container.Tree.all, Position.Node); + end Delete; + + procedure Delete (Container : in out Map; 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 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; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Map) 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); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Map) 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); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Position : Cursor) return Element_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of function Element has no element"; + end if; + + pragma Assert (Vet (Container.Tree.all, Position.Node), + "Position cursor of function Element is bad"); + + return Container.Tree.Nodes (Position.Node).Element; + + end Element; + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Find (Container, Key).Node; + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + return Container.Tree.Nodes (Node).Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : constant Node_Access := Key_Ops.Find (Container.Tree.all, 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); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + 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); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + begin + if Length (Container) = 0 then + return No_Element; + end if; + + if Container.K = Plain then + return (Node => Container.Tree.First); + else + return (Node => Container.First); + end if; + + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Tree.Nodes (First (Container).Node).Element; + end First_Element; + + --------------- + -- First_Key -- + --------------- + + function First_Key (Container : Map) return Key_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Tree.Nodes (First (Container).Node).Key; + end First_Key; + + ----------- + -- Floor -- + ----------- + + 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; + + if Container.Tree.Nodes (Container.Last).Key < Key then + return (Node => Container.Last); + end if; + 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; + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free + (Tree : in out Tree_Types.Tree_Type; + X : Count_Type) + is + begin + Tree.Nodes (X).Has_Element := False; + Tree_Operations.Free (Tree, X); + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate + (Tree : in out Tree_Types.Tree_Type'Class; + Node : out Count_Type) + is + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + begin + Allocate (Tree, Node); + Tree.Nodes (Node).Has_Element := True; + end Generic_Allocate; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : Map; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + 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; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + if Container.Tree.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); + begin + N.Key := Key; + N.Element := New_Item; + end; + end if; + end Include; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + 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); + + -------------- + -- 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 Initialize (Node : in out Node_Type) is + begin + Node.Key := Key; + Node.Element := New_Item; + end Initialize; + + X : Node_Access; + + begin + Allocate_Node (Container.Tree.all, X); + return X; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree.all, + Key, + Position.Node, + Inserted); + end; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with "key already in map"; + end if; + end Insert; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + 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); + + -------------- + -- 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 Initialize (Node : in out Node_Type) is + begin + Node.Key := Key; + end Initialize; + + X : Node_Access; + + begin + Allocate_Node (Container.Tree.all, X); + return X; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree.all, + Key, + Position.Node, + Inserted); + end; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + -- k > node same as node < k + + return Right.Key < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Key; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : + not null access procedure (Container : Map; Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Container, (Node => Node)); + end Process_Node; + + B : Natural renames Container.Tree.all.Busy; + + -- Start of processing for Iterate + + begin + 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; + + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Container : Map; Position : Cursor) return Key_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of function Key has no element"; + end if; + + pragma Assert (Vet (Container.Tree.all, Position.Node), + "Position cursor of function Key is bad"); + + return Container.Tree.Nodes (Position.Node).Key; + end Key; + + ---------- + -- Last -- + ---------- + + function Last (Container : Map) return Cursor is + begin + 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; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Tree.Nodes (Last (Container).Node).Element; + end Last_Element; + + -------------- + -- Last_Key -- + -------------- + + function Last_Key (Container : Map) return Key_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Tree.Nodes (Last (Container).Node).Key; + end Last_Key; + + ---------- + -- Left -- + ---------- + + 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; + 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); + end if; + end Left; + + -------------- + -- Left_Son -- + -------------- + + function Left_Son (Node : Node_Type) return Count_Type is + begin + return Node.Left; + end Left_Son; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + if Container.K = Plain then + return Container.Tree.Length; + else + return Container.Length; + end if; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Map; Source : in out Map) is + NN : Tree_Types.Nodes_Type renames Source.Tree.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; + end if; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + if Source.Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + Clear (Target); + + loop + X := First (Source).Node; + exit when X = 0; + + -- Here we insert a copy of the source element into the target, and + -- then delete the element from the source. Another possibility is + -- that delete it first (and hang onto its index), then insert it. + -- ??? + + 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); + end loop; + end Move; + + ---------- + -- 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); + end Next; + + function Next (Container : Map; Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Container.Tree.all, Position.Node), + "bad cursor in Next"); + + return (Node => Next_Unchecked (Container, Position.Node)); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Map) return Boolean is + begin + + 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; + + 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).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); + + else + return True; + end if; + end loop; + end; + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Type) return Count_Type is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Container : Map; Position : in out Cursor) is + begin + Position := Previous (Container, Position); + end Previous; + + function Previous (Container : Map; Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Container.Tree.all, 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); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : in out Map; + Position : Cursor; + Process : not null access 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 + "Position cursor of Query_Element has no element"; + end if; + + pragma Assert (Vet (Container.Tree.all, 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; + + begin + B := B + 1; + L := L + 1; + + declare + N : Node_Type renames T.Nodes (Position.Node); + K : Key_Type renames N.Key; + E : Element_Type renames N.Element; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new Generic_Allocate (Read_Element); + + procedure Read_Elements is + new Tree_Operations.Generic_Read (Allocate); + + ------------------ + -- Read_Element -- + ------------------ + + procedure Read_Element (Node : in out Node_Type) is + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + 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; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + 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 Node_Access := Key_Ops.Find (Container.Tree.all, Key); + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + if Container.Tree.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); + begin + N.Key := Key; + N.Element := New_Item; + end; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + 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 + raise Program_Error with + "attempt to tamper with cursors (map is locked)"; + end if; + + pragma Assert (Vet (Container.Tree.all, Position.Node), + "Position cursor of Replace_Element is bad"); + + Container.Tree.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Map; + Process : + not null access procedure (Container : Map; Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Container, (Node => Node)); + end Process_Node; + + B : Natural renames Container.Tree.Busy; + + -- Start of processing for Reverse_Iterate + + begin + 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; + + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Container : Map; Position : Cursor) return Map 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); + end if; + + if C = Lst then + raise Constraint_Error with + "Position cursor has no element"; + 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; + end loop; + + return (Capacity => Container.Capacity, + K => Part, + Tree => Container.Tree, + Length => L, + First => Position.Node, + Last => Last (Container).Node); + end Right; + + --------------- + -- Right_Son -- + --------------- + + function Right_Son (Node : Node_Type) return Count_Type is + begin + return Node.Right; + end Right_Son; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : in out Node_Type; + Color : Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is + begin + Node.Right := Right; + end Set_Right; + + ------------------ + -- Strict_Equal -- + ------------------ + + function Strict_Equal (Left, Right : Map) return Boolean is + LNode : Count_Type := First (Left).Node; + RNode : Count_Type := First (Right).Node; + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + while LNode = RNode loop + if LNode = 0 then + 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 + exit; + end if; + + LNode := Next_Unchecked (Left, LNode); + RNode := Next_Unchecked (Right, RNode); + end loop; + return False; + end Strict_Equal; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + 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), + "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; + + begin + B := B + 1; + L := L + 1; + + declare + N : Node_Type renames T.Nodes (Position.Node); + K : Key_Type renames N.Key; + E : Element_Type renames N.Element; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Node); + + procedure Write_Nodes is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write_Nodes (Stream, Container.Tree.all); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + +end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads new file mode 100644 index 00000000000..25cb8a743e0 --- /dev/null +++ b/gcc/ada/a-cforma.ads @@ -0,0 +1,252 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Red_Black_Trees; +private with Ada.Streams; +with Ada.Containers; use Ada.Containers; + +generic + type Key_Type is private; + type Element_Type is private; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Formal_Ordered_Maps is + pragma Pure; + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + type Map (Capacity : Count_Type) is tagged private; + -- pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map; + + function Key (Container : Map; Position : Cursor) return Key_Type; + + function Element (Container : Map; Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); + + procedure Delete_First (Container : in out Map); + + procedure Delete_Last (Container : in out Map); + + function First (Container : Map) return Cursor; + + function First_Element (Container : Map) return Element_Type; + + function First_Key (Container : Map) return Key_Type; + + function Last (Container : Map) return Cursor; + + function Last_Element (Container : Map) return Element_Type; + + function Last_Key (Container : Map) return Key_Type; + + function Next (Container : Map; Position : Cursor) return Cursor; + + procedure Next (Container : Map; Position : in out Cursor); + + function Previous (Container : Map; Position : Cursor) return Cursor; + + procedure Previous (Container : Map; Position : in out Cursor); + + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Floor (Container : Map; Key : Key_Type) return Cursor; + + function Ceiling (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function Has_Element (Container : Map; Position : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : + not null access procedure (Container : Map; Position : Cursor)); + + procedure Reverse_Iterate + (Container : Map; + Process : + not null access procedure (Container : Map; Position : Cursor)); + + function Strict_Equal (Left, Right : Map) return Boolean; + + function Left (Container : Map; Position : Cursor) return Map; + + function Right (Container : Map; Position : Cursor) return Map; + + function Overlap (Left, Right : Map) return Boolean; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + subtype Node_Access is Count_Type; + + use Red_Black_Trees; + + type Node_Type is record + Has_Element : Boolean := False; + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + 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; + + 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; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := (Node => 0); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + Empty_Map : constant Map := (Capacity => 0, others => <>); + +end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb new file mode 100644 index 00000000000..30a0f97a31d --- /dev/null +++ b/gcc/ada/a-cforse.adb @@ -0,0 +1,2924 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Formal_Ordered_Sets is + + ------------------------------ + -- Access to Fields of Node -- + ------------------------------ + + -- These subprograms provide functional notation for access to fields + -- of a node, and procedural notation for modifiying these fields. + + function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; + pragma Inline (Color); + + function Left_Son (Node : Node_Type) return Count_Type; + pragma Inline (Left); + + function Parent (Node : Node_Type) return Count_Type; + pragma Inline (Parent); + + function Right_Son (Node : Node_Type) return Count_Type; + pragma Inline (Right); + + procedure Set_Color + (Node : in out Node_Type; + Color : Red_Black_Trees.Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type); + pragma Inline (Set_Left); + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type); + pragma Inline (Set_Right); + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); + pragma Inline (Set_Parent); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (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 Insert_Sans_Hint + (Container : in out Tree_Types.Tree_Type; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean); + + procedure Insert_With_Hint + (Dst_Set : in out Tree_Types.Tree_Type; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Element_Node); + + 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; + Node : Count_Type; + Item : Element_Type); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Bounded_Operations + (Tree_Types, + Left => Left_Son, + Right => Right_Son); + + use Tree_Operations; + + package Element_Keys is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Red_Black_Trees.Generic_Bounded_Set_Operations + (Tree_Operations => Tree_Operations, + Set_Type => Tree_Types.Tree_Type, + Assign => Assign, + Insert_With_Hint => Insert_With_Hint, + Is_Less => Is_Less_Node_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + Lst : Count_Type; + Node : Count_Type := First (Left).Node; + ENode : Count_Type; + begin + + if Length (Left) /= Length (Right) then + return False; + end if; + + if Is_Empty (Left) then + return True; + end if; + + Lst := Next (Left.Tree.all, Last (Left).Node); + while Node /= Lst loop + ENode := Find (Right, Left.Tree.Nodes (Node).Element).Node; + if ENode = 0 or else + Left.Tree.Nodes (Node).Element /= Right.Tree.Nodes (ENode).Element + then + return False; + end if; + Node := Next (Left.Tree.all, Node); + end loop; + + return True; + + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Tree_Types.Tree_Type; + Source : Tree_Types.Tree_Type) is + procedure Append_Element (Source_Node : Count_Type); + + procedure Append_Elements is + new Tree_Operations.Generic_Iteration (Append_Element); + + -------------------- + -- Append_Element -- + -------------------- + + procedure Append_Element (Source_Node : Count_Type) is + SN : Node_Type renames Source.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, 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, + Hint => 0, + Key => SN.Element, + Node => Target_Node); + end Append_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Constraint_Error + with "Target capacity is less than Source length"; + end if; + + Tree_Operations.Clear_Tree (Target); + 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; + + 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; + end if; + + declare + Node : constant Count_Type := + Element_Keys.Ceiling (Container.Tree.all, Item); + + 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); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + 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; + + 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; + Node := Node + 1; + end loop; + + while Node <= Target.Capacity loop + N := Node; + Formal_Ordered_Sets.Free (Tree => Target.Tree.all, 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; + + ------------ + -- Delete -- + ------------ + + 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), + "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, + Position.Node); + Formal_Ordered_Sets.Free (Container.Tree.all, 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); + + 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); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + Tree : Tree_Types.Tree_Type renames Container.Tree.all; + X : constant Count_Type := Tree.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); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + Tree : Tree_Types.Tree_Type renames Container.Tree.all; + X : constant Count_Type := Tree.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); + end if; + end Delete_Last; + + ---------------- + -- Difference -- + ---------------- + + 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; + + 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 + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Length (Left) = 0 then + return Empty_Set; + end if; + + if Length (Right) = 0 then + return Left.Copy; + 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); + + 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; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Position : Cursor) return Element_Type is + begin + 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), + "bad cursor in Element"); + + declare + N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + begin + return N (Position.Node).Element; + end; + end Element; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + function Is_Equivalent_Node_Node + (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is + begin + if L.Element < R.Element then + return False; + elsif R.Element < L.Element then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- 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; + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : constant Count_Type := Element_Keys.Find (Container.Tree.all, 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); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + 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; + + if Item < Container.Tree.Nodes (Container.First).Element or + Container.Tree.Nodes (Container.Last).Element < Item then + return No_Element; + end if; + end if; + + declare + Node : constant Count_Type := + Element_Keys.Find (Container.Tree.all, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Length (Container) = 0 then + return No_Element; + end if; + + if Container.K = Plain then + return (Node => Container.Tree.First); + else + return (Node => Container.First); + end if; + + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + Fst : constant Count_Type := First (Container).Node; + begin + if Fst = 0 then + raise Constraint_Error with "set is empty"; + end if; + + declare + N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + begin + return N (Fst).Element; + end; + end First_Element; + + ----------- + -- Floor -- + ----------- + + 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); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free + (Tree : in out Tree_Types.Tree_Type; + X : Count_Type) + is + begin + Tree.Nodes (X).Has_Element := False; + Tree_Operations.Free (Tree, X); + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate + (Tree : in out Tree_Types.Tree_Type'Class; + Node : out Count_Type) + is + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + begin + Allocate (Tree, Node); + Tree.Nodes (Node).Has_Element := True; + end Generic_Allocate; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + ------------- + -- Ceiling -- + ------------- + + 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; + + if 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.Ceiling (Container.Tree.all, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Ceiling; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + 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); + + 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; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type 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 + raise Constraint_Error with "key not in set"; + end if; + end if; + + declare + Node : constant Count_Type := + Key_Keys.Find (Container.Tree.all, Key); + + 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; + end; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + 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); + + begin + if X /= 0 then + Delete_Node_Sans_Free (Container.Tree.all, X); + Formal_Ordered_Sets.Free (Container.Tree.all, X); + end if; + end; + end Exclude; + + ---------- + -- Find -- + ---------- + + 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); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Find; + + ----------- + -- Floor -- + ----------- + + 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; + + declare + Node : constant Count_Type := + Key_Keys.Floor (Container.Tree.all, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Key (Right.Element) < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Key (Right.Element); + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Container : Set; Position : Cursor) return Key_Type is + begin + 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), + "bad cursor in Key"); + + declare + N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + begin + return Key (N (Position.Node).Element); + end; + end Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Keys.Find (Container.Tree.all, 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); + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + 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), + "bad cursor in Update_Element_Preserving_Key"); + + declare + N : Tree_Types.Nodes_Type renames Container.Tree.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; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if Equivalent_Keys (K, Key (E)) then + return; + end if; + end; + + declare + X : constant Count_Type := Position.Node; + begin + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Formal_Ordered_Sets.Free (Tree, X); + end; + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + 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; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + if Container.Tree.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; + begin + N (Position.Node).Element := New_Item; + end; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + 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; + + Insert_Sans_Hint + (Container.Tree.all, + New_Item, + Position.Node, + Inserted); + + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Container : in out Tree_Types.Tree_Type; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + + procedure Set_Element (Node : in out Node_Type); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Conditional_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Allocate is + new Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + + begin + Allocate (Container, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := New_Item; + end Set_Element; + + -- Start of processing for Insert_Sans_Hint + + begin + Conditional_Insert_Sans_Hint + (Container, + New_Item, + Node, + Inserted); + end Insert_Sans_Hint; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Set : in out Tree_Types.Tree_Type; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type) + is + Success : Boolean; + pragma Unreferenced (Success); + + procedure Set_Element (Node : in out Node_Type); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Insert_Post, + 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 (Dst_Set, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := Src_Node.Element; + end Set_Element; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Set, + Dst_Hint, + Src_Node.Element, + Dst_Node, + Success); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + 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; + end Intersection; + + function Intersection (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left.Copy; + 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; + end return; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean + is + begin + -- Compute e > node same as node < e + + return Right.Element < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Type) return Boolean is + begin + return L.Element < R.Element; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + 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; + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : + not null access procedure (Container : Set; Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + procedure Local_Iterate_Between is + new Iterate_Between (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Container, (Node => Node)); + end Process_Node; + + T : Tree_Types.Tree_Type renames Container.Tree.all; + B : Natural renames T.Busy; + + -- Start of prccessing for Iterate + + begin + 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); + + exception + when others => + B := B - 1; + raise; + end; + + 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 -- + ---------- + + function Last (Container : Set) return Cursor is + begin + 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; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + if Last (Container).Node = 0 then + raise Constraint_Error with "set is empty"; + end if; + + declare + N : Tree_Types.Nodes_Type renames Container.Tree.Nodes; + begin + return N (Last (Container).Node).Element; + end; + end Last_Element; + + ---------- + -- Left -- + ---------- + + 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; + 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); + end if; + end Left; + + -------------- + -- Left_Son -- + -------------- + + function Left_Son (Node : Node_Type) return Count_Type is + begin + return Node.Left; + end Left_Son; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + if Container.K = Plain then + return Container.Tree.Length; + else + return Container.Length; + end if; + end Length; + + ---------- + -- Move -- + ---------- + + 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; + 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; + end if; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + if S.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + Clear (Target); + + loop + X := S.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); + end loop; + end Move; + + ---------- + -- 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 + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Container.Tree.all, Position.Node), + "bad cursor in Next"); + return (Node => Next_Unchecked (Container, Position.Node)); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + 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; + + 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; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Type) return Count_Type is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Container : Set; Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Container.Tree.all, 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); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Previous; + + procedure Previous (Container : Set; Position : in out Cursor) is + begin + Position := Previous (Container, Position); + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : in out Set; + Position : Cursor; + 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), + "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; + + begin + B := B + 1; + L := L + 1; + + begin + Process (T.Nodes (Position.Node).Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new Generic_Allocate (Read_Element); + + procedure Read_Elements is + new Tree_Operations.Generic_Read (Allocate); + + ------------------ + -- Read_Element -- + ------------------ + + procedure Read_Element (Node : in out Node_Type) is + begin + Element_Type'Read (Stream, Node.Element); + 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; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + ------------- + -- Replace -- + ------------- + + 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); + + 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; + + Container.Tree.Nodes (Node).Element := New_Item; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Tree : in out Tree_Types.Tree_Type; + Node : Count_Type; + Item : Element_Type) + is + pragma Assert (Node /= 0); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Local_Insert_Post, + Local_Insert_Sans_Hint); + + NN : Tree_Types.Nodes_Type renames Tree.Nodes; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + N : Node_Type renames NN (Node); + + begin + N.Element := Item; + N.Color := Red; + N.Parent := 0; + N.Right := 0; + N.Left := 0; + + return Node; + end New_Node; + + Hint : Count_Type; + Result : Count_Type; + Inserted : Boolean; + + -- Start of processing for Insert + + begin + if Item < NN (Node).Element + or else NN (Node).Element < Item + then + null; + + else + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is locked)"; + end if; + + NN (Node).Element := Item; + return; + end if; + + Hint := Element_Keys.Ceiling (Tree, Item); + + if Hint = 0 then + null; + + elsif Item < NN (Hint).Element then + if Hint = Node then + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is locked)"; + end if; + + NN (Node).Element := Item; + return; + end if; + + else + pragma Assert (not (NN (Hint).Element < Item)); + raise Program_Error with "attempt to replace existing element"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + + Local_Insert_With_Hint + (Tree => Tree, + Position => Hint, + Key => Item, + Node => Result, + Inserted => Inserted); + + pragma Assert (Inserted); + pragma Assert (Result = Node); + end Replace_Element; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + 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), + "bad cursor in Replace_Element"); + + Replace_Element (Container.Tree.all, Position.Node, New_Item); + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : + not null access procedure (Container : Set; Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Container, (Node => Node)); + end Process_Node; + + T : Tree_Types.Tree_Type renames Container.Tree.all; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + 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; + + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + 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); + end if; + + if C = Lst then + raise Constraint_Error with + "Position cursor has no element"; + 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; + end loop; + + return (Capacity => Container.Capacity, + K => Part, + Tree => Container.Tree, + Length => L, + First => Position.Node, + Last => Last (Container).Node); + end Right; + + --------------- + -- Right_Son -- + --------------- + + function Right_Son (Node : Node_Type) return Count_Type is + begin + return Node.Right; + end Right_Son; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : in out Node_Type; + Color : Red_Black_Trees.Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is + begin + Node.Right := Right; + end Set_Right; + + ------------------ + -- Strict_Equal -- + ------------------ + + function Strict_Equal (Left, Right : Set) return Boolean is + LNode : Count_Type := First (Left).Node; + RNode : Count_Type := First (Right).Node; + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + while LNode = RNode loop + if LNode = 0 then + return True; + end if; + + if Left.Tree.Nodes (LNode).Element /= + Right.Tree.Nodes (RNode).Element then + exit; + end if; + + LNode := Next_Unchecked (Left, LNode); + RNode := Next_Unchecked (Right, RNode); + end loop; + return False; + + end Strict_Equal; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + 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; + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + if Length (Left) = 0 then + return Right.Copy; + 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; + + end return; + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Node : Count_Type; + Inserted : Boolean; + + begin + return S : Set (Capacity => 1) do + Insert_Sans_Hint (S.Tree.all, New_Item, Node, Inserted); + pragma Assert (Inserted); + end return; + end To_Set; + + ----------- + -- Union -- + ----------- + + 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; + end Union; + + function Union (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left.Copy; + end if; + + if Length (Left) = 0 then + return Right.Copy; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + return S : Set (Length (Left) + Length (Right)) do + S.Assign (Source => Left); + S.Union (Right); + end return; + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Element + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Element); + + procedure Write_Elements is + new Tree_Operations.Generic_Write (Write_Element); + + ------------------- + -- Write_Element -- + ------------------- + + procedure Write_Element + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Element; + + -- Start of processing for Write + + begin + Write_Elements (Stream, Container.Tree.all); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + +end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads new file mode 100644 index 00000000000..92c4e93497f --- /dev/null +++ b/gcc/ada/a-cforse.ads @@ -0,0 +1,301 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Red_Black_Trees; +private with Ada.Streams; + +with Ada.Containers; +use Ada.Containers; + +generic + type Element_Type is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Formal_Ordered_Sets is + pragma Pure; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + + type Set (Capacity : Count_Type) is tagged private; + -- pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Equivalent_Sets (Left, Right : Set) return Boolean; + + function To_Set (New_Item : Element_Type) return Set; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set; + + function Element (Container : Set; Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + + procedure Include + (Container : in out Set; + New_Item : Element_Type); + + procedure Replace + (Container : in out Set; + New_Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) return Element_Type; + + function Next (Container : Set; Position : Cursor) return Cursor; + + procedure Next (Container : Set; Position : in out Cursor); + + function Previous (Container : Set; Position : Cursor) return Cursor; + + procedure Previous (Container : Set; Position : in out Cursor); + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Has_Element (Container : Set; Position : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : + not null access procedure (Container : Set; Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : + not null access procedure (Container : Set; Position : Cursor)); + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + package Generic_Keys is + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + function Key (Container : Set; Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Floor (Container : Set; Key : Key_Type) return Cursor; + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + end Generic_Keys; + + function Strict_Equal (Left, Right : Set) return Boolean; + + function Left (Container : Set; Position : Cursor) return Set; + + function Right (Container : Set; Position : Cursor) return Set; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type is record + Has_Element : Boolean := False; + Parent : Count_Type; + Left : Count_Type; + Right : Count_Type; + 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; + + use Red_Black_Trees; + use Ada.Streams; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Node : Count_Type; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := (Node => 0); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := + (Capacity => 0, others => <>); + +end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb new file mode 100644 index 00000000000..fd30ca9cda7 --- /dev/null +++ b/gcc/ada/a-cofove.adb @@ -0,0 +1,2293 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with System; use type System.Address; + +package body Ada.Containers.Formal_Vectors is + + type Int is range System.Min_Int .. System.Max_Int; + type UInt is mod System.Max_Binary_Modulus; + + function Get_Element + (Container : Vector; + Position : Count_Type) return Element_Type; + + --------- + -- "&" -- + --------- + + 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; + end if; + + declare + E : constant Elements_Array (1 .. Length (Right)) := + Right.Plain.Elements (RFst .. RLst); + begin + return (Length (Right), + new Plain_Vector'(Length (Right), E, + Last => Right.Plain.Last, others => <>), + others => <>); + end; + end if; + + if RN = 0 then + declare + E : constant Elements_Array (1 .. Length (Left)) := + Left.Plain.Elements (LFst .. LLst); + begin + return (Length (Left), + new Plain_Vector'(Length (Left), E, + Last => Left.Plain.Last, others => <>), + others => <>); + end; + + end if; + + declare + N : constant Int'Base := Int (LN) + Int (RN); + Last_As_Int : Int'Base; + + begin + if Int (No_Index) > Int'Last - N then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (No_Index) + N; + + if Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + -- TODO: should check whether length > max capacity (cnt_t'last) ??? + + declare + Last : constant Index_Type := Index_Type (Last_As_Int); + + LE : constant Elements_Array (1 .. Length (Left)) := + Left.Plain.Elements (LFst .. LLst); + + RE : Elements_Array renames Right.Plain.Elements (RFst .. RLst); + + Capacity : constant Count_Type := Length (Left) + Length (Right); + + begin + return (Capacity, + new Plain_Vector'(Capacity, LE & RE, + Last => Last, others => <>), + others => <>); + end; + end; + end "&"; + + 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 => <>); + end if; + + if Int (Index_Type'First) > Int'Last - Int (LN) then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (Index_Type'First) + Int (LN); + + if Last_As_Int > Int (Index_Type'Last) then + 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); + + Capacity : constant Count_Type := Length (Left) + 1; + + begin + return (Capacity, + new Plain_Vector'(Capacity, LE & Right, + Last => Last, others => <>), + others => <>); + end; + + end "&"; + + function "&" (Left : Element_Type; Right : Vector) return Vector 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 => <>); + end if; + + if Int (Index_Type'First) > Int'Last - Int (RN) then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (Index_Type'First) + Int (RN); + + if Last_As_Int > Int (Index_Type'Last) then + 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); + + Capacity : constant Count_Type := 1 + Length (Right); + + begin + return (Capacity, + new Plain_Vector'(Capacity, Left & RE, + Last => Last, others => <>), + others => <>); + end; + end "&"; + + function "&" (Left, Right : Element_Type) return Vector is + begin + if Index_Type'First >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + declare + Last : constant Index_Type := Index_Type'First + 1; + + begin + return (2, + new Plain_Vector'(2, (Left, Right), + Last => Last, others => <>), + others => <>); + end; + end "&"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Vector) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + if Length (Left) /= Length (Right) then + return False; + end if; + + for J in Count_Type range 1 .. Length (Left) loop + if Get_Element (Left, J) /= Get_Element (Right, J) then + return False; + end if; + end loop; + + return True; + end "="; + + ------------ + -- Append -- + ------------ + + 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 + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert + (Container, + Container.Plain.Last + 1, + New_Item); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + 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 + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + -- TODO: should check whether length > max capacity (cnt_t'last) ??? + + Insert + (Container, + Container.Plain.Last + 1, + New_Item, + Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) 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; + + if Target.Capacity < LS then + raise Constraint_Error; + end if; + + 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; + + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Capacity_Subtype is + begin + return Container.Plain.Elements'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + 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 + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + Container.Plain.Last := No_Index; + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Capacity_Subtype := 0) return Vector + is + LS : constant Count_Type := Length (Source); + C : Capacity_Subtype; + + begin + if Capacity = 0 then + C := LS; + + elsif Capacity >= LS then + C := Capacity; + + else + raise Constraint_Error; + 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; + + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1) + 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 + raise Constraint_Error with "Index is out of range (too large)"; + end if; + + 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 (vector is busy)"; + end if; + + declare + I_As_Int : constant Int := Int (Index); + Old_Last_As_Int : constant Int := + Index_Type'Pos (Container.Plain.Last); + + Count1 : constant Int'Base := Count_Type'Pos (Count); + Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; + N : constant Int'Base := Int'Min (Count1, Count2); + + J_As_Int : constant Int'Base := I_As_Int + N; + + begin + if J_As_Int > Old_Last_As_Int then + Container.Plain.Last := Index - 1; + + else + declare + EA : Elements_Array renames Container.Plain.Elements; + + II : constant Int'Base := I_As_Int - Int (No_Index); + I : constant Count_Type := Count_Type (II); + + JJ : constant Int'Base := J_As_Int - Int (No_Index); + J : constant Count_Type := Count_Type (JJ); + + New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; + New_Last : constant Index_Type := + Index_Type (New_Last_As_Int); + + KK : constant Int := New_Last_As_Int - Int (No_Index); + K : constant Count_Type := Count_Type (KK); + + begin + EA (I .. K) := EA (J .. Length (Container)); + Container.Plain.Last := New_Last; + end; + end if; + end; + end Delete; + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1) + 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 + raise Program_Error with "Position index is out of range"; + end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1) + 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 Count >= Length (Container) then + Clear (Container); + return; + end if; + + Delete (Container, Index_Type'First, Count); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1) + is + Index : Int'Base; + + 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 + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + Index := Int'Base (Container.Plain.Last) - Int'Base (Count); + + if Index < Index_Type'Pos (Index_Type'First) then + Container.Plain.Last := No_Index; + else + Container.Plain.Last := Index_Type (Index); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + begin + if Index > Container.Plain.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + II : constant Int'Base := Int (Index) - Int (No_Index); + I : constant Count_Type := Count_Type (II); + + 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; + + function Element + (Container : Vector; + Position : Cursor) return Element_Type + is + Lst : constant Index_Type := Last_Index (Container); + begin + if not Position.Valid then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Index > Lst then + raise Constraint_Error with "Position cursor is out of range"; + end if; + + declare + II : constant Int'Base := Int (Position.Index) - Int (No_Index); + I : constant Count_Type := Count_Type (II); + + begin + + return Get_Element (Container, I); + end; + end Element; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + K : Count_Type; + Last : constant Index_Type := Last_Index (Container); + + begin + + if Position.Valid then + if Position.Index > Last_Index (Container) then + raise Program_Error with "Position index is out of range"; + end if; + end if; + + K := Count_Type (Int (Position.Index) - Int (No_Index)); + + for J in Position.Index .. Last loop + if Get_Element (Container, K) = Item then + return Cursor'(Index => J, others => <>); + end if; + K := K + 1; + end loop; + + return No_Element; + + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + K : Count_Type; + Last : constant Index_Type := Last_Index (Container); + + begin + + K := Count_Type (Int (Index) - Int (No_Index)); + for Indx in Index .. Last loop + if Get_Element (Container, K) = Item then + return Indx; + end if; + K := K + 1; + end loop; + + return No_Index; + end Find_Index; + + ----------- + -- First -- + ----------- + + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (True, Index_Type'First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "Container is empty"; + end if; + + return Get_Element (Container, 1); + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : Vector) return Boolean is + Last : constant Index_Type := Last_Index (Container); + begin + + if Container.Plain.Last <= Last then + return True; + end if; + + declare + L : constant Capacity_Subtype := Length (Container); + begin + + for J in Count_Type range 1 .. L - 1 loop + if Get_Element (Container, J + 1) + < Get_Element (Container, J) then + return False; + end if; + end loop; + end; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + 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; + + I, J : Count_Type; + + begin + -- ??? + -- if Target.Last < Index_Type'First then + -- Move (Target => Target, Source => Source); + -- return; + -- end if; + + if Target'Address = Source'Address then + return; + end if; + + if Source.Plain.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 + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + if Source.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + I := Length (Target); + Target.Set_Length (I + Length (Source)); + + J := Length (Target); + while not Source.Is_Empty loop + pragma Assert (Length (Source) <= 1 + or else not (SA (Length (Source)) < + SA (Length (Source) - 1))); + + if I = 0 then + TA (1 .. J) := SA (1 .. Length (Source)); + Source.Plain.Last := No_Index; + return; + end if; + + pragma Assert (I <= 1 + or else not (TA (I) < TA (I - 1))); + + if SA (Length (Source)) < TA (I) then + TA (J) := TA (I); + I := I - 1; + + else + TA (J) := SA (Length (Source)); + Source.Plain.Last := Source.Plain.Last - 1; + end if; + + J := J - 1; + end loop; + end; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) + is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Count_Type, + 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 + return; + end if; + + if Container.Plain.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; + end if; + + Sort (Container.Plain.Elements (1 .. Length (Container))); + end Sort; + + end Generic_Sorting; + + ----------------- + -- Get_Element -- + ----------------- + + function Get_Element + (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); + end Get_Element; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element + (Container : Vector; + Position : Cursor) return Boolean is + begin + if not Position.Valid then + return False; + end if; + + return Position.Index <= Last_Index (Container); + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1) + is + N : constant Int := Count_Type'Pos (Count); + + First : constant Int := Int (Index_Type'First); + New_Last_As_Int : Int'Base; + New_Last : Index_Type; + New_Length : UInt; + Max_Length : constant UInt := UInt (Container.Capacity); + + 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 + then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + + if Count = 0 then + return; + end if; + + declare + Old_Last_As_Int : constant Int := Int (Container.Plain.Last); + + begin + if Old_Last_As_Int > Int'Last - N then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Last_As_Int := Old_Last_As_Int + N; + + if New_Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Length := UInt (New_Last_As_Int - First + Int'(1)); + + if New_Length > Max_Length then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Last := Index_Type (New_Last_As_Int); + + -- Resolve issue of capacity vs. max index ??? + end; + + if Container.Plain.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; + + BB : constant Int'Base := Int (Before) - Int (No_Index); + B : constant Count_Type := Count_Type (BB); + + LL : constant Int'Base := New_Last_As_Int - Int (No_Index); + L : constant Count_Type := Count_Type (LL); + + begin + if Before <= Container.Plain.Last then + declare + II : constant Int'Base := BB + N; + I : constant Count_Type := Count_Type (II); + + begin + EA (I .. L) := EA (B .. Length (Container)); + EA (B .. I - 1) := (others => New_Item); + end; + + else + EA (B .. L) := (others => New_Item); + end if; + end; + + Container.Plain.Last := New_Last; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); + + 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 + then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + + if N = 0 then + return; + end if; + + Insert_Space (Container, Before, Count => N); + + declare + Dst_Last_As_Int : constant Int'Base := + Int (Before) + Int (N) - 1 - Int (No_Index); + + 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); + + return; + end if; + + declare + Src : Elements_Array renames Container.Plain.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); + + begin + Dst := Src; + end; + + if Dst_Last = Length (Container) then + return; + end if; + + declare + Src : Elements_Array renames + Container.Plain.Elements + (Dst_Last + 1 .. Length (Container)); + + Index_As_Int : constant Int'Base := + Dst_Last_As_Int - Src'Length + 1; + + Index : constant Count_Type := Count_Type (Index_As_Int); + + Dst : Elements_Array renames + Container.Plain.Elements (Index .. Dst_Last); + + begin + Dst := Src; + end; + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector) + is + Index : Index_Type'Base; + + 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 + then + if Container.Plain.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Plain.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor) + is + Index : Index_Type'Base; + + 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 + then + Position := No_Element; + else + Position := (True, Before.Index); + end if; + + return; + end if; + + if not Before.Valid + or else Before.Index > Container.Plain.Last + then + if Container.Plain.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Plain.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + + Position := Cursor'(True, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + 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 + then + if Container.Plain.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Plain.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + 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 + then + Position := No_Element; + else + Position := (True, Before.Index); + end if; + + return; + end if; + + if not Before.Valid + or else Before.Index > Container.Plain.Last + then + if Container.Plain.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Plain.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + + Position := Cursor'(True, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + ------------------ + -- Insert_Space -- + ------------------ + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + N : constant Int := Count_Type'Pos (Count); + + First : constant Int := Int (Index_Type'First); + New_Last_As_Int : Int'Base; + New_Last : Index_Type; + New_Length : UInt; + Max_Length : constant UInt := UInt (Count_Type'Last); + + 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 + then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + + if Count = 0 then + return; + end if; + + declare + Old_Last_As_Int : constant Int := Int (Container.Plain.Last); + + begin + if Old_Last_As_Int > Int'Last - N then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Last_As_Int := Old_Last_As_Int + N; + + if New_Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Length := UInt (New_Last_As_Int - First + Int'(1)); + + if New_Length > Max_Length then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Last := Index_Type (New_Last_As_Int); + + -- Resolve issue of capacity vs. max index ??? + end; + + if Container.Plain.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; + + BB : constant Int'Base := Int (Before) - Int (No_Index); + B : constant Count_Type := Count_Type (BB); + + LL : constant Int'Base := New_Last_As_Int - Int (No_Index); + L : constant Count_Type := Count_Type (LL); + + begin + if Before <= Container.Plain.Last then + declare + II : constant Int'Base := BB + N; + I : constant Count_Type := Count_Type (II); + + begin + EA (I .. L) := EA (B .. Length (Container)); + end; + end if; + end; + + Container.Plain.Last := New_Last; + end Insert_Space; + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + 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 + then + Position := No_Element; + else + Position := (True, Before.Index); + end if; + + return; + end if; + + if not Before.Valid + or else Before.Index > Container.Plain.Last + then + if Container.Plain.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Plain.Last + 1; + + else + Index := Before.Index; + end if; + + Insert_Space (Container, Index, Count => Count); + + Position := Cursor'(True, Index); + end Insert_Space; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Vector) return Boolean is + begin + return Last_Index (Container) < Index_Type'First; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Vector; + Process : + not null access procedure (Container : Vector; Position : Cursor)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Plain.Busy; + + begin + B := B + 1; + + begin + for Indx in Index_Type'First .. Last_Index (Container) loop + Process (Container, Cursor'(True, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (True, Last_Index (Container)); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "Container is empty"; + end if; + + return Get_Element (Container, Length (Container)); + end Last_Element; + + ---------------- + -- Last_Index -- + ---------------- + + 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; + end Last_Index; + + ------------ + -- Length -- + ------------ + + function Length (Container : Vector) return Capacity_Subtype is + L : constant Int := Int (Last_Index (Container)); + F : constant Int := Int (Index_Type'First); + N : constant Int'Base := L - F + 1; + + begin + return Capacity_Subtype (N); + end Length; + + ---------- + -- Left -- + ---------- + + function Left (Container : Vector; Position : Cursor) return Vector is + Fst : Count_Type; + 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)); + end if; + + if Position.Index > Last_Index (Container) then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + + return (Container.Capacity, Container.Plain, Part, Fst, + (Position.Index - 1)); + end Left; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Vector; + Source : in out Vector) + is + N : constant Count_Type := Length (Source); + + 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 + raise Program_Error with + "attempt to tamper with elements (Target is busy)"; + end if; + + if Source.Plain.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (Source is busy)"; + end if; + + if N > Target.Capacity then + raise Constraint_Error with -- correct exception here??? + "length of Source is greater than capacity of Target"; + end if; + + -- 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.Plain.Last := Source.Plain.Last; + Source.Plain.Last := No_Index; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Container : Vector; Position : Cursor) return Cursor is + begin + if not Position.Valid then + return No_Element; + end if; + + if Position.Index < Last_Index (Container) then + return (True, Position.Index + 1); + end if; + + return No_Element; + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next (Container : Vector; Position : in out Cursor) is + begin + if not Position.Valid then + return; + end if; + + if Position.Index < Last_Index (Container) then + Position.Index := Position.Index + 1; + else + Position := No_Element; + end if; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out Vector; New_Item : Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, + Index_Type'First, + New_Item, + Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Container : Vector; Position : in out Cursor) is + begin + if not Position.Valid then + return; + end if; + + if Position.Index > Index_Type'First and + Position.Index <= Last_Index (Container) then + Position.Index := Position.Index - 1; + else + Position := No_Element; + end if; + end Previous; + + function Previous (Container : Vector; Position : Cursor) return Cursor is + begin + if not Position.Valid then + return No_Element; + end if; + + if Position.Index > Index_Type'First and + Position.Index <= Last_Index (Container) then + return (True, Position.Index - 1); + end if; + + return No_Element; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + 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; + + begin + if Index > Last_Index (Container) then + raise Constraint_Error with "Index is out of range"; + end if; + + B := B + 1; + L := L + 1; + + declare + II : constant Int'Base := Int (Index) - Int (No_Index); + I : constant Count_Type := Count_Type (II); + + begin + Process (Get_Element (V, I)); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end Query_Element; + + procedure Query_Element + (Container : Vector; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if not Position.Valid then + raise Constraint_Error with "Position cursor has no element"; + end if; + + Query_Element (Container, Position.Index, Process); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector) + is + Length : Count_Type'Base; + Last : Index_Type'Base := No_Index; + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, Length); + + if Length < 0 then + raise Program_Error with "stream appears to be corrupt"; + end if; + + if Length > Container.Capacity then + raise Storage_Error with "not enough capacity"; -- ??? + end if; + + for J in Count_Type range 1 .. Length loop + Last := Last + 1; + Element_Type'Read (Stream, Container.Plain.Elements (J)); + Container.Plain.Last := Last; + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Read; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + 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 + raise Constraint_Error with "Index is out of range"; + end if; + + if Container.Plain.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; + end if; + + declare + II : constant Int'Base := Int (Index) - Int (No_Index); + I : constant Count_Type := Count_Type (II); + + begin + Container.Plain.Elements (I) := New_Item; + end; + end Replace_Element; + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + 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 + raise Constraint_Error with "Position cursor is out of range"; + end if; + + if Container.Plain.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; + end if; + + declare + II : constant Int'Base := Int (Position.Index) - Int (No_Index); + I : constant Count_Type := Count_Type (II); + + begin + Container.Plain.Elements (I) := New_Item; + end; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Vector; + 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; -- ??? + end if; + end Reserve_Capacity; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + 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 + 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; + + begin + I := 1; + J := Length (Container); + while I < J loop + declare + EI : constant Element_Type := E (I); + + begin + E (I) := E (J); + E (J) := EI; + end; + + I := I + 1; + J := J - 1; + end loop; + end; + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Last : Index_Type'Base; + K : Count_Type; + + begin + + if not Position.Valid + or else Position.Index > Last_Index (Container) + then + Last := Last_Index (Container); + else + Last := Position.Index; + end if; + + K := Count_Type (Int (Last) - Int (No_Index)); + for Indx in reverse Index_Type'First .. Last loop + if Get_Element (Container, K) = Item then + return (True, Indx); + end if; + K := K - 1; + end loop; + + return No_Element; + end Reverse_Find; + + ------------------------ + -- Reverse_Find_Index -- + ------------------------ + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + Last : Index_Type'Base; + K : Count_Type; + + begin + if Index > Last_Index (Container) then + Last := Last_Index (Container); + else + Last := Index; + end if; + + K := Count_Type (Int (Last) - Int (No_Index)); + for Indx in reverse Index_Type'First .. Last loop + if Get_Element (Container, K) = Item then + return Indx; + end if; + K := K - 1; + end loop; + + return No_Index; + end Reverse_Find_Index; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Vector; + Process : + not null access procedure (Container : Vector; Position : Cursor)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Plain.Busy; + + begin + B := B + 1; + + begin + for Indx in reverse Index_Type'First .. Last_Index (Container) loop + Process (Container, Cursor'(True, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Container : Vector; Position : Cursor) return Vector is + Fst : Count_Type; + 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, No_Index); + end if; + + if Position.Index > Last_Index (Container) then + raise Constraint_Error with + "Position index is out of range (too large)"; + 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)); + end Right; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length + (Container : in out Vector; + 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 + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + if Length > Container.Capacity then + raise Constraint_Error; -- ??? + end if; + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Length) - 1; + begin + Container.Plain.Last := Index_Type'Base (Last_As_Int); + end; + end Set_Length; + + ---------- + -- Swap -- + ---------- + + 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 + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Plain.Last then + raise Constraint_Error with "J index is out of range"; + end if; + + if I = J then + return; + end if; + + if Container.Plain.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; + end if; + + declare + 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_Copy : constant Element_Type := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + 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"; + end if; + + if not J.Valid then + raise Constraint_Error with "J cursor has no element"; + end if; + + Swap (Container, I.Index, J.Index); + end Swap; + + --------------- + -- To_Cursor -- + --------------- + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor + is + begin + if Index not in Index_Type'First .. Last_Index (Container) then + return No_Element; + end if; + + return Cursor'(True, Index); + end To_Cursor; + + -------------- + -- To_Index -- + -------------- + + function To_Index (Position : Cursor) return Extended_Index is + begin + if not Position.Valid then + return No_Index; + end if; + + return Position.Index; + end To_Index; + + --------------- + -- To_Vector -- + --------------- + + function To_Vector (Length : Capacity_Subtype) return Vector is + begin + if Length = 0 then + return Empty_Vector; + end if; + + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : Index_Type; + + begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; -- ??? + end if; + + Last := Index_Type (Last_As_Int); + + return (Length, + new Plain_Vector'(Length, (others => <>), Last => Last, + others => <>), + others => <>); + end; + end To_Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Capacity_Subtype) return Vector + is + begin + if Length = 0 then + return Empty_Vector; + end if; + + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : Index_Type; + + begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; -- ??? + end if; + + Last := Index_Type (Last_As_Int); + + return (Length, + new Plain_Vector'(Length, (others => New_Item), Last => Last, + others => <>), + others => <>); + end; + end To_Vector; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Vector; + 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; + + begin + if Container.K /= Plain then + raise Constraint_Error + with "Can't modify part of container"; + end if; + + if Index > Container.Plain.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + B := B + 1; + L := L + 1; + + declare + II : constant Int'Base := Int (Index) - Int (No_Index); + I : constant Count_Type := Count_Type (II); + + begin + Process (Container.Plain.Elements (I)); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end Update_Element; + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if not Position.Valid then + raise Constraint_Error with "Position cursor has no element"; + end if; + + Update_Element (Container, Position.Index, Process); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector) + is + begin + Count_Type'Base'Write (Stream, Length (Container)); + + for J in 1 .. Length (Container) loop + Element_Type'Write (Stream, Container.Plain.Elements (J)); + end loop; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Write; + +end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads new file mode 100644 index 00000000000..d8e87f6695a --- /dev/null +++ b/gcc/ada/a-cofove.ads @@ -0,0 +1,396 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +private with Ada.Streams; +with Ada.Containers; +use Ada.Containers; + +generic + type Index_Type is range <>; + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Formal_Vectors is + pragma Pure; + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + + -- ??? i don't think we can do this... + -- TODO: we need the ARG to either figure out how to declare this subtype, + -- or eliminate the requirement that it be present. + -- subtype Capacity_Subtype is Count_Type -- correct name??? + -- range 0 .. Count_Type'Max (0, + -- Index_Type'Pos (Index_Type'Last) - + -- Index_Type'Pos (Index_Type'First) + 1); + -- + -- so for now: + subtype Capacity_Subtype is Count_Type; + + No_Index : constant Extended_Index := Extended_Index'First; + + type Vector (Capacity : Capacity_Subtype) is tagged private; + -- pragma Preelaborable_Initialization (Vector); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + function "=" (Left, Right : Vector) return Boolean; + + function To_Vector (Length : Capacity_Subtype) return Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Capacity_Subtype) return Vector; + + function "&" (Left, Right : Vector) return Vector; + + function "&" (Left : Vector; Right : Element_Type) return Vector; + + function "&" (Left : Element_Type; Right : Vector) return Vector; + + function "&" (Left, Right : Element_Type) return Vector; + + function Capacity (Container : Vector) return Capacity_Subtype; + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Capacity_Subtype); + + function Length (Container : Vector) return Capacity_Subtype; + + procedure Set_Length + (Container : in out Vector; + Length : Capacity_Subtype); + + function Is_Empty (Container : Vector) return Boolean; + + procedure Clear (Container : in out Vector); + + procedure Assign (Target : in out Vector; Source : Vector); + + function Copy + (Source : Vector; + Capacity : Capacity_Subtype := 0) return Vector; + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor; + + function To_Index (Position : Cursor) return Extended_Index; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type; + + function Element (Container : Vector; Position : Cursor) + return Element_Type; + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type); + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)); + + procedure Query_Element + (Container : Vector; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Move (Target : in out Vector; Source : in out Vector); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Vector); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out Vector; + New_Item : Vector); + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out Vector); + + procedure Swap (Container : in out Vector; I, J : Index_Type); + + procedure Swap (Container : in out Vector; I, J : Cursor); + + function First_Index (Container : Vector) return Index_Type; + + function First (Container : Vector) return Cursor; + + function First_Element (Container : Vector) return Element_Type; + + function Last_Index (Container : Vector) return Extended_Index; + + function Last (Container : Vector) return Cursor; + + function Last_Element (Container : Vector) return Element_Type; + + function Next (Container : Vector; Position : Cursor) return Cursor; + + procedure Next (Container : Vector; Position : in out Cursor); + + function Previous (Container : Vector; Position : Cursor) return Cursor; + + procedure Previous (Container : Vector; Position : in out Cursor); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index; + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index; + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean; + + function Has_Element (Container : Vector; Position : Cursor) return Boolean; + + procedure Iterate + (Container : Vector; + Process : + not null access procedure (Container : Vector; Position : Cursor)); + + procedure Reverse_Iterate + (Container : Vector; + Process : + not null access procedure (Container : Vector; Position : Cursor)); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target : in out Vector; Source : in out Vector); + + end Generic_Sorting; + + function Left (Container : Vector; Position : Cursor) return Vector; + + function Right (Container : Vector; Position : Cursor) return Vector; + +private + + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Query_Element); + pragma Inline (Update_Element); + pragma Inline (Replace_Element); + pragma Inline (Contains); + pragma Inline (Next); + pragma Inline (Previous); + + 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 + 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 + (Stream : not null access Root_Stream_Type'Class; + Container : Vector); + + for Vector'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector); + + for Vector'Read use Read; + + type Cursor is record + Valid : Boolean := True; + Index : Index_Type := Index_Type'First; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + + Empty_Vector : constant Vector := (Capacity => 0, others => <>); + + No_Element : constant Cursor := (Valid => False, Index => Index_Type'First); + +end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index dcc1159cffe..59babb14581 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -224,19 +224,6 @@ package body Errout is end if; end Change_Error_Text; - ------------------------------ - -- Check_Formal_Restriction -- - ------------------------------ - - procedure Check_Formal_Restriction (Msg : String; N : Node_Id) is - begin - if Formal_Verification_Mode - and then Comes_From_Source (Original_Node (N)) - then - Error_Msg_F ("|~~" & Msg, N); - end if; - end Check_Formal_Restriction; - ------------------------ -- Compilation_Errors -- ------------------------ diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 933f58dad5e..57b8efe0abb 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -740,13 +740,6 @@ package Errout is -- the given text. This text may contain insertion characters in the -- usual manner, and need not be the same length as the original text. - procedure Check_Formal_Restriction (Msg : String; N : Node_Id); - -- Provides a wrappper on Error_Msg_F which prepends the special characters - -- "|~~" (error not serious, language prepended) provided: - -- * the current mode is formal verification. - -- * the node N comes originally from source. - -- Otherwise, does nothing. - function First_Node (C : Node_Id) return Node_Id; -- Given a construct C, finds the first node in the construct, i.e. the -- one with the lowest Sloc value. This is useful in placing error msgs. diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 85ae7055fcd..788afa4c18b 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -512,7 +512,13 @@ package body Impunit is "a-cborse", -- Ada.Containers.Bounded_Ordered_Sets "a-cborma", -- Ada.Containers.Bounded_Ordered_Maps "a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets - "a-cbhama"); -- Ada.Containers.Bounded_Hashed_Maps + "a-cbhama", -- Ada.Containers.Bounded_Hashed_Maps + "a-cofove", -- Ada.Containers.Formal_Vectors + "a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists + "a-cforse", -- Ada.Containers.Formal_Ordered_Sets + "a-cforma", -- Ada.Containers.Formal_Ordered_Maps + "a-cfhase", -- Ada.Containers.Formal_Hashed_Sets + "a-cfhama"); -- Ada.Containers.Formal_Hashed_Maps ----------------------- -- Alternative Units -- diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 755aabc154d..42746f111ca 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -105,6 +105,19 @@ package body Restrict is Check_Restriction (No_Elaboration_Code, N); end Check_Elaboration_Code_Allowed; + ------------------------------ + -- Check_Formal_Restriction -- + ------------------------------ + + procedure Check_Formal_Restriction (Msg : String; N : Node_Id) is + begin + if Formal_Verification_Mode + and then Comes_From_Source (Original_Node (N)) + then + Error_Msg_F ("|~~" & Msg, N); + end if; + end Check_Formal_Restriction; + ----------------------------------------- -- Check_Implicit_Dynamic_Code_Allowed -- ----------------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 50d5427895c..a13326ca831 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -219,6 +219,12 @@ package Restrict is -- an elaboration routine. If elaboration code is not allowed, an error -- message is posted on the node given as argument. + procedure Check_Formal_Restriction (Msg : String; N : Node_Id); + -- Provides a wrappper on Error_Msg_F which prepends the special characters + -- "|~~" (error not serious, language prepended) provided the current mode + -- is formal verification and the node N comes originally from source. + -- Otherwise, does nothing. + procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id); -- Tests to see if dynamic code generation (dynamically generated -- trampolines, in particular) is allowed by the current restrictions diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 82025542ef6..2835caf0b41 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -40,6 +40,7 @@ with Namet.Sp; use Namet.Sp; with Nmake; use Nmake; with Nlists; use Nlists; with Opt; use Opt; +with Restrict; use Restrict; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; @@ -1098,10 +1099,11 @@ package body Sem_Aggr is end if; -- An unqualified aggregate is restricted in SPARK or ALFA to: - -- * an 'aggregate item' inside an aggregate for a multi-dimensional - -- array. - -- * an expression being assigned to an unconstrained array, but only - -- if the aggregate specifies a value for OTHERS only. + + -- An aggregate item inside an aggregate for a multi-dimensional array + + -- An expression being assigned to an unconstrained array, but only if + -- the aggregate specifies a value for OTHERS only. if Nkind (Parent (N)) /= N_Qualified_Expression then if Is_Array_Type (Etype (N)) then @@ -1114,7 +1116,7 @@ package body Sem_Aggr is end if; -- The following check is disabled until a proper place is - -- found where the type of the parent node can be inspected. + -- found where the type of the parent node can be inspected??? -- elsif not (Nkind (Parent (N)) = N_Aggregate -- and then Is_Array_Type (Etype (Parent (N))) @@ -1130,10 +1132,12 @@ package body Sem_Aggr is Check_Formal_Restriction ("record aggregate should be qualified", N); - -- The type of aggregate is neither array nor record, so an error - -- must have occurred during resolution. Do not report an - -- additional message here. + -- The type of aggregate is neither array nor record, so an error + -- must have occurred during resolution. Do not report an additional + -- message here. + else + null; end if; end if; @@ -1145,8 +1149,7 @@ package body Sem_Aggr is if Raises_Constraint_Error (N) then Aggr_Subtyp := Etype (N); Rewrite (N, - Make_Raise_Constraint_Error (Loc, - Reason => CE_Range_Check_Failed)); + Make_Raise_Constraint_Error (Loc, Reason => CE_Range_Check_Failed)); Set_Raises_Constraint_Error (N); Set_Etype (N, Aggr_Subtyp); Set_Analyzed (N); @@ -3112,9 +3115,9 @@ package body Sem_Aggr is begin -- A record aggregate is restricted in SPARK or ALFA: - -- * each named association can have only a single choice. - -- * OTHERS cannot be used. - -- * positional and named associations cannot be mixed. + -- Each named association can have only a single choice. + -- OTHERS cannot be used. + -- Positional and named associations cannot be mixed. if Present (Component_Associations (N)) and then Present (First (Component_Associations (N))) @@ -3128,19 +3131,21 @@ package body Sem_Aggr is declare Assoc : Node_Id; + begin Assoc := First (Component_Associations (N)); - while Present (Assoc) loop if List_Length (Choices (Assoc)) > 1 then Check_Formal_Restriction ("component association in record aggregate must " & "contain a single choice", Assoc); end if; + if Nkind (First (Choices (Assoc))) = N_Others_Choice then Check_Formal_Restriction ("record aggregate cannot contain OTHERS", Assoc); end if; + Assoc := Next (Assoc); end loop; end; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e688485fb59..08a08d8f68e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4966,6 +4966,7 @@ package body Sem_Ch12 is else Check_Private_View (Subtype_Indication (Parent (E))); end if; + Set_Is_Generic_Actual_Type (E, True); Set_Is_Hidden (E, False); Set_Is_Potentially_Use_Visible (E, @@ -5054,6 +5055,63 @@ package body Sem_Ch12 is Set_Is_Hidden (E, False); end if; + if Ekind (E) = E_Constant then + + -- If the type of the actual is a private type declared in the + -- enclosing scope of the generic unit, the body of the generic + -- sees the full view of the type (because it has to appear in + -- the corresponding package body). If the type is private now, + -- exchange views to restore the proper visiblity in the instance. + + declare + Typ : constant Entity_Id := Base_Type (Etype (E)); + -- The type of the actual + + Gen_Id : Entity_Id; + -- The generic unit + + Parent_Scope : Entity_Id; + -- The enclosing scope of the generic unit + + begin + if Is_Wrapper_Package (Instance) then + Gen_Id := + Generic_Parent + (Specification + (Unit_Declaration_Node + (Related_Instance (Instance)))); + else + Gen_Id := + Generic_Parent + (Specification (Unit_Declaration_Node (Instance))); + end if; + + Parent_Scope := Scope (Gen_Id); + + -- The exchange is only needed if the generic is defined + -- within a package which is not a common ancestor of the + -- scope of the instance, and is not already in scope. + + if Is_Private_Type (Typ) + and then Scope (Typ) = Parent_Scope + and then Scope (Instance) /= Parent_Scope + and then Ekind (Parent_Scope) = E_Package + and then not Is_Child_Unit (Gen_Id) + then + Switch_View (Typ); + + -- If the type of the entity is a subtype, it may also + -- have to be made visible, together with the base type + -- of its full view, after exchange. + + if Is_Private_Type (Etype (E)) then + Switch_View (Etype (E)); + Switch_View (Base_Type (Etype (E))); + end if; + end if; + end; + end if; + Next_Entity (E); end loop; end Check_Generic_Actuals; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 7d960c82b3a..65880d5604e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -36,6 +36,7 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; @@ -1860,8 +1861,9 @@ package body Sem_Ch5 is -- SPARK or ALFA. if Nkind (DS) = N_Range then - Check_Formal_Restriction ("loop parameter specification " - & "must include subtype mark", N); + Check_Formal_Restriction + ("loop parameter specification must include subtype mark", + N); end if; -- Now analyze the subtype definition. If it is a range, create diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 964b3f83210..14824ca385b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -40,6 +40,7 @@ with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; with Output; use Output; with Opt; use Opt; +with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; |
