diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-06-16 08:56:24 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-06-16 08:56:24 +0000 |
commit | ca64eb07de27f9c20b0b5b909f314afaae888e81 (patch) | |
tree | 60bbc3a40631ce4a825ff74330cd04720cf0d624 /gcc/ada/a-coinve.adb | |
parent | d25effa88fc45b26bb1ac6135a42785ddb699037 (diff) | |
download | gcc-ca64eb07de27f9c20b0b5b909f314afaae888e81.tar.gz |
2005-06-14 Matthew Heaney <heaney@adacore.com>
* a-swunha.ads, a-swunha.adb: Removed. Replaced by a-swuwha.ad[sb]
* a-swuwha.ads, a-swuwha.adb: New files
* a-szunha.ads, a-szunha.adb: Removed, replaced by a-szuzha.ad[sb]
* a-szuzha.ads, a-szuzha.adb: New files.
* a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads,
a-crbtgk.adb, a-crbltr.ads, a-coorse.ads, a-coorse.adb, a-convec.ads,
a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohata.ads, a-cohama.ads,
a-cohama.adb, a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb,
a-cidlli.ads, a-cidlli.adb, a-chtgop.ads, a-chtgop.adb, a-cdlili.ads,
a-cdlili.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cohase.adb,
a-cohase.ads, a-ciorma.ads, a-coorma.ads, a-ciormu.ads, a-coormu.ads,
a-swunha.adb, a-stunha.adb, a-ciorma.adb, a-coorma.adb, a-shcain.ads,
a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads, a-stwiha.adb,
a-strhas.adb, a-stzhas.adb: synchronized to the latest version of the
Ada 2005 RM.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@101069 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/a-coinve.adb')
-rw-r--r-- | gcc/ada/a-coinve.adb | 3027 |
1 files changed, 1600 insertions, 1427 deletions
diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index c997430f6f0..39ef4e5f190 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_VECTORS -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 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 -- @@ -39,209 +39,272 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is - type Int is range System.Min_Int .. System.Max_Int; procedure Free is - new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); + new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); procedure Free is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - - procedure Adjust (Container : in out Vector) is - begin - - if Container.Elements = null then - return; - end if; + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - if Container.Elements'Length = 0 - or else Container.Last < Index_Type'First - then - Container.Elements := null; - return; - end if; + --------- + -- "&" -- + --------- - declare - E : Elements_Type renames Container.Elements.all; - L : constant Index_Type := Container.Last; - begin - - Container.Elements := null; - Container.Last := Index_Type'Pred (Index_Type'First); - - Container.Elements := new Elements_Type (Index_Type'First .. L); - - for I in Container.Elements'Range loop - - if E (I) /= null then - Container.Elements (I) := new Element_Type'(E (I).all); - end if; + function "&" (Left, Right : Vector) return Vector is + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); - Container.Last := I; + begin + if LN = 0 then + if RN = 0 then + return Empty_Vector; + end if; - end loop; + declare + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); - end; + Elements : Elements_Access := + new Elements_Type (RE'Range); - end Adjust; + begin + for I in Elements'Range loop + begin + if RE (I) /= null then + Elements (I) := new Element_Type'(RE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + Free (Elements); + raise; + end; + end loop; - procedure Finalize (Container : in out Vector) is + return (Controlled with Elements, Right.Last, 0, 0); + end; - E : Elements_Access := Container.Elements; - L : constant Index_Type'Base := Container.Last; + end if; - begin + if RN = 0 then + declare + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); - Container.Elements := null; - Container.Last := Index_Type'Pred (Index_Type'First); + Elements : Elements_Access := + new Elements_Type (LE'Range); - for I in Index_Type'First .. L loop - Free (E (I)); - end loop; + begin + for I in Elements'Range loop + begin + if LE (I) /= null then + Elements (I) := new Element_Type'(LE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; - Free (E); + Free (Elements); + raise; + end; + end loop; - end Finalize; + return (Controlled with Elements, Left.Last, 0, 0); + end; + end if; + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (LN) + Int (RN) - 1; - procedure Write - (Stream : access Root_Stream_Type'Class; - Container : in Vector) is + Last : constant Index_Type := Index_Type (Last_As_Int); - N : constant Count_Type := Length (Container); + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); - begin + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); - Count_Type'Base'Write (Stream, N); + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); - if N = 0 then - return; - end if; + I : Index_Type'Base := Index_Type'Pred (Index_Type'First); - declare - E : Elements_Type renames Container.Elements.all; begin - for I in Index_Type'First .. Container.Last loop - - -- There's another way to do this. Instead a separate - -- Boolean for each element, you could write a Boolean - -- followed by a count of how many nulls or non-nulls - -- follow in the array. Alternately you could use a - -- signed integer, and use the sign as the indicator - -- or null-ness. + for LI in LE'Range loop + I := Index_Type'Succ (I); - if E (I) = null then - Boolean'Write (Stream, False); - else - Boolean'Write (Stream, True); - Element_Type'Output (Stream, E (I).all); - end if; + begin + if LE (LI) /= null then + Elements (I) := new Element_Type'(LE (LI).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + Free (Elements); + raise; + end; end loop; - end; - end Write; + for RI in RE'Range loop + I := Index_Type'Succ (I); + begin + if RE (RI) /= null then + Elements (I) := new Element_Type'(RE (RI).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; - procedure Read - (Stream : access Root_Stream_Type'Class; - Container : out Vector) is + Free (Elements); + raise; + end; + end loop; - Length : Count_Type'Base; - Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; - B : Boolean; + function "&" (Left : Vector; Right : Element_Type) return Vector is + LN : constant Count_Type := Length (Left); begin + if LN = 0 then + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. Index_Type'First); - Clear (Container); - - Count_Type'Base'Read (Stream, Length); - - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; - - for I in Count_Type range 1 .. Length loop - - Last := Index_Type'Succ (Last); - - Boolean'Read (Stream, B); - - if B then - Container.Elements (Last) := - new Element_Type'(Element_Type'Input (Stream)); - end if; - - Container.Last := Last; - - end loop; - - end Read; - + Elements : Elements_Access := new Elements_Subtype; - function To_Vector (Length : Count_Type) return Vector is - begin + begin + begin + Elements (Elements'First) := new Element_Type'(Right); + exception + when others => + Free (Elements); + raise; + end; - if Length = 0 then - return Empty_Vector; + return (Controlled with Elements, Index_Type'First, 0, 0); + end; end if; declare - - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := - First + Int (Length) - 1; + Int (Index_Type'First) + Int (LN); - Last : constant Index_Type := - Index_Type (Last_As_Int); + Last : constant Index_Type := Index_Type (Last_As_Int); - Elements : constant Elements_Access := - new Elements_Type (Index_Type'First .. Last); + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); - begin + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); - return (Controlled with Elements, Last); + begin + for I in LE'Range loop + begin + if LE (I) /= null then + Elements (I) := new Element_Type'(LE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; - end; + Free (Elements); + raise; + end; + end loop; - end To_Vector; + begin + Elements (Elements'Last) := new Element_Type'(Right); + exception + when others => + declare + subtype J_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Pred (Elements'Last); + begin + for J in J_Subtype loop + Free (Elements (J)); + end loop; + end; + Free (Elements); + raise; + end; + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector is + function "&" (Left : Element_Type; Right : Vector) return Vector is + RN : constant Count_Type := Length (Right); begin + if RN = 0 then + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. Index_Type'First); - if Length = 0 then - return Empty_Vector; - end if; + Elements : Elements_Access := new Elements_Subtype; - declare + begin + begin + Elements (Elements'First) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; - First : constant Int := Int (Index_Type'First); + return (Controlled with Elements, Index_Type'First, 0, 0); + end; + end if; + declare Last_As_Int : constant Int'Base := - First + Int (Length) - 1; + Int (Index_Type'First) + Int (RN); + + Last : constant Index_Type := Index_Type (Last_As_Int); - Last : constant Index_Type := - Index_Type (Last_As_Int); + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Last); + new Elements_Type (Index_Type'First .. Last); + + I : Index_Type'Base := Index_Type'First; begin + begin + Elements (I) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; - for I in Elements'Range loop + for RI in RE'Range loop + I := Index_Type'Succ (I); begin - Elements (I) := new Element_Type'(New_Item); + if RE (RI) /= null then + Elements (I) := new Element_Type'(RE (RI).all); + end if; exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop @@ -251,19 +314,45 @@ package body Ada.Containers.Indefinite_Vectors is Free (Elements); raise; end; - end loop; - return (Controlled with Elements, Last); + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; + + function "&" (Left, Right : Element_Type) return Vector is + subtype IT is Index_Type'Base range + Index_Type'First .. Index_Type'Succ (Index_Type'First); + Elements : Elements_Access := new Elements_Type (IT); + + begin + begin + Elements (Elements'First) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; end; - end To_Vector; + begin + Elements (Elements'Last) := new Element_Type'(Right); + exception + when others => + Free (Elements (Elements'First)); + Free (Elements); + raise; + end; + return (Controlled with Elements, Elements'Last, 0, 0); + end "&"; + + --------- + -- "=" -- + --------- function "=" (Left, Right : Vector) return Boolean is begin - if Left'Address = Right'Address then return True; end if; @@ -272,8 +361,7 @@ package body Ada.Containers.Indefinite_Vectors is return False; end if; - for I in Index_Type'First .. Left.Last loop - + for J in Index_Type'First .. Left.Last loop -- NOTE: -- I think it's a bounded error to read or otherwise manipulate -- an "empty" element, which here means that it has the value @@ -285,396 +373,719 @@ package body Ada.Containers.Indefinite_Vectors is -- you have a contrary argument then let me know. -- END NOTE. - if Left.Elements (I) = null then - - if Right.Elements (I) /= null then + if Left.Elements (J) = null then + if Right.Elements (J) /= null then return False; end if; - elsif Right.Elements (I) = null then - + elsif Right.Elements (J) = null then return False; - elsif Left.Elements (I).all /= Right.Elements (I).all then - + elsif Left.Elements (J).all /= Right.Elements (J).all then return False; end if; - end loop; return True; - end "="; + ------------ + -- Adjust -- + ------------ - function Length (Container : Vector) return Count_Type is - - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - - N : constant Int'Base := L - F + 1; + procedure Adjust (Container : in out Vector) is begin - return Count_Type (N); - end Length; + if Container.Elements = null then + return; + end if; + if Container.Elements'Length = 0 + or else Container.Last < Index_Type'First + then + Container.Elements := null; + return; + end if; - function Is_Empty (Container : Vector) return Boolean is - begin - return Container.Last < Index_Type'First; - end Is_Empty; + declare + E : Elements_Type renames Container.Elements.all; + L : constant Index_Type := Container.Last; + begin + Container.Elements := null; + Container.Last := No_Index; + Container.Busy := 0; + Container.Lock := 0; + Container.Elements := new Elements_Type (Index_Type'First .. L); - procedure Set_Length - (Container : in out Vector; - Length : in Count_Type) is + for I in Container.Elements'Range loop + if E (I) /= null then + Container.Elements (I) := new Element_Type'(E (I).all); + end if; - N : constant Count_Type := Indefinite_Vectors.Length (Container); + Container.Last := I; + end loop; + end; + end Adjust; - begin + ------------ + -- Append -- + ------------ - if Length = N then + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if Is_Empty (New_Item) then return; end if; - if Length = 0 then - Clear (Container); + Insert + (Container, + Index_Type'Succ (Container.Last), + New_Item); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + if Count = 0 then return; end if; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Length) - 1; + Insert + (Container, + Index_Type'Succ (Container.Last), + New_Item, + Count); + end Append; - Last : constant Index_Type := - Index_Type (Last_As_Int); - begin + ------------ + -- Assign -- + ------------ - if Length > N then + procedure Assign + (Target : in out Vector; + Source : Vector) + is + N : constant Count_Type := Length (Source); - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; + begin + if Target'Address = Source'Address then + return; + end if; - Container.Last := Last; + Clear (Target); - return; + if N = 0 then + return; + end if; - end if; + if N > Capacity (Target) then + Reserve_Capacity (Target, Capacity => N); + end if; - for I in reverse Index_Type'Succ (Last) .. Container.Last loop + for J in Index_Type'First .. Source.Last loop + declare + EA : constant Element_Access := Source.Elements (J); + begin + if EA /= null then + Target.Elements (J) := new Element_Type'(EA.all); + end if; + end; - declare - X : Element_Access := Container.Elements (I); - begin - Container.Elements (I) := null; - Container.Last := Index_Type'Pred (Container.Last); - Free (X); - end; + Target.Last := J; + end loop; + end Assign; - end loop; + -------------- + -- Capacity -- + -------------- - end; + function Capacity (Container : Vector) return Count_Type is + begin + if Container.Elements = null then + return 0; + end if; - end Set_Length; + return Container.Elements'Length; + end Capacity; + ----------- + -- Clear -- + ----------- procedure Clear (Container : in out Vector) is begin + if Container.Busy > 0 then + raise Program_Error; + end if; - for I in reverse Index_Type'First .. Container.Last loop - + for J in reverse Index_Type'First .. Container.Last loop declare - X : Element_Access := Container.Elements (I); + X : Element_Access := Container.Elements (J); begin - Container.Elements (I) := null; - Container.Last := Index_Type'Pred (I); + Container.Elements (J) := null; + Container.Last := Index_Type'Pred (J); Free (X); end; - end loop; - end Clear; + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ------------ + -- Delete -- + ------------ - procedure Append (Container : in out Vector; - New_Item : in Element_Type; - Count : in Count_Type := 1) is + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1) + is begin + if Index < Index_Type'First then + raise Constraint_Error; + end if; + + if Index > Container.Last then + if Index > Container.Last + 1 then + raise Constraint_Error; + end if; + + return; + end if; + if Count = 0 then return; end if; - Insert - (Container, - Index_Type'Succ (Container.Last), - New_Item, - Count); - end Append; + if Container.Busy > 0 then + raise Program_Error; + end if; + declare + I_As_Int : constant Int := Int (Index); - procedure Insert - (Container : in out Vector; - Before : in Extended_Index; - New_Item : in Element_Type; - Count : in Count_Type := 1) is + Old_Last_As_Int : constant Int := Int (Container.Last); - Old_Last_As_Int : constant Int := Int (Container.Last); + Count1 : constant Int'Base := Int (Count); + Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; - N : constant Int := Int (Count); + N : constant Int'Base := Int'Min (Count1, Count2); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; + J_As_Int : constant Int'Base := I_As_Int + N; + J : constant Index_Type'Base := Index_Type'Base (J_As_Int); - New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + E : Elements_Type renames Container.Elements.all; - Index : Index_Type; + New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; - Dst_Last : Index_Type; - Dst : Elements_Access; + New_Last : constant Extended_Index := + Extended_Index (New_Last_As_Int); + + begin + for K in Index .. Index_Type'Pred (J) loop + declare + X : Element_Access := E (K); + begin + E (K) := null; + Free (X); + end; + end loop; + + E (Index .. New_Last) := E (J .. Container.Last); + Container.Last := New_Last; + end; + end Delete; + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1) + is begin + if Position.Container = null then + raise Constraint_Error; + end if; - if Count = 0 then - return; + if Position.Container /= + Vector_Access'(Container'Unchecked_Access) + or else Position.Index > Container.Last + then + raise Program_Error; end if; - declare - subtype Before_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Container.Last); + Delete (Container, Position.Index, Count); - Old_First : constant Before_Subtype := Before; + if Position.Index <= Container.Last then + Position := (Container'Unchecked_Access, Position.Index); + else + Position := No_Element; + end if; + end Delete; - Old_First_As_Int : constant Int := Int (Old_First); + ------------------ + -- Delete_First -- + ------------------ - New_First_As_Int : constant Int'Base := Old_First_As_Int + N; - begin - Index := Index_Type (New_First_As_Int); - end; + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; - if Container.Elements = null then + if Count >= Length (Container) then + Clear (Container); + return; + end if; - declare - subtype Elements_Subtype is - Elements_Type (Index_Type'First .. New_Last); - begin - Container.Elements := new Elements_Subtype; - Container.Last := Index_Type'Pred (Index_Type'First); + Delete (Container, Index_Type'First, Count); + end Delete_First; - for I in Container.Elements'Range loop - Container.Elements (I) := new Element_Type'(New_Item); - Container.Last := I; - end loop; - end; + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1) + is + Index : Int'Base; + begin + if Count = 0 then return; + end if; + if Count >= Length (Container) then + Clear (Container); + return; end if; - if New_Last <= Container.Elements'Last then + Index := Int'Base (Container.Last) - Int'Base (Count) + 1; - declare - E : Elements_Type renames Container.Elements.all; - begin - E (Index .. New_Last) := E (Before .. Container.Last); - Container.Last := New_Last; + Delete (Container, Index_Type'Base (Index), Count); + end Delete_Last; - -- NOTE: - -- Now we do the allocation. If it fails, we can propagate the - -- exception and invariants are more or less satisfied. The - -- issue is that we have some slots still null, and the client - -- has no way of detecting whether the slot is null (unless we - -- give him a way). - -- - -- Another way is to allocate a subarray on the stack, do the - -- allocation into that array, and if that success then do - -- the insertion proper. The issue there is that you have to - -- allocate the subarray on the stack, and that may fail if the - -- subarray is long. - -- - -- Or we could try to roll-back the changes: deallocate the - -- elements we have successfully deallocated, and then copy - -- the elements ptrs back to their original posns. - -- END NOTE. + ------------- + -- Element -- + ------------- - -- NOTE: I have written the loop manually here. I could - -- have done it this way too: - -- E (Before .. Index_Type'Pred (Index)) := - -- (others => new Element_Type'New_Item); - -- END NOTE. + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + return Container.Elements (T'(Index)).all; + end Element; - for I in Before .. Index_Type'Pred (Index) loop + function Element (Position : Cursor) return Element_Type is + begin + return Element (Position.Container.all, Position.Index); + end Element; - begin - E (I) := new Element_Type'(New_Item); - exception - when others => - E (I .. Index_Type'Pred (Index)) := (others => null); - raise; - end; + -------------- + -- Finalize -- + -------------- - end loop; - end; + procedure Finalize (Container : in out Vector) is + begin + Clear (Container); - return; + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := null; + Free (X); + end; + end Finalize; + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor is + + begin + if Position.Container /= null + and then (Position.Container /= + Vector_Access'(Container'Unchecked_Access) + or else Position.Index > Container.Last) + then + raise Program_Error; end if; - declare + for J in Position.Index .. Container.Last loop + if Container.Elements (J) /= null + and then Container.Elements (J).all = Item + then + return (Container'Unchecked_Access, J); + end if; + end loop; - First : constant Int := Int (Index_Type'First); + return No_Element; + end Find; - New_Size : constant Int'Base := - New_Last_As_Int - First + 1; + ---------------- + -- Find_Index -- + ---------------- - Max_Size : constant Int'Base := - Int (Index_Type'Last) - First + 1; + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index is + begin + for Indx in Index .. Container.Last loop + if Container.Elements (Indx) /= null + and then Container.Elements (Indx).all = Item + then + return Indx; + end if; + end loop; - Size, Dst_Last_As_Int : Int'Base; + return No_Index; + end Find_Index; - begin + ----------- + -- First -- + ----------- - if New_Size >= Max_Size / 2 then + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; - Dst_Last := Index_Type'Last; + return (Container'Unchecked_Access, Index_Type'First); + end First; + + ------------------- + -- First_Element -- + ------------------- + function First_Element (Container : Vector) return Element_Type is + begin + return Element (Container, Index_Type'First); + 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 + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Less (L, R : Element_Access) return Boolean; + pragma Inline (Is_Less); + + ------------- + -- Is_Less -- + ------------- + + function Is_Less (L, R : Element_Access) return Boolean is + begin + if L = null then + return R /= null; + elsif R = null then + return False; else + return L.all < R.all; + end if; + end Is_Less; - Size := Container.Elements'Length; + --------------- + -- Is_Sorted -- + --------------- - if Size = 0 then - Size := 1; - end if; + function Is_Sorted (Container : Vector) return Boolean is + begin + if Container.Last <= Index_Type'First then + return True; + end if; - while Size < New_Size loop - Size := 2 * Size; + declare + E : Elements_Type renames Container.Elements.all; + begin + for I in Index_Type'First .. Container.Last - 1 loop + if Is_Less (E (I + 1), E (I)) then + return False; + end if; end loop; + end; - Dst_Last_As_Int := First + Size - 1; - Dst_Last := Index_Type (Dst_Last_As_Int); + return True; + end Is_Sorted; + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I : Index_Type'Base := Target.Last; + J : Index_Type'Base; + + begin + if Target.Last < Index_Type'First then + Move (Target => Target, Source => Source); + return; end if; - end; + if Target'Address = Source'Address then + return; + end if; - Dst := new Elements_Type (Index_Type'First .. Dst_Last); + if Source.Last < Index_Type'First then + return; + end if; - declare - Src : Elements_Type renames Container.Elements.all; - begin - Dst (Index_Type'First .. Index_Type'Pred (Before)) := - Src (Index_Type'First .. Index_Type'Pred (Before)); + if Source.Busy > 0 then + raise Program_Error; + end if; - Dst (Index .. New_Last) := Src (Before .. Container.Last); - end; + Target.Set_Length (Length (Target) + Length (Source)); + + J := Target.Last; + while Source.Last >= Index_Type'First loop + if I < Index_Type'First then + declare + Src : Elements_Type renames + Source.Elements (Index_Type'First .. Source.Last); + + begin + Target.Elements (Index_Type'First .. J) := Src; + Src := (others => null); + end; + + Source.Last := No_Index; + return; + end if; + + declare + Src : Element_Access renames Source.Elements (Source.Last); + Tgt : Element_Access renames Target.Elements (I); + + begin + if Is_Less (Src, Tgt) then + Target.Elements (J) := Tgt; + Tgt := null; + I := I - 1; + + else + Target.Elements (J) := Src; + Src := null; + Source.Last := Source.Last - 1; + end if; + end; + + J := J - 1; + end loop; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) + is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Index_Type, + Element_Type => Element_Access, + Array_Type => Elements_Type, + "<" => Is_Less); + + -- Start of processing for Sort - declare - X : Elements_Access := Container.Elements; begin - Container.Elements := Dst; - Container.Last := New_Last; + if Container.Last <= Index_Type'First then + return; + end if; - Free (X); - end; + if Container.Lock > 0 then + raise Program_Error; + end if; - -- NOTE: - -- Now do the allocation. If the allocation fails, - -- then the worst thing is that we have a few null slots. - -- Our invariants are otherwise satisfied. - -- END NOTE. + Sort (Container.Elements (Index_Type'First .. Container.Last)); + end Sort; - for I in Before .. Index_Type'Pred (Index) loop - Dst (I) := new Element_Type'(New_Item); - end loop; + end Generic_Sorting; - end Insert; + ----------------- + -- Has_Element -- + ----------------- + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; - procedure Insert_Space - (Container : in out Vector; - Before : in Extended_Index; - Count : in Count_Type := 1) is + return Position.Index <= Position.Container.Last; + end Has_Element; - Old_Last_As_Int : constant Int := Int (Container.Last); + ------------ + -- Insert -- + ------------ + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1) + is N : constant Int := Int (Count); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; - - New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + New_Last_As_Int : Int'Base; + New_Last : Index_Type; - Index : Index_Type; + Index : Extended_Index; -- TODO: see note in a-convec.adb. Dst_Last : Index_Type; Dst : Elements_Access; begin + if Before < Index_Type'First then + raise Constraint_Error; + end if; + + if Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error; + end if; if Count = 0 then return; end if; declare - subtype Before_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Container.Last); + Old_Last_As_Int : constant Int := Int (Container.Last); - Old_First : constant Before_Subtype := Before; + begin + New_Last_As_Int := Old_Last_As_Int + N; + New_Last := Index_Type (New_Last_As_Int); + end; - Old_First_As_Int : constant Int := Int (Old_First); + if Container.Busy > 0 then + raise Program_Error; + end if; + + declare + Old_First_As_Int : constant Int := Int (Before); New_First_As_Int : constant Int'Base := Old_First_As_Int + N; + begin - Index := Index_Type (New_First_As_Int); + Index := Extended_Index (New_First_As_Int); -- TODO end; if Container.Elements = null then - declare subtype Elements_Subtype is Elements_Type (Index_Type'First .. New_Last); begin Container.Elements := new Elements_Subtype; - Container.Last := New_Last; + Container.Last := Index_Type'Pred (Index_Type'First); + + for J in Container.Elements'Range loop + Container.Elements (J) := new Element_Type'(New_Item); + Container.Last := J; + end loop; end; return; - end if; if New_Last <= Container.Elements'Last then - declare E : Elements_Type renames Container.Elements.all; begin E (Index .. New_Last) := E (Before .. Container.Last); - E (Before .. Index_Type'Pred (Index)) := (others => null); - Container.Last := New_Last; + + -- NOTE: + -- Now we do the allocation. If it fails, we can propagate the + -- exception and invariants are more or less satisfied. The + -- issue is that we have some slots still null, and the client + -- has no way of detecting whether the slot is null (unless we + -- give him a way). + -- + -- Another way is to allocate a subarray on the stack, do the + -- allocation into that array, and if that success then do + -- the insertion proper. The issue there is that you have to + -- allocate the subarray on the stack, and that may fail if the + -- subarray is long. + -- + -- Or we could try to roll-back the changes: deallocate the + -- elements we have successfully deallocated, and then copy + -- the elements ptrs back to their original posns. + -- END NOTE. + + -- NOTE: I have written the loop manually here. I could + -- have done it this way too: + -- E (Before .. Index_Type'Pred (Index)) := + -- (others => new Element_Type'New_Item); + -- END NOTE. + + for J in Before .. Index_Type'Pred (Index) loop + begin + E (J) := new Element_Type'(New_Item); + exception + when others => + E (J .. Index_Type'Pred (Index)) := (others => null); + raise; + end; + end loop; end; return; - end if; declare - First : constant Int := Int (Index_Type'First); - New_Size : constant Int'Base := - Int (New_Last_As_Int) - First + 1; - - Max_Size : constant Int'Base := - Int (Index_Type'Last) - First + 1; + New_Size : constant Int'Base := New_Last_As_Int - First + 1; + Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; Size, Dst_Last_As_Int : Int'Base; begin - if New_Size >= Max_Size / 2 then - Dst_Last := Index_Type'Last; else - Size := Container.Elements'Length; if Size = 0 then @@ -687,15 +1098,14 @@ package body Ada.Containers.Indefinite_Vectors is Dst_Last_As_Int := First + Size - 1; Dst_Last := Index_Type (Dst_Last_As_Int); - end if; - end; Dst := new Elements_Type (Index_Type'First .. Dst_Last); declare Src : Elements_Type renames Container.Elements.all; + begin Dst (Index_Type'First .. Index_Type'Pred (Before)) := Src (Index_Type'First .. Index_Type'Pred (Before)); @@ -712,900 +1122,564 @@ package body Ada.Containers.Indefinite_Vectors is Free (X); end; - end Insert_Space; - - - procedure Delete_First (Container : in out Vector; - Count : in Count_Type := 1) is - begin - - 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; - + -- NOTE: + -- Now do the allocation. If the allocation fails, + -- then the worst thing is that we have a few null slots. + -- Our invariants are otherwise satisfied. + -- END NOTE. - procedure Delete_Last (Container : in out Vector; - Count : in Count_Type := 1) is + for J in Before .. Index_Type'Pred (Index) loop + Dst (J) := new Element_Type'(New_Item); + end loop; + end Insert; - Index : Int'Base; + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); begin - - if Count = 0 then - return; + if Before < Index_Type'First then + raise Constraint_Error; end if; - if Count >= Length (Container) then - Clear (Container); - return; + if Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error; end if; - Index := Int'Base (Container.Last) - Int'Base (Count) + 1; - - Delete (Container, Index_Type'Base (Index), Count); - - end Delete_Last; - - - procedure Delete - (Container : in out Vector; - Index : in Extended_Index; -- TODO: verify in Atlanta - Count : in Count_Type := 1) is - - begin - - if Count = 0 then + if N = 0 then return; end if; - declare - - subtype I_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - I : constant I_Subtype := Index; - I_As_Int : constant Int := Int (I); - - Old_Last_As_Int : constant Int := Int (Container.Last); - - Count1 : constant Int'Base := Int (Count); - Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; - - N : constant Int'Base := Int'Min (Count1, Count2); + Insert_Space (Container, Before, Count => N); - J_As_Int : constant Int'Base := I_As_Int + N; - J : constant Index_Type'Base := Index_Type'Base (J_As_Int); + if Container'Address = New_Item'Address then + declare + Dst_Last_As_Int : constant Int'Base := + Int'Base (Before) + Int'Base (N) - 1; - E : Elements_Type renames Container.Elements.all; + Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; + Dst_Index : Index_Type'Base := Index_Type'Pred (Before); - New_Last : constant Extended_Index := - Extended_Index (New_Last_As_Int); + Dst : Elements_Type renames + Container.Elements (Before .. Dst_Last); - begin + begin + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Pred (Before); - for K in I .. Index_Type'Pred (J) loop + Src : Elements_Type renames + Container.Elements (Src_Index_Subtype); begin - Free (E (K)); - exception - when others => - E (K) := null; - raise; - end; - - end loop; - - E (I .. New_Last) := E (J .. Container.Last); - Container.Last := New_Last; - - end; - - end Delete; - - - function Capacity (Container : Vector) return Count_Type is - begin - if Container.Elements = null then - return 0; - end if; - - return Container.Elements'Length; - end Capacity; - - - procedure Reserve_Capacity (Container : in out Vector; - Capacity : in Count_Type) is - - N : constant Count_Type := Length (Container); - - begin - - if Capacity = 0 then - - if N = 0 then + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); - declare - X : Elements_Access := Container.Elements; - begin - Container.Elements := null; - Free (X); + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; end; - elsif N < Container.Elements'Length then - declare - subtype Array_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'Succ (Dst_Last) .. Container.Last; Src : Elements_Type renames - Container.Elements (Array_Index_Subtype); + Container.Elements (Src_Index_Subtype); - subtype Array_Subtype is - Elements_Type (Array_Index_Subtype); - - X : Elements_Access := Container.Elements; begin - Container.Elements := new Array_Subtype'(Src); - Free (X); - end; - - end if; + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); - return; + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; + end; - end if; + else + declare + Dst_Last_As_Int : constant Int'Base := + Int'Base (Before) + Int'Base (N) - 1; - if Container.Elements = null then + Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + Dst_Index : Index_Type'Base := Index_Type'Pred (Before); - Last : constant Index_Type := - Index_Type (Last_As_Int); + Src : Elements_Type renames + New_Item.Elements (Index_Type'First .. New_Item.Last); - subtype Array_Subtype is - Elements_Type (Index_Type'First .. Last); + Dst : Elements_Type renames + Container.Elements (Before .. Dst_Last); begin - Container.Elements := new Array_Subtype; - end; + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); - return; + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; end if; + end Insert; - if Capacity <= N then - - if N < Container.Elements'Length then - - declare - subtype Array_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Type renames - Container.Elements (Array_Index_Subtype); - - subtype Array_Subtype is - Elements_Type (Array_Index_Subtype); - - X : Elements_Access := Container.Elements; - begin - Container.Elements := new Array_Subtype'(Src); - Free (X); - end; - - end if; - - return; + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector) + is + Index : Index_Type'Base; + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; end if; - if Capacity = Container.Elements'Length then + if Is_Empty (New_Item) then return; end if; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; - - Last : constant Index_Type := - Index_Type (Last_As_Int); - - subtype Array_Subtype is - Elements_Type (Index_Type'First .. Last); - - X : Elements_Access := Container.Elements; - begin - Container.Elements := new Array_Subtype; - - declare - Src : Elements_Type renames - X (Index_Type'First .. Container.Last); - - Tgt : Elements_Type renames - Container.Elements (Index_Type'First .. Container.Last); - begin - Tgt := Src; - end; - - Free (X); - end; - - end Reserve_Capacity; - - - function First_Index (Container : Vector) return Index_Type is - pragma Warnings (Off, Container); - begin - return Index_Type'First; - end First_Index; - - - function First_Element (Container : Vector) return Element_Type is - begin - return Element (Container, Index_Type'First); - end First_Element; - - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - - function Last_Element (Container : Vector) return Element_Type is - begin - return Element (Container, Container.Last); - end Last_Element; - - - function Element (Container : Vector; - Index : Index_Type) - return Element_Type is - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - begin - return Container.Elements (T'(Index)).all; - end Element; - + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; - procedure Replace_Element (Container : in Vector; - Index : in Index_Type; - By : in Element_Type) is + Insert (Container, Index, New_Item); + end Insert; - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor) + is + Index : Index_Type'Base; - X : Element_Access := Container.Elements (T'(Index)); begin - Container.Elements (T'(Index)) := new Element_Type'(By); - Free (X); - end Replace_Element; - - - procedure Generic_Sort (Container : in Vector) is - - function Is_Less (L, R : Element_Access) return Boolean; - pragma Inline (Is_Less); + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; - function Is_Less (L, R : Element_Access) return Boolean is - begin - if L = null then - return R /= null; - elsif R = null then - return False; + if Is_Empty (New_Item) then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; else - return L.all < R.all; + Position := (Container'Unchecked_Access, Before.Index); end if; - end Is_Less; - - procedure Sort is - new Generic_Array_Sort - (Index_Type, - Element_Access, - Elements_Type, - "<" => Is_Less); - begin - - if Container.Elements = null then return; end if; - Sort (Container.Elements (Index_Type'First .. Container.Last)); - - end Generic_Sort; - - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) - return Extended_Index is - - begin - - for I in Index .. Container.Last loop - if Container.Elements (I) /= null - and then Container.Elements (I).all = Item - then - return I; - end if; - end loop; - - return No_Index; - - end 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; - - begin - - if Index > Container.Last then - Last := Container.Last; + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); else - Last := Index; + Index := Before.Index; end if; - for I in reverse Index_Type'First .. Last loop - if Container.Elements (I) /= null - and then Container.Elements (I).all = Item - then - return I; - end if; - end loop; - - return No_Index; + Insert (Container, Index, New_Item); - end Reverse_Find_Index; + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert; + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Index : Index_Type'Base; - function Contains (Container : Vector; - Item : Element_Type) return Boolean is begin - return Find_Index (Container, Item) /= No_Index; - end Contains; + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + if Count = 0 then + return; + end if; + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; - procedure Assign - (Target : in out Vector; - Source : in Vector) is + Insert (Container, Index, New_Item, Count); + end Insert; - N : constant Count_Type := Length (Source); + 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 Target'Address = Source'Address then - return; + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; end if; - Clear (Target); + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; - if N = 0 then return; end if; - if N > Capacity (Target) then - Reserve_Capacity (Target, Capacity => N); + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; end if; - for I in Index_Type'First .. Source.Last loop - - declare - EA : constant Element_Access := Source.Elements (I); - begin - if EA /= null then - Target.Elements (I) := new Element_Type'(EA.all); - end if; - end; + Insert (Container, Index, New_Item, Count); - Target.Last := I; + Position := (Container'Unchecked_Access, Index); + end Insert; - end loop; + ------------------ + -- Insert_Space -- + ------------------ - end Assign; + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + N : constant Int := Int (Count); + New_Last_As_Int : Int'Base; + New_Last : Index_Type; - procedure Move - (Target : in out Vector; - Source : in out Vector) is + Index : Extended_Index; -- TODO: see a-convec.adb. - X : Elements_Access := Target.Elements; + Dst_Last : Index_Type; + Dst : Elements_Access; begin - - if Target'Address = Source'Address then - return; + if Before < Index_Type'First then + raise Constraint_Error; end if; - if Target.Last >= Index_Type'First then + if Before > Container.Last + and then Before > Container.Last + 1 + then raise Constraint_Error; end if; - Target.Elements := null; - Free (X); -- shouldn't fail - - Target.Elements := Source.Elements; - Target.Last := Source.Last; - - Source.Elements := null; - Source.Last := Index_Type'Pred (Index_Type'First); - - end Move; - - - procedure Query_Element - (Container : in Vector; - Index : in Index_Type; - Process : not null access procedure (Element : in Element_Type)) is - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - begin - Process (Container.Elements (T'(Index)).all); - end Query_Element; - - - procedure Update_Element - (Container : in Vector; - Index : in Index_Type; - Process : not null access procedure (Element : in out Element_Type)) is - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - begin - Process (Container.Elements (T'(Index)).all); - end Update_Element; - - - procedure Prepend (Container : in out Vector; - New_Item : in Element_Type; - Count : in Count_Type := 1) is - begin - Insert (Container, - Index_Type'First, - New_Item, - Count); - end Prepend; - - - procedure Swap - (Container : in Vector; - I, J : in Index_Type) is - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - - EI : constant Element_Access := Container.Elements (T'(I)); - - begin - - Container.Elements (T'(I)) := Container.Elements (T'(J)); - Container.Elements (T'(J)) := EI; - - end Swap; + if Count = 0 then + return; + end if; + declare + Old_Last_As_Int : constant Int := Int (Container.Last); - function "&" (Left, Right : Vector) return Vector is + begin + New_Last_As_Int := Old_Last_As_Int + N; + New_Last := Index_Type (New_Last_As_Int); + end; - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); + if Container.Busy > 0 then + raise Program_Error; + end if; - begin + declare + Old_First_As_Int : constant Int := Int (Before); - if LN = 0 then + New_First_As_Int : constant Int'Base := Old_First_As_Int + N; - if RN = 0 then - return Empty_Vector; - end if; + begin + Index := Extended_Index (New_First_As_Int); -- TODO + end; + if Container.Elements = null then declare - RE : Elements_Type renames - Right.Elements (Index_Type'First .. Right.Last); - - Elements : Elements_Access := - new Elements_Type (RE'Range); + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. New_Last); begin - for I in Elements'Range loop - begin - if RE (I) /= null then - Elements (I) := new Element_Type'(RE (I).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Right.Last); + Container.Elements := new Elements_Subtype; + Container.Last := New_Last; end; + return; end if; - if RN = 0 then - + if New_Last <= Container.Elements'Last then declare - LE : Elements_Type renames - Left.Elements (Index_Type'First .. Left.Last); - - Elements : Elements_Access := - new Elements_Type (LE'Range); + E : Elements_Type renames Container.Elements.all; begin - for I in Elements'Range loop - begin - if LE (I) /= null then - Elements (I) := new Element_Type'(LE (I).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; + E (Index .. New_Last) := E (Before .. Container.Last); + E (Before .. Index_Type'Pred (Index)) := (others => null); - return (Controlled with Elements, Left.Last); + Container.Last := New_Last; end; + return; end if; declare + First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (LN) + Int (RN) - 1; - - Last : constant Index_Type := Index_Type (Last_As_Int); - - LE : Elements_Type renames - Left.Elements (Index_Type'First .. Left.Last); - - RE : Elements_Type renames - Right.Elements (Index_Type'First .. Right.Last); + New_Size : constant Int'Base := + Int (New_Last_As_Int) - First + 1; - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Last); + Max_Size : constant Int'Base := + Int (Index_Type'Last) - First + 1; - I : Index_Type'Base := Index_Type'Pred (Index_Type'First); + Size, Dst_Last_As_Int : Int'Base; begin + if New_Size >= Max_Size / 2 then + Dst_Last := Index_Type'Last; - for LI in LE'Range loop - - I := Index_Type'Succ (I); - - begin - if LE (LI) /= null then - Elements (I) := new Element_Type'(LE (LI).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; - - Free (Elements); - raise; - end; - - end loop; - - for RI in RE'Range loop - - I := Index_Type'Succ (I); - - begin - if RE (RI) /= null then - Elements (I) := new Element_Type'(RE (RI).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; + else + Size := Container.Elements'Length; - Free (Elements); - raise; - end; + if Size = 0 then + Size := 1; + end if; - end loop; + while Size < New_Size loop + Size := 2 * Size; + end loop; - return (Controlled with Elements, Last); + Dst_Last_As_Int := First + Size - 1; + Dst_Last := Index_Type (Dst_Last_As_Int); + end if; end; - end "&"; - - - function "&" (Left : Vector; - Right : Element_Type) return Vector is - - LN : constant Count_Type := Length (Left); - - begin - - if LN = 0 then - - declare - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Index_Type'First); - begin - - begin - Elements (Elements'First) := new Element_Type'(Right); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First); - - end; - - end if; + Dst := new Elements_Type (Index_Type'First .. Dst_Last); declare - - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (LN); - - Last : constant Index_Type := Index_Type (Last_As_Int); - - LE : Elements_Type renames - Left.Elements (Index_Type'First .. Left.Last); - - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Last); + Src : Elements_Type renames Container.Elements.all; begin + Dst (Index_Type'First .. Index_Type'Pred (Before)) := + Src (Index_Type'First .. Index_Type'Pred (Before)); - for I in LE'Range loop - - begin - if LE (I) /= null then - Elements (I) := new Element_Type'(LE (I).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; - - Free (Elements); - raise; - end; - - end loop; - - begin - Elements (Elements'Last) := new Element_Type'(Right); - exception - when others => - - declare - subtype J_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Pred (Elements'Last); - begin - for J in J_Subtype loop - Free (Elements (J)); - end loop; - end; - - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last); + Dst (Index .. New_Last) := Src (Before .. Container.Last); end; - end "&"; - - - - function "&" (Left : Element_Type; - Right : Vector) return Vector is - - RN : constant Count_Type := Length (Right); - - begin - - if RN = 0 then - - declare - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Index_Type'First); - begin - - begin - Elements (Elements'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First); - - end; - - end if; - declare - - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (RN); - - Last : constant Index_Type := Index_Type (Last_As_Int); - - RE : Elements_Type renames - Right.Elements (Index_Type'First .. Right.Last); - - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Last); - - I : Index_Type'Base := Index_Type'First; - + X : Elements_Access := Container.Elements; begin + Container.Elements := Dst; + Container.Last := New_Last; - begin - Elements (I) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; + Free (X); + end; + end Insert_Space; - for RI in RE'Range loop + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; - I := Index_Type'Succ (I); + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; - begin - if RE (RI) /= null then - Elements (I) := new Element_Type'(RE (RI).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; - Free (Elements); - raise; - end; + return; + end if; - end loop; + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; - return (Controlled with Elements, Last); - end; + Insert_Space (Container, Index, Count); - end "&"; + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert_Space; + -------------- + -- Is_Empty -- + -------------- - function "&" (Left, Right : Element_Type) return Vector is + function Is_Empty (Container : Vector) return Boolean is + begin + return Container.Last < Index_Type'First; + end Is_Empty; - subtype IT is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Index_Type'First); + ------------- + -- Iterate -- + ------------- - Elements : Elements_Access := new Elements_Type (IT); + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : in Cursor)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; begin + B := B + 1; begin - Elements (Elements'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - begin - Elements (Elements'Last) := new Element_Type'(Right); + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; exception when others => - Free (Elements (Elements'First)); - Free (Elements); + B := B - 1; raise; end; - return (Controlled with Elements, Elements'Last); - - end "&"; + B := B - 1; + end Iterate; + ---------- + -- Last -- + ---------- - function To_Cursor (Container : Vector; - Index : Extended_Index) - return Cursor is + function Last (Container : Vector) return Cursor is begin - if Index not in Index_Type'First .. Container.Last then + if Is_Empty (Container) then return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Index); - end To_Cursor; + return (Container'Unchecked_Access, Container.Last); + end Last; + ------------------ + -- Last_Element -- + ------------------ - function To_Index (Position : Cursor) return Extended_Index is + function Last_Element (Container : Vector) return Element_Type is begin - if Position.Container = null then - return No_Index; - end if; + return Element (Container, Container.Last); + end Last_Element; - if Position.Index <= Position.Container.Last then - return Position.Index; - end if; + ---------------- + -- Last_Index -- + ---------------- - return No_Index; - end To_Index; + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + ------------ + -- Length -- + ------------ - function Element (Position : Cursor) return Element_Type is + function Length (Container : Vector) return Count_Type is + L : constant Int := Int (Container.Last); + F : constant Int := Int (Index_Type'First); + N : constant Int'Base := L - F + 1; begin - return Element (Position.Container.all, Position.Index); - end Element; + return Count_Type (N); + end Length; + ---------- + -- Move -- + ---------- - function Next (Position : Cursor) return Cursor is + procedure Move + (Target : in out Vector; + Source : in out Vector) + is begin - - if Position.Container = null then - return No_Element; + if Target'Address = Source'Address then + return; end if; - if Position.Index < Position.Container.Last then - return (Position.Container, Index_Type'Succ (Position.Index)); + if Source.Busy > 0 then + raise Program_Error; end if; - return No_Element; + Clear (Target); - end Next; + declare + X : Elements_Access := Target.Elements; + begin + Target.Elements := null; + Free (X); + end; + Target.Elements := Source.Elements; + Target.Last := Source.Last; - function Previous (Position : Cursor) return Cursor is - begin + Source.Elements := null; + Source.Last := No_Index; + end Move; + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin if Position.Container = null then return No_Element; end if; - if Position.Index > Index_Type'First then - return (Position.Container, Index_Type'Pred (Position.Index)); + if Position.Index < Position.Container.Last then + return (Position.Container, Index_Type'Succ (Position.Index)); end if; return No_Element; + end Next; - end Previous; - + ---------- + -- Next -- + ---------- procedure Next (Position : in out Cursor) is begin - if Position.Container = null then return; end if; @@ -1615,13 +1689,35 @@ package body Ada.Containers.Indefinite_Vectors is else Position := No_Element; end if; - end Next; + ------------- + -- Prepend -- + ------------- - procedure Previous (Position : in out Cursor) is + 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 (Position : in out Cursor) is + begin if Position.Container = null then return; end if; @@ -1631,541 +1727,618 @@ package body Ada.Containers.Indefinite_Vectors is else Position := No_Element; end if; - end Previous; - - function Has_Element (Position : Cursor) return Boolean is + function Previous (Position : Cursor) return Cursor is begin - if Position.Container = null then - return False; + return No_Element; end if; - return Position.Index <= Position.Container.Last; - - end Has_Element; + if Position.Index > Index_Type'First then + return (Position.Container, Index_Type'Pred (Position.Index)); + end if; + return No_Element; + end Previous; - procedure Iterate - (Container : in Vector; - Process : not null access procedure (Position : in Cursor)) is - begin + ------------------- + -- Query_Element -- + ------------------- - for I in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, I)); - end loop; + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : in Element_Type)) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; - end Iterate; + E : Element_Type renames Container.Elements (T'(Index)).all; + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; - procedure Reverse_Iterate - (Container : in Vector; - Process : not null access procedure (Position : in Cursor)) is begin + B := B + 1; + L := L + 1; - for I in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, I)); - end loop; - - end Reverse_Iterate; + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + L := L - 1; + B := B - 1; + end Query_Element; procedure Query_Element - (Position : in Cursor; - Process : not null access procedure (Element : in Element_Type)) is - - C : Vector renames Position.Container.all; - E : Elements_Type renames C.Elements.all; - - subtype T is Index_Type'Base range - Index_Type'First .. C.Last; + (Position : Cursor; + Process : not null access procedure (Element : in Element_Type)) + is begin - Process (E (T'(Position.Index)).all); + Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; + ---------- + -- Read -- + ---------- - procedure Update_Element - (Position : in Cursor; - Process : not null access procedure (Element : in out Element_Type)) is + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Vector) + is + Length : Count_Type'Base; + Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); - C : Vector renames Position.Container.all; - E : Elements_Type renames C.Elements.all; + B : Boolean; - subtype T is Index_Type'Base range - Index_Type'First .. C.Last; begin - Process (E (T'(Position.Index)).all); - end Update_Element; + Clear (Container); + Count_Type'Base'Read (Stream, Length); - procedure Replace_Element (Position : in Cursor; - By : in Element_Type) is + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; - C : Vector renames Position.Container.all; - E : Elements_Type renames C.Elements.all; + for J in Count_Type range 1 .. Length loop + Last := Index_Type'Succ (Last); - subtype T is Index_Type'Base range - Index_Type'First .. C.Last; + Boolean'Read (Stream, B); - X : Element_Access := E (T'(Position.Index)); - begin - E (T'(Position.Index)) := new Element_Type'(By); - Free (X); - end Replace_Element; + if B then + Container.Elements (Last) := + new Element_Type'(Element_Type'Input (Stream)); + end if; + Container.Last := Last; + end loop; + end Read; - procedure Insert (Container : in out Vector; - Before : in Extended_Index; - New_Item : in Vector) is + --------------------- + -- Replace_Element -- + --------------------- - N : constant Count_Type := Length (New_Item); + procedure Replace_Element + (Container : Vector; + Index : Index_Type; + By : Element_Type) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; - begin + X : Element_Access := Container.Elements (T'(Index)); - if N = 0 then - return; + begin + if Container.Lock > 0 then + raise Program_Error; end if; - Insert_Space (Container, Before, Count => N); - - if Container'Address = New_Item'Address then - - declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; + Container.Elements (T'(Index)) := new Element_Type'(By); + Free (X); + end Replace_Element; - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + procedure Replace_Element (Position : Cursor; By : Element_Type) is + begin + Replace_Element (Position.Container.all, Position.Index, By); + end Replace_Element; - Dst_Index : Index_Type'Base := Index_Type'Pred (Before); + ---------------------- + -- Reserve_Capacity -- + ---------------------- - Dst : Elements_Type renames - Container.Elements (Before .. Dst_Last); - begin + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type) + is + N : constant Count_Type := Length (Container); + begin + if Capacity = 0 then + if N = 0 then declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Pred (Before); - - Src : Elements_Type renames - Container.Elements (Src_Index_Subtype); + X : Elements_Access := Container.Elements; begin - for Src_Index in Src'Range loop - Dst_Index := Index_Type'Succ (Dst_Index); - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; + Container.Elements := null; + Free (X); end; + elsif N < Container.Elements'Length then + if Container.Busy > 0 then + raise Program_Error; + end if; + declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'Succ (Dst_Last) .. Container.Last; + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; Src : Elements_Type renames - Container.Elements (Src_Index_Subtype); - begin - for Src_Index in Src'Range loop - Dst_Index := Index_Type'Succ (Dst_Index); + Container.Elements (Array_Index_Subtype); - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; + subtype Array_Subtype is + Elements_Type (Array_Index_Subtype); + + X : Elements_Access := Container.Elements; + begin + Container.Elements := new Array_Subtype'(Src); + Free (X); end; - end; + end if; - else + return; + end if; + if Container.Elements = null then declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; - - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Capacity) - 1; - Dst_Index : Index_Type'Base := Index_Type'Pred (Before); + Last : constant Index_Type := + Index_Type (Last_As_Int); - Src : Elements_Type renames - New_Item.Elements (Index_Type'First .. New_Item.Last); + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); - Dst : Elements_Type renames - Container.Elements (Before .. Dst_Last); begin - for Src_Index in Src'Range loop - Dst_Index := Index_Type'Succ (Dst_Index); - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; + Container.Elements := new Array_Subtype; end; + return; end if; - end Insert; + if Capacity <= N then + if N < Container.Elements'Length then + if Container.Busy > 0 then + raise Program_Error; + end if; + declare + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; - procedure Insert (Container : in out Vector; - Before : in Cursor; - New_Item : in Vector) is + Src : Elements_Type renames + Container.Elements (Array_Index_Subtype); - Index : Index_Type'Base; + subtype Array_Subtype is + Elements_Type (Array_Index_Subtype); - begin + X : Elements_Access := Container.Elements; - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; - end if; + begin + Container.Elements := new Array_Subtype'(Src); + Free (X); + end; + + end if; - if Is_Empty (New_Item) then return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then - Index := Index_Type'Succ (Container.Last); - else - Index := Before.Index; + if Capacity = Container.Elements'Length then + return; end if; - Insert (Container, Index, New_Item); - - end Insert; - - - - procedure Insert (Container : in out Vector; - Before : in Cursor; - New_Item : in Vector; - Position : out Cursor) is - - Index : Index_Type'Base; - - begin - - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) - then + if Container.Busy > 0 then raise Program_Error; end if; - if Is_Empty (New_Item) then + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Capacity) - 1; - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); - end if; + Last : constant Index_Type := Index_Type (Last_As_Int); - return; + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); - end if; + X : Elements_Access := Container.Elements; - if Before.Container = null - or else Before.Index > Container.Last - then - Index := Index_Type'Succ (Container.Last); - else - Index := Before.Index; - end if; + begin + Container.Elements := new Array_Subtype; - Insert (Container, Index, New_Item); + declare + Src : Elements_Type renames + X (Index_Type'First .. Container.Last); - Position := (Container'Unchecked_Access, Index); + Tgt : Elements_Type renames + Container.Elements (Index_Type'First .. Container.Last); - end Insert; + begin + Tgt := Src; + end; + Free (X); + end; + end Reserve_Capacity; - procedure Insert (Container : in out Vector; - Before : in Cursor; - New_Item : in Element_Type; - Count : in Count_Type := 1) is + ------------------ + -- Reverse_Find -- + ------------------ - Index : Index_Type'Base; + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Last : Index_Type'Base; begin - - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + if Position.Container /= null + and then Position.Container /= + Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; - if Count = 0 then - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last + if Position.Container = null + or else Position.Index > Container.Last then - Index := Index_Type'Succ (Container.Last); + Last := Container.Last; else - Index := Before.Index; + Last := Position.Index; end if; - Insert (Container, Index, New_Item, Count); - - end Insert; + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (Indx) /= null + and then Container.Elements (Indx).all = Item + then + return (Container'Unchecked_Access, Indx); + end if; + end loop; + return No_Element; + end Reverse_Find; - procedure Insert (Container : in out Vector; - Before : in Cursor; - New_Item : in Element_Type; - Position : out Cursor; - Count : in Count_Type := 1) is + ------------------------ + -- Reverse_Find_Index -- + ------------------------ - Index : Index_Type'Base; + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + Last : Index_Type'Base; begin - - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; + if Index > Container.Last then + Last := Container.Last; + else + Last := Index; end if; - if Count = 0 then - - if Before.Container = null - or else Before.Index > Container.Last + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (Indx) /= null + and then Container.Elements (Indx).all = Item then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); + return Indx; end if; + end loop; - return; - - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - Index := Index_Type'Succ (Container.Last); - else - Index := Before.Index; - end if; + return No_Index; + end Reverse_Find_Index; - Insert (Container, Index, New_Item, Count); + --------------------- + -- Reverse_Iterate -- + --------------------- - Position := (Container'Unchecked_Access, Index); + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : in Cursor)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; - end Insert; + begin + B := B + 1; + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + B := B - 1; + end Reverse_Iterate; - procedure Prepend (Container : in out Vector; - New_Item : in Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; + ---------------- + -- Set_Length -- + ---------------- + procedure Set_Length + (Container : in out Vector; + Length : Count_Type) + is + N : constant Count_Type := Indefinite_Vectors.Length (Container); - procedure Append (Container : in out Vector; - New_Item : in Vector) is begin - if Is_Empty (New_Item) then + if Length = N then return; end if; - Insert - (Container, - Index_Type'Succ (Container.Last), - New_Item); - end Append; - - - - procedure Insert_Space (Container : in out Vector; - Before : in Cursor; - Position : out Cursor; - Count : in Count_Type := 1) is - - Index : Index_Type'Base; - - begin + if Length = 0 then + Clear (Container); + return; + end if; - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) - then + if Container.Busy > 0 then raise Program_Error; end if; - if Count = 0 then + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Length) - 1; - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); - end if; + Last : constant Index_Type := + Index_Type (Last_As_Int); - return; + begin + if Length > N then + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; - end if; + Container.Last := Last; + return; + end if; - if Before.Container = null - or else Before.Index > Container.Last - then - Index := Index_Type'Succ (Container.Last); - else - Index := Before.Index; - end if; + for Indx in reverse Index_Type'Succ (Last) .. Container.Last loop + declare + X : Element_Access := Container.Elements (Indx); - Insert_Space (Container, Index, Count); + begin + Container.Elements (Indx) := null; + Container.Last := Index_Type'Pred (Container.Last); + Free (X); + end; + end loop; + end; + end Set_Length; - Position := (Container'Unchecked_Access, Index); + ---------- + -- Swap -- + ---------- - end Insert_Space; + procedure Swap + (Container : Vector; + I, J : Index_Type) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + EI : Element_Type renames Container.Elements (T'(I)).all; + EJ : Element_Type renames Container.Elements (T'(J)).all; - procedure Delete (Container : in out Vector; - Position : in out Cursor; - Count : in Count_Type := 1) is begin - - if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) - then + if Container.Lock > 0 then raise Program_Error; end if; - if Position.Container = null - or else Position.Index > Container.Last + declare + EI_Copy : constant Element_Type := EI; + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + procedure Swap (I, J : Cursor) + is + begin + if I.Container = null + or else J.Container = null then - Position := No_Element; - return; + raise Constraint_Error; end if; - Delete (Container, Position.Index, Count); - - if Position.Index <= Container.Last then - Position := (Container'Unchecked_Access, Position.Index); - else - Position := No_Element; + if I.Container /= J.Container then + raise Program_Error; end if; - end Delete; + Swap (I.Container.all, I.Index, J.Index); + end Swap; + --------------- + -- To_Cursor -- + --------------- - function First (Container : Vector) return Cursor is + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor + is begin - if Is_Empty (Container) then + if Index not in Index_Type'First .. Container.Last then return No_Element; end if; - return (Container'Unchecked_Access, Index_Type'First); - end First; + return Cursor'(Container'Unchecked_Access, Index); + end To_Cursor; + -------------- + -- To_Index -- + -------------- - function Last (Container : Vector) return Cursor is + function To_Index (Position : Cursor) return Extended_Index is begin - if Is_Empty (Container) then - return No_Element; + if Position.Container = null then + return No_Index; end if; - return (Container'Unchecked_Access, Container.Last); - end Last; + if Position.Index <= Position.Container.Last then + return Position.Index; + end if; + return No_Index; + end To_Index; - procedure Swap (I, J : in Cursor) is + --------------- + -- To_Vector -- + --------------- - -- NOTE: I've liberalized the behavior here, to - -- allow I and J to designate different containers. - -- TODO: I think this is suppose to raise P_E. + function To_Vector (Length : Count_Type) return Vector is + begin + if Length = 0 then + return Empty_Vector; + end if; - subtype TI is Index_Type'Base range - Index_Type'First .. I.Container.Last; + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : constant Index_Type := Index_Type (Last_As_Int); + Elements : constant Elements_Access := + new Elements_Type (Index_Type'First .. Last); + begin + return (Controlled with Elements, Last, 0, 0); + end; + end To_Vector; - EI : Element_Access renames - I.Container.Elements (TI'(I.Index)); + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector + is + begin + if Length = 0 then + return Empty_Vector; + end if; - EI_Copy : constant Element_Access := EI; + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : constant Index_Type := Index_Type (Last_As_Int); + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); + begin + for Indx in Elements'Range loop + begin + Elements (Indx) := new Element_Type'(New_Item); + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (Indx) loop + Free (Elements (J)); + end loop; - subtype TJ is Index_Type'Base range - Index_Type'First .. J.Container.Last; + Free (Elements); + raise; + end; - EJ : Element_Access renames - J.Container.Elements (TJ'(J.Index)); + end loop; - begin + return (Controlled with Elements, Last, 0, 0); + end; + end To_Vector; - EI := EJ; - EJ := EI_Copy; + -------------------- + -- Update_Element -- + -------------------- - end Swap; + procedure Update_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + E : Element_Type renames Container.Elements (T'(Index)).all; - function Find (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; begin + B := B + 1; + L := L + 1; - if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; - end if; - - for I in Position.Index .. Container.Last loop - if Container.Elements (I) /= null - and then Container.Elements (I).all = Item - then - return (Container'Unchecked_Access, I); - end if; - end loop; - - return No_Element; + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; - end Find; + L := L - 1; + B := B - 1; + end Update_Element; + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + Update_Element (Position.Container.all, Position.Index, Process); + end Update_Element; - function Reverse_Find (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor is + ----------- + -- Write -- + ----------- - Last : Index_Type'Base; + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Vector) + is + N : constant Count_Type := Length (Container); begin + Count_Type'Base'Write (Stream, N); - if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; - end if; - - if Position.Container = null - or else Position.Index > Container.Last - then - Last := Container.Last; - else - Last := Position.Index; + if N = 0 then + return; end if; - for I in reverse Index_Type'First .. Last loop - if Container.Elements (I) /= null - and then Container.Elements (I).all = Item - then - return (Container'Unchecked_Access, I); - end if; - end loop; + declare + E : Elements_Type renames Container.Elements.all; - return No_Element; + begin + for Indx in Index_Type'First .. Container.Last loop - end Reverse_Find; + -- There's another way to do this. Instead a separate + -- Boolean for each element, you could write a Boolean + -- followed by a count of how many nulls or non-nulls + -- follow in the array. Alternately you could use a + -- signed integer, and use the sign as the indicator + -- of null-ness. + if E (Indx) = null then + Boolean'Write (Stream, False); + else + Boolean'Write (Stream, True); + Element_Type'Output (Stream, E (Indx).all); + end if; + end loop; + end; + end Write; end Ada.Containers.Indefinite_Vectors; - |