summaryrefslogtreecommitdiff
path: root/gcc/ada/a-coinve.adb
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2005-06-16 08:56:24 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2005-06-16 08:56:24 +0000
commitca64eb07de27f9c20b0b5b909f314afaae888e81 (patch)
tree60bbc3a40631ce4a825ff74330cd04720cf0d624 /gcc/ada/a-coinve.adb
parentd25effa88fc45b26bb1ac6135a42785ddb699037 (diff)
downloadgcc-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.adb3027
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;
-