summaryrefslogtreecommitdiff
path: root/gcc/ada/a-coinve.adb
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2005-02-09 11:14:42 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2005-02-09 11:14:42 +0000
commit7ce1e9473ed905b0abcbe66b2fef2c81c8e3cffa (patch)
treefc2c56125c477bf3312555b0de2bc5a1860ba895 /gcc/ada/a-coinve.adb
parent661a91eca8edc1eb8d2516f867db70a441df2bcf (diff)
downloadgcc-7ce1e9473ed905b0abcbe66b2fef2c81c8e3cffa.tar.gz
* a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads,
a-crbtgk.adb, a-crbltr.ads, a-coprnu.ads, a-coprnu.adb, a-coorse.ads, a-coorse.adb, a-convec.ads, a-convec.adb, a-contai.ads, 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-cgcaso.ads, a-cgcaso.adb, a-cgarso.ads, a-cgarso.adb, a-cdlili.ads, a-cdlili.adb, a-cgaaso.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, a-coorma.ads, a-swunha.ads, a-stunha.ads, a-ciormu.ads, a-coormu.ads, a-rbtgso.ads, a-swunha.adb, a-stunha.adb, a-cgaaso.ads, a-ciorma.adb, a-coorma.adb, a-secain.adb, a-secain.ads, a-slcain.ads, a-slcain.adb, a-shcain.ads, a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads, a-stwiha.adb, a-strhas.ads, a-strhas.adb, a-chzla1.ads, a-chzla9.ads, a-lfztio.ads, a-liztio.ads, a-llfzti.ads, a-llizti.ads, a-sfztio.ads, a-siztio.ads, a-ssizti.ads, a-stzbou.adb, a-stzbou.ads, a-stzfix.adb, a-stzfix.ads, a-stzhas.adb, a-stzhas.ads, a-stzmap.adb, a-stzmap.ads, a-stzsea.adb, a-stzsea.ads, a-stzsup.adb, a-stzsup.ads, a-stzunb.adb, a-stzunb.ads, a-swunau.adb, a-swunau.ads, a-szmzco.ads, a-szunau.adb, a-szunau.ads, a-szunha.adb, a-szunha.ads, a-szuzti.adb, a-szuzti.ads, a-tiunio.ads, a-wwunio.ads, a-ztcoau.adb, a-ztcoau.ads, a-ztcoio.adb, a-ztcoio.ads, a-ztcstr.adb, a-ztcstr.ads, a-ztdeau.adb, a-ztdeau.ads, a-ztdeio.adb, a-ztdeio.ads, a-ztedit.adb, a-ztedit.ads, a-ztenau.adb, a-ztenau.ads, a-ztenio.adb, a-ztenio.ads, a-ztexio.adb, a-ztexio.ads, a-ztfiio.adb, a-ztfiio.ads, a-ztflau.adb, a-ztflau.ads, a-ztflio.adb, a-ztflio.ads, a-ztgeau.adb, a-ztgeau.ads, a-ztinau.adb, a-ztinau.ads, a-ztinio.adb, a-ztinio.ads, a-ztmoau.adb, a-ztmoau.ads, a-ztmoio.adb, a-ztmoio.ads, a-zttest.adb, a-zttest.ads, a-zzunio.ads: New files. Part of new Ada 2005 library. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@94764 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/a-coinve.adb')
-rw-r--r--gcc/ada/a-coinve.adb2171
1 files changed, 2171 insertions, 0 deletions
diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb
new file mode 100644
index 00000000000..c997430f6f0
--- /dev/null
+++ b/gcc/ada/a-coinve.adb
@@ -0,0 +1,2171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_VECTORS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- This unit has originally being developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Generic_Array_Sort;
+with Ada.Unchecked_Deallocation;
+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);
+
+ 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;
+
+ 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;
+
+ Container.Last := I;
+
+ end loop;
+
+ end;
+
+ end Adjust;
+
+
+ procedure Finalize (Container : in out Vector) is
+
+ E : Elements_Access := Container.Elements;
+ L : constant Index_Type'Base := Container.Last;
+
+ begin
+
+ Container.Elements := null;
+ Container.Last := Index_Type'Pred (Index_Type'First);
+
+ for I in Index_Type'First .. L loop
+ Free (E (I));
+ end loop;
+
+ Free (E);
+
+ end Finalize;
+
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : in Vector) is
+
+ N : constant Count_Type := Length (Container);
+
+ begin
+
+ Count_Type'Base'Write (Stream, N);
+
+ if N = 0 then
+ return;
+ end if;
+
+ 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.
+
+ if E (I) = null then
+ Boolean'Write (Stream, False);
+ else
+ Boolean'Write (Stream, True);
+ Element_Type'Output (Stream, E (I).all);
+ end if;
+
+ end loop;
+ end;
+
+ end Write;
+
+
+ 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);
+
+ B : Boolean;
+
+ begin
+
+ 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;
+
+
+ function To_Vector (Length : Count_Type) return Vector is
+ begin
+
+ if Length = 0 then
+ return Empty_Vector;
+ end if;
+
+ declare
+
+ First : constant Int := Int (Index_Type'First);
+
+ Last_As_Int : constant Int'Base :=
+ First + Int (Length) - 1;
+
+ Last : 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);
+
+ end;
+
+ end To_Vector;
+
+
+
+ function To_Vector
+ (New_Item : Element_Type;
+ Length : Count_Type) return Vector is
+
+ begin
+
+ if Length = 0 then
+ return Empty_Vector;
+ end if;
+
+ declare
+
+ First : constant Int := Int (Index_Type'First);
+
+ Last_As_Int : constant Int'Base :=
+ First + Int (Length) - 1;
+
+ Last : constant Index_Type :=
+ Index_Type (Last_As_Int);
+
+ Elements : Elements_Access :=
+ new Elements_Type (Index_Type'First .. Last);
+
+ begin
+
+ for I in Elements'Range loop
+
+ begin
+ Elements (I) := new Element_Type'(New_Item);
+ 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, Last);
+
+ end;
+
+ end To_Vector;
+
+
+ function "=" (Left, Right : Vector) return Boolean is
+ begin
+
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ if Left.Last /= Right.Last then
+ return False;
+ end if;
+
+ for I 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
+ -- null. If it's a bounded error then an exception might
+ -- propagate, or it might not. We take advantage of that
+ -- permission here to allow empty elements to be compared.
+ --
+ -- Whether this is the right decision I'm not really sure. If
+ -- you have a contrary argument then let me know.
+ -- END NOTE.
+
+ if Left.Elements (I) = null then
+
+ if Right.Elements (I) /= null then
+ return False;
+ end if;
+
+ elsif Right.Elements (I) = null then
+
+ return False;
+
+ elsif Left.Elements (I).all /= Right.Elements (I).all then
+
+ return False;
+
+ end if;
+
+ end loop;
+
+ return True;
+
+ end "=";
+
+
+ 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 Count_Type (N);
+ end Length;
+
+
+ function Is_Empty (Container : Vector) return Boolean is
+ begin
+ return Container.Last < Index_Type'First;
+ end Is_Empty;
+
+
+ procedure Set_Length
+ (Container : in out Vector;
+ Length : in Count_Type) is
+
+ N : constant Count_Type := Indefinite_Vectors.Length (Container);
+
+ begin
+
+ if Length = N then
+ return;
+ end if;
+
+ if Length = 0 then
+ Clear (Container);
+ return;
+ end if;
+
+ declare
+ Last_As_Int : constant Int'Base :=
+ Int (Index_Type'First) + Int (Length) - 1;
+
+ Last : constant Index_Type :=
+ Index_Type (Last_As_Int);
+ begin
+
+ if Length > N then
+
+ if Length > Capacity (Container) then
+ Reserve_Capacity (Container, Capacity => Length);
+ end if;
+
+ Container.Last := Last;
+
+ return;
+
+ end if;
+
+ for I in reverse Index_Type'Succ (Last) .. Container.Last loop
+
+ declare
+ X : Element_Access := Container.Elements (I);
+ begin
+ Container.Elements (I) := null;
+ Container.Last := Index_Type'Pred (Container.Last);
+ Free (X);
+ end;
+
+ end loop;
+
+ end;
+
+ end Set_Length;
+
+
+ procedure Clear (Container : in out Vector) is
+ begin
+
+ for I in reverse Index_Type'First .. Container.Last loop
+
+ declare
+ X : Element_Access := Container.Elements (I);
+ begin
+ Container.Elements (I) := null;
+ Container.Last := Index_Type'Pred (I);
+ Free (X);
+ end;
+
+ end loop;
+
+ end Clear;
+
+
+ procedure Append (Container : in out Vector;
+ New_Item : in Element_Type;
+ Count : in Count_Type := 1) is
+ begin
+ if Count = 0 then
+ return;
+ end if;
+
+ Insert
+ (Container,
+ Index_Type'Succ (Container.Last),
+ New_Item,
+ Count);
+ end Append;
+
+
+ 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);
+
+ 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);
+
+ Index : Index_Type;
+
+ Dst_Last : Index_Type;
+ Dst : Elements_Access;
+
+ begin
+
+ 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_First : constant Before_Subtype := Before;
+
+ Old_First_As_Int : constant Int := Int (Old_First);
+
+ New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
+ begin
+ Index := Index_Type (New_First_As_Int);
+ 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 := Index_Type'Pred (Index_Type'First);
+
+ for I in Container.Elements'Range loop
+ Container.Elements (I) := new Element_Type'(New_Item);
+ Container.Last := I;
+ 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);
+ 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 I in Before .. Index_Type'Pred (Index) loop
+
+ begin
+ E (I) := new Element_Type'(New_Item);
+ exception
+ when others =>
+ E (I .. 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 :=
+ 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
+ Size := 1;
+ end if;
+
+ while Size < New_Size loop
+ Size := 2 * Size;
+ end loop;
+
+ 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));
+
+ Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ end;
+
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := Dst;
+ Container.Last := New_Last;
+
+ Free (X);
+ end;
+
+ -- 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.
+
+ for I in Before .. Index_Type'Pred (Index) loop
+ Dst (I) := new Element_Type'(New_Item);
+ end loop;
+
+ end Insert;
+
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : in Extended_Index;
+ Count : in Count_Type := 1) is
+
+ Old_Last_As_Int : constant Int := Int (Container.Last);
+
+ 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);
+
+ Index : Index_Type;
+
+ Dst_Last : Index_Type;
+ Dst : Elements_Access;
+
+ begin
+
+ 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_First : constant Before_Subtype := Before;
+
+ Old_First_As_Int : constant Int := Int (Old_First);
+
+ New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
+ begin
+ Index := Index_Type (New_First_As_Int);
+ 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;
+ 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;
+ 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;
+
+ 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
+ Size := 1;
+ end if;
+
+ while Size < New_Size loop
+ Size := 2 * Size;
+ end loop;
+
+ 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));
+
+ Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ end;
+
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := Dst;
+ Container.Last := New_Last;
+
+ 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;
+
+
+ procedure Delete_Last (Container : in out Vector;
+ Count : in 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;
+
+ 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
+ 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);
+
+ J_As_Int : constant Int'Base := I_As_Int + N;
+ J : constant Index_Type'Base := Index_Type'Base (J_As_Int);
+
+ E : Elements_Type renames Container.Elements.all;
+
+ New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
+
+ New_Last : constant Extended_Index :=
+ Extended_Index (New_Last_As_Int);
+
+ begin
+
+ for K in I .. Index_Type'Pred (J) loop
+
+ 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
+
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := null;
+ Free (X);
+ end;
+
+ elsif 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;
+
+ end if;
+
+ if Container.Elements = null then
+
+ 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);
+ begin
+ Container.Elements := new Array_Subtype;
+ end;
+
+ return;
+
+ end if;
+
+ 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;
+
+ end if;
+
+ if Capacity = Container.Elements'Length 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;
+
+
+ procedure Replace_Element (Container : in Vector;
+ Index : in Index_Type;
+ By : in Element_Type) is
+
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
+
+ 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);
+
+ 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;
+
+ 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;
+ else
+ Last := 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;
+
+ end Reverse_Find_Index;
+
+
+ function Contains (Container : Vector;
+ Item : Element_Type) return Boolean is
+ begin
+ return Find_Index (Container, Item) /= No_Index;
+ end Contains;
+
+
+
+ procedure Assign
+ (Target : in out Vector;
+ Source : in Vector) is
+
+ N : constant Count_Type := Length (Source);
+
+ begin
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Clear (Target);
+
+ if N = 0 then
+ return;
+ end if;
+
+ if N > Capacity (Target) then
+ Reserve_Capacity (Target, Capacity => N);
+ 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;
+
+ Target.Last := I;
+
+ end loop;
+
+ end Assign;
+
+
+ procedure Move
+ (Target : in out Vector;
+ Source : in out Vector) is
+
+ X : Elements_Access := Target.Elements;
+
+ begin
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Last >= Index_Type'First 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;
+
+
+ function "&" (Left, Right : Vector) return Vector is
+
+ LN : constant Count_Type := Length (Left);
+ RN : constant Count_Type := Length (Right);
+
+ begin
+
+ if LN = 0 then
+
+ if RN = 0 then
+ return Empty_Vector;
+ end if;
+
+ declare
+ RE : Elements_Type renames
+ Right.Elements (Index_Type'First .. Right.Last);
+
+ Elements : Elements_Access :=
+ new Elements_Type (RE'Range);
+ 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);
+ end;
+
+ end if;
+
+ if RN = 0 then
+
+ declare
+ LE : Elements_Type renames
+ Left.Elements (Index_Type'First .. Left.Last);
+
+ Elements : Elements_Access :=
+ new Elements_Type (LE'Range);
+ 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;
+
+ return (Controlled with Elements, Left.Last);
+ end;
+
+ end if;
+
+ declare
+
+ 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);
+
+ Elements : Elements_Access :=
+ new Elements_Type (Index_Type'First .. Last);
+
+ I : Index_Type'Base := Index_Type'Pred (Index_Type'First);
+
+ begin
+
+ 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;
+
+ Free (Elements);
+ raise;
+ end;
+
+ end loop;
+
+ return (Controlled with Elements, Last);
+ 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;
+
+ 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);
+
+ 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;
+
+ 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);
+ 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;
+
+ begin
+
+ begin
+ Elements (I) := new Element_Type'(Left);
+ exception
+ when others =>
+ Free (Elements);
+ raise;
+ end;
+
+ 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;
+
+ Free (Elements);
+ raise;
+ end;
+
+ end loop;
+
+ return (Controlled with Elements, Last);
+ 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;
+
+ 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);
+
+ end "&";
+
+
+ function To_Cursor (Container : Vector;
+ Index : Extended_Index)
+ return Cursor is
+ begin
+ if Index not in Index_Type'First .. Container.Last then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Index);
+ end To_Cursor;
+
+
+ function To_Index (Position : Cursor) return Extended_Index is
+ begin
+ if Position.Container = null then
+ return No_Index;
+ end if;
+
+ if Position.Index <= Position.Container.Last then
+ return Position.Index;
+ end if;
+
+ return No_Index;
+ end To_Index;
+
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Element (Position.Container.all, Position.Index);
+ end Element;
+
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+
+ if Position.Container = null then
+ return No_Element;
+ end if;
+
+ if Position.Index < Position.Container.Last then
+ return (Position.Container, Index_Type'Succ (Position.Index));
+ end if;
+
+ return No_Element;
+
+ end Next;
+
+
+ function Previous (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));
+ end if;
+
+ return No_Element;
+
+ end Previous;
+
+
+ procedure Next (Position : in out Cursor) is
+ begin
+
+ if Position.Container = null then
+ return;
+ end if;
+
+ if Position.Index < Position.Container.Last then
+ Position.Index := Index_Type'Succ (Position.Index);
+ else
+ Position := No_Element;
+ end if;
+
+ end Next;
+
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+
+ if Position.Container = null then
+ return;
+ end if;
+
+ if Position.Index > Index_Type'First then
+ Position.Index := Index_Type'Pred (Position.Index);
+ else
+ Position := No_Element;
+ end if;
+
+ end Previous;
+
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+
+ if Position.Container = null then
+ return False;
+ end if;
+
+ return Position.Index <= Position.Container.Last;
+
+ end Has_Element;
+
+
+ procedure Iterate
+ (Container : in Vector;
+ Process : not null access procedure (Position : in Cursor)) is
+ begin
+
+ for I in Index_Type'First .. Container.Last loop
+ Process (Cursor'(Container'Unchecked_Access, I));
+ end loop;
+
+ end Iterate;
+
+
+ procedure Reverse_Iterate
+ (Container : in Vector;
+ Process : not null access procedure (Position : in Cursor)) is
+ begin
+
+ for I in reverse Index_Type'First .. Container.Last loop
+ Process (Cursor'(Container'Unchecked_Access, I));
+ end loop;
+
+ end Reverse_Iterate;
+
+
+ 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;
+ begin
+ Process (E (T'(Position.Index)).all);
+ end Query_Element;
+
+
+ procedure Update_Element
+ (Position : in Cursor;
+ Process : not null access procedure (Element : in out 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;
+ begin
+ Process (E (T'(Position.Index)).all);
+ end Update_Element;
+
+
+ procedure Replace_Element (Position : in Cursor;
+ By : 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;
+
+ X : Element_Access := E (T'(Position.Index));
+ begin
+ E (T'(Position.Index)) := new Element_Type'(By);
+ Free (X);
+ end Replace_Element;
+
+
+ procedure Insert (Container : in out Vector;
+ Before : in Extended_Index;
+ New_Item : in Vector) is
+
+ N : constant Count_Type := Length (New_Item);
+
+ begin
+
+ if N = 0 then
+ return;
+ 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;
+
+ Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
+
+ Dst_Index : Index_Type'Base := Index_Type'Pred (Before);
+
+ Dst : Elements_Type renames
+ Container.Elements (Before .. Dst_Last);
+ begin
+
+ 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);
+ 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;
+ end;
+
+ declare
+ subtype Src_Index_Subtype is Index_Type'Base range
+ Index_Type'Succ (Dst_Last) .. 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);
+
+ if Src (Src_Index) /= null then
+ Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
+ end if;
+ end loop;
+ end;
+
+ end;
+
+ else
+
+ 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);
+
+ Dst_Index : Index_Type'Base := Index_Type'Pred (Before);
+
+ Src : Elements_Type renames
+ New_Item.Elements (Index_Type'First .. New_Item.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;
+ end;
+
+ end if;
+
+ end Insert;
+
+
+ procedure Insert (Container : in out Vector;
+ Before : in Cursor;
+ New_Item : in 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 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;
+ 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
+ raise Program_Error;
+ end if;
+
+ if Is_Empty (New_Item) then
+
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Position := No_Element;
+ else
+ Position := (Container'Unchecked_Access, Before.Index);
+ end if;
+
+ 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;
+
+ Insert (Container, Index, New_Item);
+
+ Position := (Container'Unchecked_Access, Index);
+
+ end Insert;
+
+
+ procedure Insert (Container : in out Vector;
+ Before : in Cursor;
+ New_Item : in Element_Type;
+ Count : in Count_Type := 1) 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 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;
+
+ Insert (Container, Index, New_Item, Count);
+
+ end Insert;
+
+
+ procedure Insert (Container : in out Vector;
+ Before : in Cursor;
+ New_Item : in Element_Type;
+ Position : out Cursor;
+ Count : in Count_Type := 1) 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 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;
+
+ 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;
+
+ Insert (Container, Index, New_Item, Count);
+
+ Position := (Container'Unchecked_Access, Index);
+
+ end Insert;
+
+
+
+ procedure Prepend (Container : in out Vector;
+ New_Item : in Vector) is
+ begin
+ Insert (Container, Index_Type'First, New_Item);
+ end Prepend;
+
+
+ procedure Append (Container : in out Vector;
+ New_Item : in Vector) is
+ begin
+ if Is_Empty (New_Item) 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 Before.Container /= null
+ and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ 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;
+
+ 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;
+
+ Insert_Space (Container, Index, Count);
+
+ Position := (Container'Unchecked_Access, Index);
+
+ end Insert_Space;
+
+
+ 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
+ raise Program_Error;
+ end if;
+
+ if Position.Container = null
+ or else Position.Index > Container.Last
+ then
+ Position := No_Element;
+ return;
+ end if;
+
+ Delete (Container, Position.Index, Count);
+
+ if Position.Index <= Container.Last then
+ Position := (Container'Unchecked_Access, Position.Index);
+ else
+ Position := No_Element;
+ end if;
+
+ end Delete;
+
+
+ function First (Container : Vector) return Cursor is
+ begin
+ if Is_Empty (Container) then
+ return No_Element;
+ end if;
+
+ return (Container'Unchecked_Access, Index_Type'First);
+ end First;
+
+
+ function Last (Container : Vector) return Cursor is
+ begin
+ if Is_Empty (Container) then
+ return No_Element;
+ end if;
+
+ return (Container'Unchecked_Access, Container.Last);
+ end Last;
+
+
+ procedure Swap (I, J : in Cursor) is
+
+ -- 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.
+
+ subtype TI is Index_Type'Base range
+ Index_Type'First .. I.Container.Last;
+
+ EI : Element_Access renames
+ I.Container.Elements (TI'(I.Index));
+
+ EI_Copy : constant Element_Access := EI;
+
+ subtype TJ is Index_Type'Base range
+ Index_Type'First .. J.Container.Last;
+
+ EJ : Element_Access renames
+ J.Container.Elements (TJ'(J.Index));
+
+ begin
+
+ EI := EJ;
+ EJ := EI_Copy;
+
+ end Swap;
+
+
+ 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)
+ 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;
+
+ end Find;
+
+
+ function Reverse_Find (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor is
+
+ Last : Index_Type'Base;
+
+ begin
+
+ 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;
+ 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;
+
+ return No_Element;
+
+ end Reverse_Find;
+
+
+end Ada.Containers.Indefinite_Vectors;
+