+2005-02-09 Arnaud Charlet <charlet@adacore.com>
+
+ * 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.
+
2005-01-27 Laurent GUERBY <laurent@guerby.net>
* Makefile.in: Fix a-intnam.ads from previous commit,
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.DOUBLY_LINKED_LISTS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with System; use type System.Address;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Containers.Doubly_Linked_Lists is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Delete_Node
+ (Container : in out List;
+ Node : in out Node_Access);
+
+ procedure Insert_Internal
+ (Container : in out List;
+ Before : Node_Access;
+ New_Node : Node_Access);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : List) return Boolean is
+ L : Node_Access := Left.First;
+ R : Node_Access := Right.First;
+
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ if Left.Length /= Right.Length then
+ return False;
+ end if;
+
+ for J in 1 .. Left.Length loop
+ if L.Element /= R.Element then
+ return False;
+ end if;
+
+ L := L.Next;
+ R := R.Next;
+ end loop;
+
+ return True;
+ end "=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out List) is
+ Src : Node_Access := Container.First;
+ Length : constant Count_Type := Container.Length;
+
+ begin
+ if Src = null then
+ pragma Assert (Container.Last = null);
+ pragma Assert (Length = 0);
+ return;
+ end if;
+
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+ pragma Assert (Length > 0);
+
+ Container.First := null;
+ Container.Last := null;
+ Container.Length := 0;
+
+ Container.First := new Node_Type'(Src.Element, null, null);
+
+ Container.Last := Container.First;
+ loop
+ Container.Length := Container.Length + 1;
+ Src := Src.Next;
+ exit when Src = null;
+ Container.Last.Next := new Node_Type'(Element => Src.Element,
+ Prev => Container.Last,
+ Next => null);
+ Container.Last := Container.Last.Next;
+ end loop;
+
+ pragma Assert (Container.Length = Length);
+ end Adjust;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ begin
+ Insert (Container, No_Element, New_Item, Count);
+ end Append;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out List) is
+ begin
+ Delete_Last (Container, Count => Container.Length);
+ end Clear;
+
+ --------------
+ -- Continue --
+ --------------
+
+ function Contains
+ (Container : List;
+ Item : Element_Type) return Boolean
+ is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out List;
+ Position : in out Cursor;
+ Count : Count_Type := 1)
+ is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ for Index in 1 .. Count loop
+ Delete_Node (Container, Position.Node);
+
+ if Position.Node = null then
+ Position.Container := null;
+ return;
+ end if;
+ end loop;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First
+ (Container : in out List;
+ Count : Count_Type := 1)
+ is
+ Node : Node_Access := Container.First;
+ begin
+ for J in 1 .. Count_Type'Min (Count, Container.Length) loop
+ Delete_Node (Container, Node);
+ end loop;
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last
+ (Container : in out List;
+ Count : Count_Type := 1)
+ is
+ Node : Node_Access;
+ begin
+ for J in 1 .. Count_Type'Min (Count, Container.Length) loop
+ Node := Container.Last;
+ Delete_Node (Container, Node);
+ end loop;
+ end Delete_Last;
+
+ -----------------
+ -- Delete_Node --
+ -----------------
+
+ procedure Delete_Node
+ (Container : in out List;
+ Node : in out Node_Access)
+ is
+ X : Node_Access := Node;
+
+ begin
+ Node := X.Next;
+ Container.Length := Container.Length - 1;
+
+ if X = Container.First then
+ Container.First := X.Next;
+
+ if X = Container.Last then
+ pragma Assert (Container.First = null);
+ pragma Assert (Container.Length = 0);
+ Container.Last := null;
+ else
+ pragma Assert (Container.Length > 0);
+ Container.First.Prev := null;
+ end if;
+
+ elsif X = Container.Last then
+ pragma Assert (Container.Length > 0);
+
+ Container.Last := X.Prev;
+ Container.Last.Next := null;
+
+ else
+ pragma Assert (Container.Length > 0);
+
+ X.Next.Prev := X.Prev;
+ X.Prev.Next := X.Next;
+ end if;
+
+ Free (X);
+ end Delete_Node;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element;
+ end Element;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor
+ is
+ Node : Node_Access := Position.Node;
+
+ begin
+ if Node = null then
+ Node := Container.First;
+ elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ while Node /= null loop
+ if Node.Element = Item then
+ return Cursor'(Container'Unchecked_Access, Node);
+ end if;
+
+ Node := Node.Next;
+ end loop;
+
+ return No_Element;
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : List) return Cursor is
+ begin
+ if Container.First = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : List) return Element_Type is
+ begin
+ return Container.First.Element;
+ end First_Element;
+
+ -------------------
+ -- Generic_Merge --
+ -------------------
+
+ procedure Generic_Merge
+ (Target : in out List;
+ Source : in out List)
+ is
+ LI : Cursor := First (Target);
+ RI : Cursor := First (Source);
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ while RI.Node /= null loop
+ if LI.Node = null then
+ Splice (Target, No_Element, Source);
+ return;
+ end if;
+
+ if RI.Node.Element < LI.Node.Element then
+ declare
+ RJ : constant Cursor := RI;
+ begin
+ RI.Node := RI.Node.Next;
+ Splice (Target, LI, Source, RJ);
+ end;
+
+ else
+ LI.Node := LI.Node.Next;
+ end if;
+ end loop;
+ end Generic_Merge;
+
+ ------------------
+ -- Generic_Sort --
+ ------------------
+
+ procedure Generic_Sort (Container : in out List) is
+
+ procedure Partition
+ (Pivot : in Node_Access;
+ Back : in Node_Access);
+
+ procedure Sort (Front, Back : Node_Access);
+
+ ---------------
+ -- Partition --
+ ---------------
+
+ procedure Partition
+ (Pivot : Node_Access;
+ Back : Node_Access)
+ is
+ Node : Node_Access := Pivot.Next;
+
+ begin
+ while Node /= Back loop
+ if Node.Element < Pivot.Element then
+ declare
+ Prev : constant Node_Access := Node.Prev;
+ Next : constant Node_Access := Node.Next;
+
+ begin
+ Prev.Next := Next;
+
+ if Next = null then
+ Container.Last := Prev;
+ else
+ Next.Prev := Prev;
+ end if;
+
+ Node.Next := Pivot;
+ Node.Prev := Pivot.Prev;
+
+ Pivot.Prev := Node;
+
+ if Node.Prev = null then
+ Container.First := Node;
+ else
+ Node.Prev.Next := Node;
+ end if;
+
+ Node := Next;
+ end;
+
+ else
+ Node := Node.Next;
+ end if;
+ end loop;
+ end Partition;
+
+ ----------
+ -- Sort --
+ ----------
+
+ procedure Sort (Front, Back : Node_Access) is
+ Pivot : Node_Access;
+
+ begin
+ if Front = null then
+ Pivot := Container.First;
+ else
+ Pivot := Front.Next;
+ end if;
+
+ if Pivot /= Back then
+ Partition (Pivot, Back);
+ Sort (Front, Pivot);
+ Sort (Pivot, Back);
+ end if;
+ end Sort;
+
+ -- Start of processing for Generic_Sort
+
+ begin
+ Sort (Front => null, Back => null);
+
+ pragma Assert (Container.Length = 0
+ or else
+ (Container.First.Prev = null
+ and then Container.Last.Next = null));
+ end Generic_Sort;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position.Container /= null and then Position.Node /= null;
+ end Has_Element;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ New_Node : Node_Access;
+
+ begin
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Count = 0 then
+ Position := Before;
+ return;
+ end if;
+
+ New_Node := new Node_Type'(New_Item, null, null);
+ Insert_Internal (Container, Before.Node, New_Node);
+
+ Position := Cursor'(Before.Container, New_Node);
+
+ for J in Count_Type'(2) .. Count loop
+ New_Node := new Node_Type'(New_Item, null, null);
+ Insert_Internal (Container, Before.Node, New_Node);
+ end loop;
+ end Insert;
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ Position : Cursor;
+ begin
+ Insert (Container, Before, New_Item, Position, Count);
+ end Insert;
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ New_Node : Node_Access;
+
+ begin
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Count = 0 then
+ Position := Before;
+ return;
+ end if;
+
+ New_Node := new Node_Type;
+ Insert_Internal (Container, Before.Node, New_Node);
+
+ Position := Cursor'(Before.Container, New_Node);
+
+ for J in Count_Type'(2) .. Count loop
+ New_Node := new Node_Type;
+ Insert_Internal (Container, Before.Node, New_Node);
+ end loop;
+ end Insert;
+
+ ---------------------
+ -- Insert_Internal --
+ ---------------------
+
+ procedure Insert_Internal
+ (Container : in out List;
+ Before : Node_Access;
+ New_Node : Node_Access)
+ is
+ begin
+ if Container.Length = 0 then
+ pragma Assert (Before = null);
+ pragma Assert (Container.First = null);
+ pragma Assert (Container.Last = null);
+
+ Container.First := New_Node;
+ Container.Last := New_Node;
+
+ elsif Before = null then
+ pragma Assert (Container.Last.Next = null);
+
+ Container.Last.Next := New_Node;
+ New_Node.Prev := Container.Last;
+
+ Container.Last := New_Node;
+
+ elsif Before = Container.First then
+ pragma Assert (Container.First.Prev = null);
+
+ Container.First.Prev := New_Node;
+ New_Node.Next := Container.First;
+
+ Container.First := New_Node;
+
+ else
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ New_Node.Next := Before;
+ New_Node.Prev := Before.Prev;
+
+ Before.Prev.Next := New_Node;
+ Before.Prev := New_Node;
+ end if;
+
+ Container.Length := Container.Length + 1;
+ end Insert_Internal;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : List) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : List;
+ Process : not null access procedure (Position : Cursor))
+ is
+ Node : Node_Access := Container.First;
+ begin
+ while Node /= null loop
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ Node := Node.Next;
+ end loop;
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : List) return Cursor is
+ begin
+ if Container.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : List) return Element_Type is
+ begin
+ return Container.Last.Element;
+ end Last_Element;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : List) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Target : in out List;
+ Source : in out List)
+ is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Length > 0 then
+ raise Constraint_Error;
+ end if;
+
+ Target.First := Source.First;
+ Source.First := null;
+
+ Target.Last := Source.Last;
+ Source.Last := null;
+
+ Target.Length := Source.Length;
+ Source.Length := 0;
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ if Position.Node = null then
+ return;
+ end if;
+
+ Position.Node := Position.Node.Next;
+
+ if Position.Node = null then
+ Position.Container := null;
+ end if;
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ return No_Element;
+ end if;
+
+ declare
+ Next_Node : constant Node_Access := Position.Node.Next;
+ begin
+ if Next_Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Next_Node);
+ end;
+ end Next;
+
+ -------------
+ -- Prepend --
+ -------------
+
+ procedure Prepend
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ begin
+ Insert (Container, First (Container), New_Item, Count);
+ end Prepend;
+
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ if Position.Node = null then
+ return;
+ end if;
+
+ Position.Node := Position.Node.Prev;
+
+ if Position.Node = null then
+ Position.Container := null;
+ end if;
+ end Previous;
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ return No_Element;
+ end if;
+
+ declare
+ Prev_Node : constant Node_Access := Position.Node.Prev;
+ begin
+ if Prev_Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Prev_Node);
+ end;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in Element_Type))
+ is
+ begin
+ Process (Position.Node.Element);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Item : out List)
+ is
+ N : Count_Type'Base;
+ X : Node_Access;
+
+ begin
+ Clear (Item); -- ???
+ Count_Type'Base'Read (Stream, N);
+
+ if N = 0 then
+ return;
+ end if;
+
+ X := new Node_Type;
+
+ begin
+ Element_Type'Read (Stream, X.Element);
+ exception
+ when others =>
+ Free (X);
+ raise;
+ end;
+
+ Item.First := X;
+ Item.Last := X;
+
+ loop
+ Item.Length := Item.Length + 1;
+ exit when Item.Length = N;
+
+ X := new Node_Type;
+
+ begin
+ Element_Type'Read (Stream, X.Element);
+ exception
+ when others =>
+ Free (X);
+ raise;
+ end;
+
+ X.Prev := Item.Last;
+ Item.Last.Next := X;
+ Item.Last := X;
+ end loop;
+ end Read;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Position : Cursor;
+ By : Element_Type)
+ is
+ begin
+ Position.Node.Element := By;
+ end Replace_Element;
+
+ ------------------
+ -- Reverse_Find --
+ ------------------
+
+ function Reverse_Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor
+ is
+ Node : Node_Access := Position.Node;
+
+ begin
+ if Node = null then
+ Node := Container.Last;
+ elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ while Node /= null loop
+ if Node.Element = Item then
+ return Cursor'(Container'Unchecked_Access, Node);
+ end if;
+
+ Node := Node.Prev;
+ end loop;
+
+ return No_Element;
+ end Reverse_Find;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : List;
+ Process : not null access procedure (Position : Cursor))
+ is
+ Node : Node_Access := Container.Last;
+ begin
+ while Node /= null loop
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ Node := Node.Prev;
+ end loop;
+ end Reverse_Iterate;
+
+ ------------------
+ -- Reverse_List --
+ ------------------
+
+ procedure Reverse_List (Container : in out List) is
+ I : Node_Access := Container.First;
+ J : Node_Access := Container.Last;
+
+ procedure Swap (L, R : Node_Access);
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (L, R : Node_Access) is
+ LN : constant Node_Access := L.Next;
+ LP : constant Node_Access := L.Prev;
+
+ RN : constant Node_Access := R.Next;
+ RP : constant Node_Access := R.Prev;
+
+ begin
+ if LP /= null then
+ LP.Next := R;
+ end if;
+
+ if RN /= null then
+ RN.Prev := L;
+ end if;
+
+ L.Next := RN;
+ R.Prev := LP;
+
+ if LN = R then
+ pragma Assert (RP = L);
+
+ L.Prev := R;
+ R.Next := L;
+
+ else
+ L.Prev := RP;
+ RP.Next := L;
+
+ R.Next := LN;
+ LN.Prev := R;
+ end if;
+ end Swap;
+
+ -- Start of processing for Reverse_List
+
+ begin
+ if Container.Length <= 1 then
+ return;
+ end if;
+
+ Container.First := J;
+ Container.Last := I;
+ loop
+ Swap (L => I, R => J);
+
+ J := J.Next;
+ exit when I = J;
+
+ I := I.Prev;
+ exit when I = J;
+
+ Swap (L => J, R => I);
+
+ I := I.Next;
+ exit when I = J;
+
+ J := J.Prev;
+ exit when I = J;
+ end loop;
+
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+ end Reverse_List;
+
+ ------------
+ -- Splice --
+ ------------
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List)
+ is
+ begin
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Target'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Target'Address = Source'Address
+ or else Source.Length = 0
+ then
+ return;
+ end if;
+
+ if Target.Length = 0 then
+ pragma Assert (Before = No_Element);
+
+ Target.First := Source.First;
+ Target.Last := Source.Last;
+
+ elsif Before.Node = null then
+ pragma Assert (Target.Last.Next = null);
+
+ Target.Last.Next := Source.First;
+ Source.First.Prev := Target.Last;
+
+ Target.Last := Source.Last;
+
+ elsif Before.Node = Target.First then
+ pragma Assert (Target.First.Prev = null);
+
+ Source.Last.Next := Target.First;
+ Target.First.Prev := Source.Last;
+
+ Target.First := Source.First;
+
+ else
+ Before.Node.Prev.Next := Source.First;
+ Source.First.Prev := Before.Node.Prev;
+
+ Before.Node.Prev := Source.Last;
+ Source.Last.Next := Before.Node;
+ end if;
+
+ Source.First := null;
+ Source.Last := null;
+
+ Target.Length := Target.Length + Source.Length;
+ Source.Length := 0;
+ end Splice;
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Position : Cursor)
+ is
+ X : Node_Access := Position.Node;
+
+ begin
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Target'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Position.Container /= null
+ and then Position.Container /= List_Access'(Target'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if X = null
+ or else X = Before.Node
+ or else X.Next = Before.Node
+ then
+ return;
+ end if;
+
+ pragma Assert (Target.Length > 0);
+
+ if Before.Node = null then
+ pragma Assert (X /= Target.Last);
+
+ if X = Target.First then
+ Target.First := X.Next;
+ Target.First.Prev := null;
+ else
+ X.Prev.Next := X.Next;
+ X.Next.Prev := X.Prev;
+ end if;
+
+ Target.Last.Next := X;
+ X.Prev := Target.Last;
+
+ Target.Last := X;
+ Target.Last.Next := null;
+
+ return;
+ end if;
+
+ if Before.Node = Target.First then
+ pragma Assert (X /= Target.First);
+
+ if X = Target.Last then
+ Target.Last := X.Prev;
+ Target.Last.Next := null;
+ else
+ X.Prev.Next := X.Next;
+ X.Next.Prev := X.Prev;
+ end if;
+
+ Target.First.Prev := X;
+ X.Next := Target.First;
+
+ Target.First := X;
+ Target.First.Prev := null;
+
+ return;
+ end if;
+
+ if X = Target.First then
+ Target.First := X.Next;
+ Target.First.Prev := null;
+
+ elsif X = Target.Last then
+ Target.Last := X.Prev;
+ Target.Last.Next := null;
+
+ else
+ X.Prev.Next := X.Next;
+ X.Next.Prev := X.Prev;
+ end if;
+
+ Before.Node.Prev.Next := X;
+ X.Prev := Before.Node.Prev;
+
+ Before.Node.Prev := X;
+ X.Next := Before.Node;
+ end Splice;
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List;
+ Position : Cursor)
+ is
+ X : Node_Access := Position.Node;
+
+ begin
+ if Target'Address = Source'Address then
+ Splice (Target, Before, Position);
+ return;
+ end if;
+
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Target'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Position.Container /= null
+ and then Position.Container /= List_Access'(Source'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if X = null then
+ return;
+ end if;
+
+ pragma Assert (Source.Length > 0);
+ pragma Assert (Source.First.Prev = null);
+ pragma Assert (Source.Last.Next = null);
+
+ if X = Source.First then
+ Source.First := X.Next;
+ Source.First.Prev := null;
+
+ if X = Source.Last then
+ pragma Assert (Source.First = null);
+ pragma Assert (Source.Length = 1);
+ Source.Last := null;
+ end if;
+
+ elsif X = Source.Last then
+ Source.Last := X.Prev;
+ Source.Last.Next := null;
+
+ else
+ X.Prev.Next := X.Next;
+ X.Next.Prev := X.Prev;
+ end if;
+
+ if Target.Length = 0 then
+ pragma Assert (Before = No_Element);
+ pragma Assert (Target.First = null);
+ pragma Assert (Target.Last = null);
+
+ Target.First := X;
+ Target.Last := X;
+
+ elsif Before.Node = null then
+ Target.Last.Next := X;
+ X.Next := Target.Last;
+
+ Target.Last := X;
+ Target.Last.Next := null;
+
+ elsif Before.Node = Target.First then
+ Target.First.Prev := X;
+ X.Next := Target.First;
+
+ Target.First := X;
+ Target.First.Prev := null;
+
+ else
+ Before.Node.Prev.Next := X;
+ X.Prev := Before.Node.Prev;
+
+ Before.Node.Prev := X;
+ X.Next := Before.Node;
+ end if;
+
+ Target.Length := Target.Length + 1;
+ Source.Length := Source.Length - 1;
+ end Splice;
+
+ ----------
+ -- Swap --
+ ----------
+
+ -- Is this defined when I and J designate elements in different containers,
+ -- or should it raise an exception (Program_Error)???
+
+ procedure Swap (I, J : in Cursor) is
+ EI : constant Element_Type := I.Node.Element;
+ begin
+ I.Node.Element := J.Node.Element;
+ J.Node.Element := EI;
+ end Swap;
+
+ ----------------
+ -- Swap_Links --
+ ----------------
+
+ procedure Swap_Links
+ (Container : in out List;
+ I, J : Cursor)
+ is
+ begin
+ if I = No_Element
+ or else J = No_Element
+ then
+ raise Constraint_Error;
+ end if;
+
+ if I.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ if J.Container /= I.Container then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length >= 1);
+
+ if I.Node = J.Node then
+ return;
+ end if;
+
+ pragma Assert (Container.Length >= 2);
+
+ declare
+ I_Next : constant Cursor := Next (I);
+
+ begin
+ if I_Next = J then
+ Splice (Container, Before => I, Position => J);
+
+ else
+ declare
+ J_Next : constant Cursor := Next (J);
+
+ begin
+ if J_Next = I then
+ Splice (Container, Before => J, Position => I);
+
+ else
+ pragma Assert (Container.Length >= 3);
+
+ Splice (Container, Before => I_Next, Position => J);
+ Splice (Container, Before => J_Next, Position => I);
+ end if;
+ end;
+ end if;
+ end;
+ end Swap_Links;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type)) is
+ begin
+ Process (Position.Node.Element);
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Item : List)
+ is
+ Node : Node_Access := Item.First;
+
+ begin
+ Count_Type'Base'Write (Stream, Item.Length);
+
+ while Node /= null loop
+ Element_Type'Write (Stream, Node.Element);
+ Node := Node.Next;
+ end loop;
+ end Write;
+
+end Ada.Containers.Doubly_Linked_Lists;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.DOUBLY_LINKED_LISTS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+ type Element_Type is private;
+
+ with function "=" (Left, Right : Element_Type)
+ return Boolean is <>;
+
+package Ada.Containers.Doubly_Linked_Lists is
+ pragma Preelaborate (Doubly_Linked_Lists);
+
+ type List is tagged private;
+
+ type Cursor is private;
+
+ Empty_List : constant List;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : List) return Boolean;
+
+ function Length (Container : List) return Count_Type;
+
+ function Is_Empty (Container : List) return Boolean;
+
+ procedure Clear (Container : in out List);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Replace_Element
+ (Position : Cursor;
+ By : Element_Type);
+
+ procedure Move
+ (Target : in out List;
+ Source : in out List);
+
+ procedure Prepend
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Append
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete
+ (Container : in out List;
+ Position : in out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete_First
+ (Container : in out List;
+ Count : Count_Type := 1);
+
+ procedure Delete_Last
+ (Container : in out List;
+ Count : Count_Type := 1);
+
+ generic
+ with function "<" (Left, Right : Element_Type)
+ return Boolean is <>;
+ procedure Generic_Sort (Container : in out List);
+
+ generic
+ with function "<" (Left, Right : Element_Type)
+ return Boolean is <>;
+ procedure Generic_Merge (Target : in out List; Source : in out List);
+
+ procedure Reverse_List (Container : in out List);
+
+ procedure Swap (I, J : in Cursor);
+
+ procedure Swap_Links
+ (Container : in out List;
+ I, J : Cursor);
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List);
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Position : Cursor);
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List;
+ Position : Cursor);
+
+ function First (Container : List) return Cursor;
+
+ function First_Element (Container : List) return Element_Type;
+
+ function Last (Container : List) return Cursor;
+
+ function Last_Element (Container : List) return Element_Type;
+
+ function Contains
+ (Container : List;
+ Item : Element_Type) return Boolean;
+
+ function Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Reverse_Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : List;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : List;
+ Process : not null access procedure (Position : Cursor));
+
+private
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ type Node_Type is
+ record
+ Element : Element_Type;
+ Next : Node_Access;
+ Prev : Node_Access;
+ end record;
+
+ function "=" (L, R : Node_Type) return Boolean is abstract;
+
+ use Ada.Finalization;
+
+ type List is
+ new Controlled with record
+ First : Node_Access;
+ Last : Node_Access;
+ Length : Count_Type := 0;
+ end record;
+
+ procedure Adjust (Container : in out List);
+
+ procedure Finalize (Container : in out List) renames Clear;
+
+ use Ada.Streams;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Item : out List);
+
+ for List'Read use Read;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Item : List);
+
+ for List'Write use Write;
+
+ Empty_List : constant List := List'(Controlled with null, null, 0);
+
+ type List_Access is access constant List;
+ for List_Access'Storage_Size use 0;
+
+ type Cursor is
+ record
+ Container : List_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, null);
+
+end Ada.Containers.Doubly_Linked_Lists;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+procedure Ada.Containers.Generic_Anonymous_Array_Sort
+ (First, Last : Index_Type'Base)
+is
+ Pivot, Lo, Mid, Hi : Index_Type;
+
+begin
+ if Last <= First then
+ return;
+ end if;
+
+ Lo := First;
+ Hi := Last;
+
+ if Last = Index_Type'Succ (First) then
+ if not Less (Lo, Hi) then
+ Swap (Lo, Hi);
+ end if;
+
+ return;
+ end if;
+
+ Mid := Index_Type'Val
+ (Index_Type'Pos (Lo) +
+ (Index_Type'Pos (Hi) - Index_Type'Pos (Lo)) / 2);
+
+ -- We need to figure out which case we have:
+ -- x < y < z
+ -- x < z < y
+ -- z < x < y
+ -- y < x < z
+ -- y < z < x
+ -- z < y < x
+
+ if Less (Lo, Mid) then
+ if Less (Lo, Hi) then
+ if Less (Mid, Hi) then
+ Swap (Lo, Mid);
+
+ else
+ Swap (Lo, Hi);
+
+ end if;
+
+ else
+ null; -- lo is median
+ end if;
+
+ elsif Less (Lo, Hi) then
+ null; -- lo is median
+
+ elsif Less (Mid, Hi) then
+ Swap (Lo, Hi);
+
+ else
+ Swap (Lo, Mid);
+ end if;
+
+ Pivot := Lo;
+ Outer : loop
+ loop
+ exit Outer when not (Pivot < Hi);
+
+ if Less (Hi, Pivot) then
+ Swap (Hi, Pivot);
+ Pivot := Hi;
+ Lo := Index_Type'Succ (Lo);
+ exit;
+ else
+ Hi := Index_Type'Pred (Hi);
+ end if;
+ end loop;
+
+ loop
+ exit Outer when not (Lo < Pivot);
+
+ if Less (Lo, Pivot) then
+ Lo := Index_Type'Succ (Lo);
+ else
+ Swap (Lo, Pivot);
+ Pivot := Lo;
+ Hi := Index_Type'Pred (Hi);
+ exit;
+ end if;
+ end loop;
+ end loop Outer;
+
+ Generic_Anonymous_Array_Sort (First, Index_Type'Pred (Pivot));
+ Generic_Anonymous_Array_Sort (Index_Type'Succ (Pivot), Last);
+
+end Ada.Containers.Generic_Anonymous_Array_Sort;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+generic
+ type Index_Type is (<>);
+ with function Less (Left, Right : Index_Type) return Boolean is <>;
+ with procedure Swap (Left, Right : Index_Type) is <>;
+
+procedure Ada.Containers.Generic_Anonymous_Array_Sort
+ (First, Last : in Index_Type'Base);
+
+pragma Pure (Ada.Containers.Generic_Anonymous_Array_Sort);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.GENERIC_ARRAY_SORT --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Generic_Constrained_Array_Sort;
+
+procedure Ada.Containers.Generic_Array_Sort
+ (Container : in out Array_Type)
+is
+ subtype Index_Subtype is
+ Index_Type range Container'First .. Container'Last;
+
+ subtype Array_Subtype is
+ Array_Type (Index_Subtype);
+
+ procedure Sort is
+ new Generic_Constrained_Array_Sort
+ (Index_Type => Index_Subtype,
+ Element_Type => Element_Type,
+ Array_Type => Array_Subtype,
+ "<" => "<");
+
+begin
+ Sort (Container);
+end Ada.Containers.Generic_Array_Sort;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.GENERIC_ARRAY_SORT --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+ type Index_Type is (<>);
+ type Element_Type is private;
+ type Array_Type is array (Index_Type range <>) of Element_Type;
+
+ with function "<" (Left, Right : Element_Type)
+ return Boolean is <>;
+
+procedure Ada.Containers.Generic_Array_Sort (Container : in out Array_Type);
+
+pragma Pure (Ada.Containers.Generic_Array_Sort);
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT --
+-- --
+-- 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. --
+------------------------------------------------------------------------------
+
+procedure Ada.Containers.Generic_Constrained_Array_Sort
+ (Container : in out Array_Type)
+is
+ function Is_Less (I, J : Index_Type) return Boolean;
+ pragma Inline (Is_Less);
+
+ procedure Swap (I, J : Index_Type);
+ pragma Inline (Swap);
+
+ procedure Sort (First, Last : Index_Type'Base);
+
+ -------------
+ -- Is_Less --
+ -------------
+
+ function Is_Less (I, J : Index_Type) return Boolean is
+ begin
+ return Container (I) < Container (J);
+ end Is_Less;
+
+ ----------
+ -- Sort --
+ ----------
+
+ procedure Sort (First, Last : Index_Type'Base) is
+ Pivot, Lo, Mid, Hi : Index_Type;
+
+ begin
+ if Last <= First then
+ return;
+ end if;
+
+ Lo := First;
+ Hi := Last;
+
+ if Last = Index_Type'Succ (First) then
+ if not Is_Less (Lo, Hi) then
+ Swap (Lo, Hi);
+ end if;
+
+ return;
+ end if;
+
+ Mid := Index_Type'Val
+ (Index_Type'Pos (Lo) +
+ (Index_Type'Pos (Hi) - Index_Type'Pos (Lo)) / 2);
+
+ -- We need to figure out which case we have:
+ -- x < y < z
+ -- x < z < y
+ -- z < x < y
+ -- y < x < z
+ -- y < z < x
+ -- z < y < x
+
+ if Is_Less (Lo, Mid) then
+ if Is_Less (Lo, Hi) then
+ if Is_Less (Mid, Hi) then
+ Swap (Lo, Mid);
+ else
+ Swap (Lo, Hi);
+ end if;
+
+ else
+ null; -- lo is median
+ end if;
+
+ elsif Is_Less (Lo, Hi) then
+ null; -- lo is median
+
+ elsif Is_Less (Mid, Hi) then
+ Swap (Lo, Hi);
+
+ else
+ Swap (Lo, Mid);
+ end if;
+
+ Pivot := Lo;
+
+ Outer : loop
+ loop
+ exit Outer when not (Pivot < Hi);
+
+ if Is_Less (Hi, Pivot) then
+ Swap (Hi, Pivot);
+ Pivot := Hi;
+ Lo := Index_Type'Succ (Lo);
+ exit;
+ else
+ Hi := Index_Type'Pred (Hi);
+ end if;
+ end loop;
+
+ loop
+ exit Outer when not (Lo < Pivot);
+
+ if Is_Less (Lo, Pivot) then
+ Lo := Index_Type'Succ (Lo);
+ else
+ Swap (Lo, Pivot);
+ Pivot := Lo;
+ Hi := Index_Type'Pred (Hi);
+ exit;
+ end if;
+ end loop;
+ end loop Outer;
+
+ Sort (First, Index_Type'Pred (Pivot));
+ Sort (Index_Type'Succ (Pivot), Last);
+ end Sort;
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (I, J : Index_Type) is
+ EI : constant Element_Type := Container (I);
+ begin
+ Container (I) := Container (J);
+ Container (J) := EI;
+ end Swap;
+
+-- Start of processing for Generic_Constrained_Array_Sort
+
+begin
+ Sort (Container'First, Container'Last);
+end Ada.Containers.Generic_Constrained_Array_Sort;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+ type Index_Type is (<>);
+ type Element_Type is private;
+ type Array_Type is array (Index_Type) of Element_Type;
+
+ with function "<" (Left, Right : Element_Type)
+ return Boolean is <>;
+
+procedure Ada.Containers.Generic_Constrained_Array_Sort
+ (Container : in out Array_Type);
+
+pragma Pure (Ada.Containers.Generic_Constrained_Array_Sort);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+package body Ada.Containers.Hash_Tables.Generic_Keys is
+
+ --------------------------
+ -- Delete_Key_Sans_Free --
+ --------------------------
+
+ procedure Delete_Key_Sans_Free
+ (HT : in out HT_Type;
+ Key : Key_Type;
+ X : out Node_Access)
+ is
+ Indx : Hash_Type;
+ Prev : Node_Access;
+
+ begin
+ if HT.Length = 0 then
+ X := Null_Node;
+ return;
+ end if;
+
+ Indx := Index (HT, Key);
+ X := HT.Buckets (Indx);
+
+ if X = Null_Node then
+ return;
+ end if;
+
+ if Equivalent_Keys (Key, X) then
+ HT.Buckets (Indx) := Next (X);
+ HT.Length := HT.Length - 1;
+ return;
+ end if;
+
+ loop
+ Prev := X;
+ X := Next (Prev);
+
+ if X = Null_Node then
+ return;
+ end if;
+
+ if Equivalent_Keys (Key, X) then
+ Set_Next (Node => Prev, Next => Next (X));
+ HT.Length := HT.Length - 1;
+ return;
+ end if;
+ end loop;
+ end Delete_Key_Sans_Free;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (HT : HT_Type;
+ Key : Key_Type) return Node_Access is
+
+ Indx : Hash_Type;
+ Node : Node_Access;
+
+ begin
+ if HT.Length = 0 then
+ return Null_Node;
+ end if;
+
+ Indx := Index (HT, Key);
+
+ Node := HT.Buckets (Indx);
+ while Node /= Null_Node loop
+ if Equivalent_Keys (Key, Node) then
+ return Node;
+ end if;
+ Node := Next (Node);
+ end loop;
+
+ return Null_Node;
+ end Find;
+
+ --------------------------------
+ -- Generic_Conditional_Insert --
+ --------------------------------
+
+ procedure Generic_Conditional_Insert
+ (HT : in out HT_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Success : out Boolean)
+ is
+ Indx : constant Hash_Type := Index (HT, Key);
+ B : Node_Access renames HT.Buckets (Indx);
+
+ subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
+
+ begin
+ if B = Null_Node then
+ declare
+ Length : constant Length_Subtype := HT.Length;
+ begin
+ Node := New_Node (Next => Null_Node);
+ Success := True;
+
+ B := Node;
+ HT.Length := Length + 1;
+ end;
+
+ return;
+ end if;
+
+ Node := B;
+ loop
+ if Equivalent_Keys (Key, Node) then
+ Success := False;
+ return;
+ end if;
+
+ Node := Next (Node);
+
+ exit when Node = Null_Node;
+ end loop;
+
+ declare
+ Length : constant Length_Subtype := HT.Length;
+ begin
+ Node := New_Node (Next => B);
+ Success := True;
+
+ B := Node;
+ HT.Length := Length + 1;
+ end;
+ end Generic_Conditional_Insert;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (HT : HT_Type;
+ Key : Key_Type) return Hash_Type is
+ begin
+ return Hash (Key) mod HT.Buckets'Length;
+ end Index;
+
+end Ada.Containers.Hash_Tables.Generic_Keys;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+ with package HT_Types is
+ new Generic_Hash_Table_Types (<>);
+
+ type HT_Type is new HT_Types.Hash_Table_Type with private;
+
+ use HT_Types;
+
+ Null_Node : Node_Access;
+
+ with function Next (Node : Node_Access) return Node_Access;
+
+ with procedure Set_Next
+ (Node : Node_Access;
+ Next : Node_Access);
+
+ type Key_Type (<>) is limited private;
+
+ with function Hash (Key : Key_Type) return Hash_Type;
+
+ with function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean;
+
+package Ada.Containers.Hash_Tables.Generic_Keys is
+ pragma Preelaborate;
+
+ function Index
+ (HT : HT_Type;
+ Key : Key_Type) return Hash_Type;
+ pragma Inline (Index);
+
+ procedure Delete_Key_Sans_Free
+ (HT : in out HT_Type;
+ Key : Key_Type;
+ X : out Node_Access);
+
+ function Find (HT : HT_Type; Key : Key_Type) return Node_Access;
+
+ generic
+ with function New_Node
+ (Next : Node_Access) return Node_Access;
+ procedure Generic_Conditional_Insert
+ (HT : in out HT_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Success : out Boolean);
+
+end Ada.Containers.Hash_Tables.Generic_Keys;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- This body needs commenting ???
+
+with Ada.Containers.Prime_Numbers;
+with Ada.Unchecked_Deallocation;
+
+with System; use type System.Address;
+
+package body Ada.Containers.Hash_Tables.Generic_Operations is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Rehash
+ (HT : in out Hash_Table_Type;
+ Size : Hash_Type);
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (HT : in out Hash_Table_Type) is
+ Src_Buckets : constant Buckets_Access := HT.Buckets;
+ N : constant Count_Type := HT.Length;
+ Src_Node : Node_Access;
+ Dst_Prev : Node_Access;
+
+ begin
+ HT.Buckets := null;
+ HT.Length := 0;
+
+ if N = 0 then
+ return;
+ end if;
+
+ HT.Buckets := new Buckets_Type (Src_Buckets'Range);
+
+ -- Probably we have to duplicate the Size (Src), too, in order
+ -- to guarantee that
+
+ -- Dst := Src;
+ -- Dst = Src is true
+
+ -- The only quirk is that we depend on the hash value of a dst key
+ -- to be the same as the src key from which it was copied.
+ -- If we relax the requirement that the hash value must be the
+ -- same, then of course we can't guarantee that following
+ -- assignment that Dst = Src is true ???
+
+ for Src_Index in Src_Buckets'Range loop
+ Src_Node := Src_Buckets (Src_Index);
+
+ if Src_Node /= Null_Node then
+ declare
+ Dst_Node : constant Node_Access := Copy_Node (Src_Node);
+
+ -- See note above
+
+ pragma Assert (Index (HT, Dst_Node) = Src_Index);
+
+ begin
+ HT.Buckets (Src_Index) := Dst_Node;
+ HT.Length := HT.Length + 1;
+
+ Dst_Prev := Dst_Node;
+ end;
+
+ Src_Node := Next (Src_Node);
+ while Src_Node /= Null_Node loop
+ declare
+ Dst_Node : constant Node_Access := Copy_Node (Src_Node);
+
+ -- See note above
+
+ pragma Assert (Index (HT, Dst_Node) = Src_Index);
+
+ begin
+ Set_Next (Node => Dst_Prev, Next => Dst_Node);
+ HT.Length := HT.Length + 1;
+
+ Dst_Prev := Dst_Node;
+ end;
+
+ Src_Node := Next (Src_Node);
+ end loop;
+ end if;
+ end loop;
+
+ pragma Assert (HT.Length = N);
+ end Adjust;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (HT : Hash_Table_Type) return Count_Type is
+ begin
+ if HT.Buckets = null then
+ return 0;
+ end if;
+
+ return HT.Buckets'Length;
+ end Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (HT : in out Hash_Table_Type) is
+ Index : Hash_Type := 0;
+ Node : Node_Access;
+
+ begin
+ while HT.Length > 0 loop
+ while HT.Buckets (Index) = Null_Node loop
+ Index := Index + 1;
+ end loop;
+
+ declare
+ Bucket : Node_Access renames HT.Buckets (Index);
+ begin
+ loop
+ Node := Bucket;
+ Bucket := Next (Bucket);
+ HT.Length := HT.Length - 1;
+ Free (Node);
+ exit when Bucket = Null_Node;
+ end loop;
+ end;
+ end loop;
+ end Clear;
+
+ ---------------------------
+ -- Delete_Node_Sans_Free --
+ ---------------------------
+
+ procedure Delete_Node_Sans_Free
+ (HT : in out Hash_Table_Type;
+ X : Node_Access)
+ is
+ pragma Assert (X /= Null_Node);
+
+ Indx : Hash_Type;
+ Prev : Node_Access;
+ Curr : Node_Access;
+
+ begin
+ if HT.Length = 0 then
+ raise Program_Error;
+ end if;
+
+ Indx := Index (HT, X);
+ Prev := HT.Buckets (Indx);
+
+ if Prev = Null_Node then
+ raise Program_Error;
+ end if;
+
+ if Prev = X then
+ HT.Buckets (Indx) := Next (Prev);
+ HT.Length := HT.Length - 1;
+ return;
+ end if;
+
+ if HT.Length = 1 then
+ raise Program_Error;
+ end if;
+
+ loop
+ Curr := Next (Prev);
+
+ if Curr = Null_Node then
+ raise Program_Error;
+ end if;
+
+ if Curr = X then
+ Set_Next (Node => Prev, Next => Next (Curr));
+ HT.Length := HT.Length - 1;
+ return;
+ end if;
+
+ Prev := Curr;
+ end loop;
+ end Delete_Node_Sans_Free;
+
+ ---------------------
+ -- Ensure_Capacity --
+ ---------------------
+
+ procedure Ensure_Capacity
+ (HT : in out Hash_Table_Type;
+ N : Count_Type)
+ is
+ NN : Hash_Type;
+
+ begin
+ if N = 0 then
+ if HT.Length = 0 then
+ Free (HT.Buckets);
+
+ elsif HT.Length < HT.Buckets'Length then
+ NN := Prime_Numbers.To_Prime (HT.Length);
+
+ -- ASSERT: NN >= HT.Length
+
+ if NN < HT.Buckets'Length then
+ Rehash (HT, Size => NN);
+ end if;
+ end if;
+
+ return;
+ end if;
+
+ if HT.Buckets = null then
+ NN := Prime_Numbers.To_Prime (N);
+
+ -- ASSERT: NN >= N
+
+ Rehash (HT, Size => NN);
+ return;
+ end if;
+
+ if N <= HT.Length then
+ if HT.Length >= HT.Buckets'Length then
+ return;
+ end if;
+
+ NN := Prime_Numbers.To_Prime (HT.Length);
+
+ -- ASSERT: NN >= HT.Length
+
+ if NN < HT.Buckets'Length then
+ Rehash (HT, Size => NN);
+ end if;
+
+ return;
+ end if;
+
+ -- ASSERT: N > HT.Length
+
+ if N = HT.Buckets'Length then
+ return;
+ end if;
+
+ NN := Prime_Numbers.To_Prime (N);
+
+ -- ASSERT: NN >= N
+ -- ASSERT: NN > HT.Length
+
+ if NN /= HT.Buckets'Length then
+ Rehash (HT, Size => NN);
+ end if;
+ end Ensure_Capacity;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (HT : in out Hash_Table_Type) is
+ begin
+ Clear (HT);
+ Free (HT.Buckets);
+ end Finalize;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (HT : Hash_Table_Type) return Node_Access is
+ Indx : Hash_Type;
+
+ begin
+ if HT.Length = 0 then
+ return Null_Node;
+ end if;
+
+ Indx := HT.Buckets'First;
+ loop
+ if HT.Buckets (Indx) /= Null_Node then
+ return HT.Buckets (Indx);
+ end if;
+
+ Indx := Indx + 1;
+ end loop;
+ end First;
+
+ ---------------------
+ -- Free_Hash_Table --
+ ---------------------
+
+ procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
+ Node : Node_Access;
+
+ begin
+ if Buckets = null then
+ return;
+ end if;
+
+ for J in Buckets'Range loop
+ while Buckets (J) /= Null_Node loop
+ Node := Buckets (J);
+ Buckets (J) := Next (Node);
+ Free (Node);
+ end loop;
+ end loop;
+
+ Free (Buckets);
+ end Free_Hash_Table;
+
+ -------------------
+ -- Generic_Equal --
+ -------------------
+
+ function Generic_Equal
+ (L, R : Hash_Table_Type) return Boolean is
+
+ L_Index : Hash_Type;
+ L_Node : Node_Access;
+
+ N : Count_Type;
+
+ begin
+ if L'Address = R'Address then
+ return True;
+ end if;
+
+ if L.Length /= R.Length then
+ return False;
+ end if;
+
+ if L.Length = 0 then
+ return True;
+ end if;
+
+ L_Index := 0;
+
+ loop
+ L_Node := L.Buckets (L_Index);
+ exit when L_Node /= Null_Node;
+ L_Index := L_Index + 1;
+ end loop;
+
+ N := L.Length;
+
+ loop
+ if not Find (HT => R, Key => L_Node) then
+ return False;
+ end if;
+
+ N := N - 1;
+
+ L_Node := Next (L_Node);
+
+ if L_Node = Null_Node then
+ if N = 0 then
+ return True;
+ end if;
+
+ loop
+ L_Index := L_Index + 1;
+ L_Node := L.Buckets (L_Index);
+ exit when L_Node /= Null_Node;
+ end loop;
+ end if;
+ end loop;
+ end Generic_Equal;
+
+ -----------------------
+ -- Generic_Iteration --
+ -----------------------
+
+ procedure Generic_Iteration (HT : Hash_Table_Type) is
+ Node : Node_Access;
+
+ begin
+ if HT.Buckets = null
+ or else HT.Length = 0
+ then
+ return;
+ end if;
+
+ for Indx in HT.Buckets'Range loop
+ Node := HT.Buckets (Indx);
+ while Node /= Null_Node loop
+ Process (Node);
+ Node := Next (Node);
+ end loop;
+ end loop;
+ end Generic_Iteration;
+
+ ------------------
+ -- Generic_Read --
+ ------------------
+
+ procedure Generic_Read
+ (Stream : access Root_Stream_Type'Class;
+ HT : out Hash_Table_Type)
+ is
+ X, Y : Node_Access;
+
+ Last, I : Hash_Type;
+ N, M : Count_Type'Base;
+
+ begin
+ -- As with the sorted set, it's not clear whether read is allowed to
+ -- have side effect if it fails. For now, we assume side effects are
+ -- allowed since it simplifies the algorithm ???
+ --
+ Clear (HT);
+
+ declare
+ B : Buckets_Access := HT.Buckets;
+ begin
+ HT.Buckets := null;
+ HT.Length := 0;
+ Free (B); -- can this fail???
+ end;
+
+ Hash_Type'Read (Stream, Last);
+
+ if Last /= 0 then
+ HT.Buckets := new Buckets_Type (0 .. Last);
+ end if;
+
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+ while N > 0 loop
+ Hash_Type'Read (Stream, I);
+ pragma Assert (I in HT.Buckets'Range);
+ pragma Assert (HT.Buckets (I) = Null_Node);
+
+ Count_Type'Base'Read (Stream, M);
+ pragma Assert (M >= 1);
+ pragma Assert (M <= N);
+
+ HT.Buckets (I) := New_Node (Stream);
+ pragma Assert (HT.Buckets (I) /= Null_Node);
+ pragma Assert (Next (HT.Buckets (I)) = Null_Node);
+
+ Y := HT.Buckets (I);
+
+ HT.Length := HT.Length + 1;
+
+ for J in Count_Type range 2 .. M loop
+ X := New_Node (Stream);
+ pragma Assert (X /= Null_Node);
+ pragma Assert (Next (X) = Null_Node);
+
+ Set_Next (Node => Y, Next => X);
+ Y := X;
+
+ HT.Length := HT.Length + 1;
+ end loop;
+
+ N := N - M;
+ end loop;
+ end Generic_Read;
+
+ -------------------
+ -- Generic_Write --
+ -------------------
+
+ procedure Generic_Write
+ (Stream : access Root_Stream_Type'Class;
+ HT : Hash_Table_Type)
+ is
+ M : Count_Type'Base;
+ X : Node_Access;
+
+ begin
+ if HT.Buckets = null then
+ Hash_Type'Write (Stream, 0);
+ else
+ Hash_Type'Write (Stream, HT.Buckets'Last);
+ end if;
+
+ Count_Type'Base'Write (Stream, HT.Length);
+
+ if HT.Length = 0 then
+ return;
+ end if;
+
+ for Indx in HT.Buckets'Range loop
+ X := HT.Buckets (Indx);
+
+ if X /= Null_Node then
+ M := 1;
+ loop
+ X := Next (X);
+ exit when X = Null_Node;
+ M := M + 1;
+ end loop;
+
+ Hash_Type'Write (Stream, Indx);
+ Count_Type'Base'Write (Stream, M);
+
+ X := HT.Buckets (Indx);
+ for J in Count_Type range 1 .. M loop
+ Write (Stream, X);
+ X := Next (X);
+ end loop;
+
+ pragma Assert (X = Null_Node);
+ end if;
+ end loop;
+ end Generic_Write;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Buckets : Buckets_Type;
+ Node : Node_Access) return Hash_Type is
+ begin
+ return Hash_Node (Node) mod Buckets'Length;
+ end Index;
+
+ function Index
+ (Hash_Table : Hash_Table_Type;
+ Node : Node_Access) return Hash_Type is
+ begin
+ return Index (Hash_Table.Buckets.all, Node);
+ end Index;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target, Source : in out Hash_Table_Type) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Length > 0 then
+ raise Constraint_Error;
+ end if;
+
+ Free (Target.Buckets);
+
+ Target.Buckets := Source.Buckets;
+ Source.Buckets := null;
+
+ Target.Length := Source.Length;
+ Source.Length := 0;
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next
+ (HT : Hash_Table_Type;
+ Node : Node_Access) return Node_Access
+ is
+ Result : Node_Access := Next (Node);
+
+ begin
+ if Result /= Null_Node then
+ return Result;
+ end if;
+
+ for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
+ Result := HT.Buckets (Indx);
+
+ if Result /= Null_Node then
+ return Result;
+ end if;
+ end loop;
+
+ return Null_Node;
+ end Next;
+
+ ------------
+ -- Rehash --
+ ------------
+
+ procedure Rehash
+ (HT : in out Hash_Table_Type;
+ Size : Hash_Type)
+ is
+ subtype Buckets_Range is Hash_Type range 0 .. Size - 1;
+
+ Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range);
+ Src_Buckets : Buckets_Access := HT.Buckets;
+
+ L : Count_Type renames HT.Length;
+ LL : constant Count_Type := L;
+
+ begin
+ if Src_Buckets = null then
+ pragma Assert (L = 0);
+ HT.Buckets := Dst_Buckets;
+ return;
+ end if;
+
+ if L = 0 then
+ HT.Buckets := Dst_Buckets;
+ Free (Src_Buckets);
+ return;
+ end if;
+
+ -- We might want to change this to iter from 1 .. L instead ???
+
+ for Src_Index in Src_Buckets'Range loop
+
+ declare
+ Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
+ begin
+ while Src_Bucket /= Null_Node loop
+ declare
+ Src_Node : constant Node_Access := Src_Bucket;
+ Dst_Index : constant Hash_Type :=
+ Index (Dst_Buckets.all, Src_Node);
+ Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
+ begin
+ Src_Bucket := Next (Src_Node);
+ Set_Next (Src_Node, Dst_Bucket);
+ Dst_Bucket := Src_Node;
+ end;
+
+ pragma Assert (L > 0);
+ L := L - 1;
+
+ end loop;
+
+ exception
+ when others =>
+
+ -- Not clear that we can deallocate the nodes,
+ -- because they may be designated by outstanding
+ -- iterators. Which means they're now lost... ???
+
+ -- for J in NB'Range loop
+ -- declare
+ -- Dst : Node_Access renames NB (J);
+ -- X : Node_Access;
+ -- begin
+ -- while Dst /= Null_Node loop
+ -- X := Dst;
+ -- Dst := Succ (Dst);
+ -- Free (X);
+ -- end loop;
+ -- end;
+ -- end loop;
+
+
+ Free (Dst_Buckets);
+ raise;
+ end;
+
+ -- exit when L = 0;
+ -- need to bother???
+
+ end loop;
+
+ pragma Assert (L = 0);
+
+ HT.Buckets := Dst_Buckets;
+ HT.Length := LL;
+
+ Free (Src_Buckets);
+ end Rehash;
+
+end Ada.Containers.Hash_Tables.Generic_Operations;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Streams;
+
+generic
+
+ with package HT_Types is
+ new Generic_Hash_Table_Types (<>);
+
+ type Hash_Table_Type is new HT_Types.Hash_Table_Type with private;
+
+ use HT_Types;
+
+ Null_Node : in Node_Access;
+
+ with function Hash_Node (Node : Node_Access) return Hash_Type;
+
+ with function Next (Node : Node_Access) return Node_Access;
+
+ with procedure Set_Next
+ (Node : Node_Access;
+ Next : Node_Access);
+
+ with function Copy_Node (Source : Node_Access) return Node_Access;
+
+ with procedure Free (X : in out Node_Access);
+
+package Ada.Containers.Hash_Tables.Generic_Operations is
+ pragma Preelaborate;
+
+ procedure Free_Hash_Table (Buckets : in out Buckets_Access);
+
+ function Index
+ (Buckets : Buckets_Type;
+ Node : Node_Access) return Hash_Type;
+ pragma Inline (Index);
+
+ function Index
+ (Hash_Table : Hash_Table_Type;
+ Node : Node_Access) return Hash_Type;
+ pragma Inline (Index);
+
+ procedure Adjust (HT : in out Hash_Table_Type);
+
+ procedure Finalize (HT : in out Hash_Table_Type);
+
+ generic
+ with function Find
+ (HT : Hash_Table_Type;
+ Key : Node_Access) return Boolean;
+ function Generic_Equal
+ (L, R : Hash_Table_Type) return Boolean;
+
+ procedure Clear (HT : in out Hash_Table_Type);
+
+ procedure Move (Target, Source : in out Hash_Table_Type);
+
+ function Capacity (HT : Hash_Table_Type) return Count_Type;
+
+ procedure Ensure_Capacity
+ (HT : in out Hash_Table_Type;
+ N : Count_Type);
+
+ procedure Delete_Node_Sans_Free
+ (HT : in out Hash_Table_Type;
+ X : Node_Access);
+
+ function First (HT : Hash_Table_Type) return Node_Access;
+
+ function Next
+ (HT : Hash_Table_Type;
+ Node : Node_Access) return Node_Access;
+
+ generic
+ with procedure Process (Node : Node_Access);
+ procedure Generic_Iteration (HT : Hash_Table_Type);
+
+ generic
+ use Ada.Streams;
+ with procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ procedure Generic_Write
+ (Stream : access Root_Stream_Type'Class;
+ HT : Hash_Table_Type);
+
+ generic
+ use Ada.Streams;
+ with function New_Node (Stream : access Root_Stream_Type'Class)
+ return Node_Access;
+ procedure Generic_Read
+ (Stream : access Root_Stream_Type'Class;
+ HT : out Hash_Table_Type);
+
+end Ada.Containers.Hash_Tables.Generic_Operations;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . C H A R A C T E R S . W I D E _ W I D E _ L A T I N _ 1 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides definitions analogous to those in the RM defined
+-- package Ada.Characters.Latin_1 except that the type of the constants
+-- is Wide_Wide_Character instead of Character. The provision of this package
+-- is in accordance with the implementation permission in RM (A.3.3(27)).
+
+package Ada.Characters.Wide_Wide_Latin_1 is
+pragma Pure (Wide_Wide_Latin_1);
+
+ ------------------------
+ -- Control Characters --
+ ------------------------
+
+ NUL : constant Wide_Wide_Character := Wide_Wide_Character'Val (0);
+ SOH : constant Wide_Wide_Character := Wide_Wide_Character'Val (1);
+ STX : constant Wide_Wide_Character := Wide_Wide_Character'Val (2);
+ ETX : constant Wide_Wide_Character := Wide_Wide_Character'Val (3);
+ EOT : constant Wide_Wide_Character := Wide_Wide_Character'Val (4);
+ ENQ : constant Wide_Wide_Character := Wide_Wide_Character'Val (5);
+ ACK : constant Wide_Wide_Character := Wide_Wide_Character'Val (6);
+ BEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (7);
+ BS : constant Wide_Wide_Character := Wide_Wide_Character'Val (8);
+ HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (9);
+ LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (10);
+ VT : constant Wide_Wide_Character := Wide_Wide_Character'Val (11);
+ FF : constant Wide_Wide_Character := Wide_Wide_Character'Val (12);
+ CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (13);
+ SO : constant Wide_Wide_Character := Wide_Wide_Character'Val (14);
+ SI : constant Wide_Wide_Character := Wide_Wide_Character'Val (15);
+
+ DLE : constant Wide_Wide_Character := Wide_Wide_Character'Val (16);
+ DC1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (17);
+ DC2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (18);
+ DC3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (19);
+ DC4 : constant Wide_Wide_Character := Wide_Wide_Character'Val (20);
+ NAK : constant Wide_Wide_Character := Wide_Wide_Character'Val (21);
+ SYN : constant Wide_Wide_Character := Wide_Wide_Character'Val (22);
+ ETB : constant Wide_Wide_Character := Wide_Wide_Character'Val (23);
+ CAN : constant Wide_Wide_Character := Wide_Wide_Character'Val (24);
+ EM : constant Wide_Wide_Character := Wide_Wide_Character'Val (25);
+ SUB : constant Wide_Wide_Character := Wide_Wide_Character'Val (26);
+ ESC : constant Wide_Wide_Character := Wide_Wide_Character'Val (27);
+ FS : constant Wide_Wide_Character := Wide_Wide_Character'Val (28);
+ GS : constant Wide_Wide_Character := Wide_Wide_Character'Val (29);
+ RS : constant Wide_Wide_Character := Wide_Wide_Character'Val (30);
+ US : constant Wide_Wide_Character := Wide_Wide_Character'Val (31);
+
+ -------------------------------------
+ -- ISO 646 Graphic Wide_Wide_Characters --
+ -------------------------------------
+
+ Space : constant Wide_Wide_Character := ' '; -- WC'Val(32)
+ Exclamation : constant Wide_Wide_Character := '!'; -- WC'Val(33)
+ Quotation : constant Wide_Wide_Character := '"'; -- WC'Val(34)
+ Number_Sign : constant Wide_Wide_Character := '#'; -- WC'Val(35)
+ Dollar_Sign : constant Wide_Wide_Character := '$'; -- WC'Val(36)
+ Percent_Sign : constant Wide_Wide_Character := '%'; -- WC'Val(37)
+ Ampersand : constant Wide_Wide_Character := '&'; -- WC'Val(38)
+ Apostrophe : constant Wide_Wide_Character := '''; -- WC'Val(39)
+ Left_Parenthesis : constant Wide_Wide_Character := '('; -- WC'Val(40)
+ Right_Parenthesis : constant Wide_Wide_Character := ')'; -- WC'Val(41)
+ Asterisk : constant Wide_Wide_Character := '*'; -- WC'Val(42)
+ Plus_Sign : constant Wide_Wide_Character := '+'; -- WC'Val(43)
+ Comma : constant Wide_Wide_Character := ','; -- WC'Val(44)
+ Hyphen : constant Wide_Wide_Character := '-'; -- WC'Val(45)
+ Minus_Sign : Wide_Wide_Character renames Hyphen;
+ Full_Stop : constant Wide_Wide_Character := '.'; -- WC'Val(46)
+ Solidus : constant Wide_Wide_Character := '/'; -- WC'Val(47)
+
+ -- Decimal digits '0' though '9' are at positions 48 through 57
+
+ Colon : constant Wide_Wide_Character := ':'; -- WC'Val(58)
+ Semicolon : constant Wide_Wide_Character := ';'; -- WC'Val(59)
+ Less_Than_Sign : constant Wide_Wide_Character := '<'; -- WC'Val(60)
+ Equals_Sign : constant Wide_Wide_Character := '='; -- WC'Val(61)
+ Greater_Than_Sign : constant Wide_Wide_Character := '>'; -- WC'Val(62)
+ Question : constant Wide_Wide_Character := '?'; -- WC'Val(63)
+
+ Commercial_At : constant Wide_Wide_Character := '@'; -- WC'Val(64)
+
+ -- Letters 'A' through 'Z' are at positions 65 through 90
+
+ Left_Square_Bracket : constant Wide_Wide_Character := '['; -- WC'Val (91)
+ Reverse_Solidus : constant Wide_Wide_Character := '\'; -- WC'Val (92)
+ Right_Square_Bracket : constant Wide_Wide_Character := ']'; -- WC'Val (93)
+ Circumflex : constant Wide_Wide_Character := '^'; -- WC'Val (94)
+ Low_Line : constant Wide_Wide_Character := '_'; -- WC'Val (95)
+
+ Grave : constant Wide_Wide_Character := '`'; -- WC'Val (96)
+ LC_A : constant Wide_Wide_Character := 'a'; -- WC'Val (97)
+ LC_B : constant Wide_Wide_Character := 'b'; -- WC'Val (98)
+ LC_C : constant Wide_Wide_Character := 'c'; -- WC'Val (99)
+ LC_D : constant Wide_Wide_Character := 'd'; -- WC'Val (100)
+ LC_E : constant Wide_Wide_Character := 'e'; -- WC'Val (101)
+ LC_F : constant Wide_Wide_Character := 'f'; -- WC'Val (102)
+ LC_G : constant Wide_Wide_Character := 'g'; -- WC'Val (103)
+ LC_H : constant Wide_Wide_Character := 'h'; -- WC'Val (104)
+ LC_I : constant Wide_Wide_Character := 'i'; -- WC'Val (105)
+ LC_J : constant Wide_Wide_Character := 'j'; -- WC'Val (106)
+ LC_K : constant Wide_Wide_Character := 'k'; -- WC'Val (107)
+ LC_L : constant Wide_Wide_Character := 'l'; -- WC'Val (108)
+ LC_M : constant Wide_Wide_Character := 'm'; -- WC'Val (109)
+ LC_N : constant Wide_Wide_Character := 'n'; -- WC'Val (110)
+ LC_O : constant Wide_Wide_Character := 'o'; -- WC'Val (111)
+ LC_P : constant Wide_Wide_Character := 'p'; -- WC'Val (112)
+ LC_Q : constant Wide_Wide_Character := 'q'; -- WC'Val (113)
+ LC_R : constant Wide_Wide_Character := 'r'; -- WC'Val (114)
+ LC_S : constant Wide_Wide_Character := 's'; -- WC'Val (115)
+ LC_T : constant Wide_Wide_Character := 't'; -- WC'Val (116)
+ LC_U : constant Wide_Wide_Character := 'u'; -- WC'Val (117)
+ LC_V : constant Wide_Wide_Character := 'v'; -- WC'Val (118)
+ LC_W : constant Wide_Wide_Character := 'w'; -- WC'Val (119)
+ LC_X : constant Wide_Wide_Character := 'x'; -- WC'Val (120)
+ LC_Y : constant Wide_Wide_Character := 'y'; -- WC'Val (121)
+ LC_Z : constant Wide_Wide_Character := 'z'; -- WC'Val (122)
+ Left_Curly_Bracket : constant Wide_Wide_Character := '{'; -- WC'Val (123)
+ Vertical_Line : constant Wide_Wide_Character := '|'; -- WC'Val (124)
+ Right_Curly_Bracket : constant Wide_Wide_Character := '}'; -- WC'Val (125)
+ Tilde : constant Wide_Wide_Character := '~'; -- WC'Val (126)
+ DEL : constant Wide_Wide_Character :=
+ Wide_Wide_Character'Val (127);
+
+ --------------------------------------
+ -- ISO 6429 Control Wide_Wide_Characters --
+ --------------------------------------
+
+ IS4 : Wide_Wide_Character renames FS;
+ IS3 : Wide_Wide_Character renames GS;
+ IS2 : Wide_Wide_Character renames RS;
+ IS1 : Wide_Wide_Character renames US;
+
+ Reserved_128
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (128);
+ Reserved_129
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (129);
+ BPH : constant Wide_Wide_Character := Wide_Wide_Character'Val (130);
+ NBH : constant Wide_Wide_Character := Wide_Wide_Character'Val (131);
+ Reserved_132
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (132);
+ NEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (133);
+ SSA : constant Wide_Wide_Character := Wide_Wide_Character'Val (134);
+ ESA : constant Wide_Wide_Character := Wide_Wide_Character'Val (135);
+ HTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (136);
+ HTJ : constant Wide_Wide_Character := Wide_Wide_Character'Val (137);
+ VTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (138);
+ PLD : constant Wide_Wide_Character := Wide_Wide_Character'Val (139);
+ PLU : constant Wide_Wide_Character := Wide_Wide_Character'Val (140);
+ RI : constant Wide_Wide_Character := Wide_Wide_Character'Val (141);
+ SS2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (142);
+ SS3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (143);
+
+ DCS : constant Wide_Wide_Character := Wide_Wide_Character'Val (144);
+ PU1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (145);
+ PU2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (146);
+ STS : constant Wide_Wide_Character := Wide_Wide_Character'Val (147);
+ CCH : constant Wide_Wide_Character := Wide_Wide_Character'Val (148);
+ MW : constant Wide_Wide_Character := Wide_Wide_Character'Val (149);
+ SPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (150);
+ EPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (151);
+
+ SOS : constant Wide_Wide_Character := Wide_Wide_Character'Val (152);
+ Reserved_153
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (153);
+ SCI : constant Wide_Wide_Character := Wide_Wide_Character'Val (154);
+ CSI : constant Wide_Wide_Character := Wide_Wide_Character'Val (155);
+ ST : constant Wide_Wide_Character := Wide_Wide_Character'Val (156);
+ OSC : constant Wide_Wide_Character := Wide_Wide_Character'Val (157);
+ PM : constant Wide_Wide_Character := Wide_Wide_Character'Val (158);
+ APC : constant Wide_Wide_Character := Wide_Wide_Character'Val (159);
+
+ -----------------------------------
+ -- Other Graphic Wide_Wide_Characters --
+ -----------------------------------
+
+ -- Wide_Wide_Character positions 160 (16#A0#) .. 175 (16#AF#)
+
+ No_Break_Space
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (160);
+ NBSP : Wide_Wide_Character renames No_Break_Space;
+ Inverted_Exclamation
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (161);
+ Cent_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (162);
+ Pound_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (163);
+ Currency_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (164);
+ Yen_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (165);
+ Broken_Bar : constant Wide_Wide_Character := Wide_Wide_Character'Val (166);
+ Section_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (167);
+ Diaeresis : constant Wide_Wide_Character := Wide_Wide_Character'Val (168);
+ Copyright_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (169);
+ Feminine_Ordinal_Indicator
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (170);
+ Left_Angle_Quotation
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (171);
+ Not_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (172);
+ Soft_Hyphen : constant Wide_Wide_Character := Wide_Wide_Character'Val (173);
+ Registered_Trade_Mark_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (174);
+ Macron : constant Wide_Wide_Character := Wide_Wide_Character'Val (175);
+
+ -- Wide_Wide_Character positions 176 (16#B0#) .. 191 (16#BF#)
+
+ Degree_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (176);
+ Ring_Above : Wide_Wide_Character renames Degree_Sign;
+ Plus_Minus_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (177);
+ Superscript_Two
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (178);
+ Superscript_Three
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (179);
+ Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (180);
+ Micro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (181);
+ Pilcrow_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (182);
+ Paragraph_Sign
+ : Wide_Wide_Character renames Pilcrow_Sign;
+ Middle_Dot : constant Wide_Wide_Character := Wide_Wide_Character'Val (183);
+ Cedilla : constant Wide_Wide_Character := Wide_Wide_Character'Val (184);
+ Superscript_One
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (185);
+ Masculine_Ordinal_Indicator
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (186);
+ Right_Angle_Quotation
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (187);
+ Fraction_One_Quarter
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (188);
+ Fraction_One_Half
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (189);
+ Fraction_Three_Quarters
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (190);
+ Inverted_Question
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (191);
+
+ -- Wide_Wide_Character positions 192 (16#C0#) .. 207 (16#CF#)
+
+ UC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (192);
+ UC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (193);
+ UC_A_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (194);
+ UC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (195);
+ UC_A_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (196);
+ UC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (197);
+ UC_AE_Diphthong
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (198);
+ UC_C_Cedilla
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (199);
+ UC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (200);
+ UC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (201);
+ UC_E_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (202);
+ UC_E_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (203);
+ UC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (204);
+ UC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (205);
+ UC_I_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (206);
+ UC_I_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (207);
+
+ -- Wide_Wide_Character positions 208 (16#D0#) .. 223 (16#DF#)
+
+ UC_Icelandic_Eth
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (208);
+ UC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (209);
+ UC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (210);
+ UC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (211);
+ UC_O_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (212);
+ UC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (213);
+ UC_O_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (214);
+ Multiplication_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (215);
+ UC_O_Oblique_Stroke
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (216);
+ UC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (217);
+ UC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (218);
+ UC_U_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (219);
+ UC_U_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (220);
+ UC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (221);
+ UC_Icelandic_Thorn
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (222);
+ LC_German_Sharp_S
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (223);
+
+ -- Wide_Wide_Character positions 224 (16#E0#) .. 239 (16#EF#)
+
+ LC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (224);
+ LC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (225);
+ LC_A_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (226);
+ LC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (227);
+ LC_A_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (228);
+ LC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (229);
+ LC_AE_Diphthong
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (230);
+ LC_C_Cedilla
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (231);
+ LC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (232);
+ LC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (233);
+ LC_E_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (234);
+ LC_E_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (235);
+ LC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (236);
+ LC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (237);
+ LC_I_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (238);
+ LC_I_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (239);
+
+ -- Wide_Wide_Character positions 240 (16#F0#) .. 255 (16#FF)
+
+ LC_Icelandic_Eth
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (240);
+ LC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (241);
+ LC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (242);
+ LC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (243);
+ LC_O_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (244);
+ LC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (245);
+ LC_O_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (246);
+ Division_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (247);
+ LC_O_Oblique_Stroke
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (248);
+ LC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (249);
+ LC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (250);
+ LC_U_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (251);
+ LC_U_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (252);
+ LC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (253);
+ LC_Icelandic_Thorn
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (254);
+ LC_Y_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (255);
+
+end Ada.Characters.Wide_Wide_Latin_1;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . C H A R A C T E R S . W I D E _ W I D E _ L A T I N _ 9 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides definitions analogous to those in the GNAT package
+-- Ada.Characters.Latin_9 except that the type of the various constants is
+-- Wide_Wide_Character instead of Character. The provision of this package
+-- is in accordance with the implementation permission in RM (A.3.3(27)).
+
+package Ada.Characters.Wide_Wide_Latin_9 is
+pragma Pure (Wide_Wide_Latin_9);
+
+ ------------------------
+ -- Control Characters --
+ ------------------------
+
+ NUL : constant Wide_Wide_Character := Wide_Wide_Character'Val (0);
+ SOH : constant Wide_Wide_Character := Wide_Wide_Character'Val (1);
+ STX : constant Wide_Wide_Character := Wide_Wide_Character'Val (2);
+ ETX : constant Wide_Wide_Character := Wide_Wide_Character'Val (3);
+ EOT : constant Wide_Wide_Character := Wide_Wide_Character'Val (4);
+ ENQ : constant Wide_Wide_Character := Wide_Wide_Character'Val (5);
+ ACK : constant Wide_Wide_Character := Wide_Wide_Character'Val (6);
+ BEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (7);
+ BS : constant Wide_Wide_Character := Wide_Wide_Character'Val (8);
+ HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (9);
+ LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (10);
+ VT : constant Wide_Wide_Character := Wide_Wide_Character'Val (11);
+ FF : constant Wide_Wide_Character := Wide_Wide_Character'Val (12);
+ CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (13);
+ SO : constant Wide_Wide_Character := Wide_Wide_Character'Val (14);
+ SI : constant Wide_Wide_Character := Wide_Wide_Character'Val (15);
+
+ DLE : constant Wide_Wide_Character := Wide_Wide_Character'Val (16);
+ DC1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (17);
+ DC2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (18);
+ DC3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (19);
+ DC4 : constant Wide_Wide_Character := Wide_Wide_Character'Val (20);
+ NAK : constant Wide_Wide_Character := Wide_Wide_Character'Val (21);
+ SYN : constant Wide_Wide_Character := Wide_Wide_Character'Val (22);
+ ETB : constant Wide_Wide_Character := Wide_Wide_Character'Val (23);
+ CAN : constant Wide_Wide_Character := Wide_Wide_Character'Val (24);
+ EM : constant Wide_Wide_Character := Wide_Wide_Character'Val (25);
+ SUB : constant Wide_Wide_Character := Wide_Wide_Character'Val (26);
+ ESC : constant Wide_Wide_Character := Wide_Wide_Character'Val (27);
+ FS : constant Wide_Wide_Character := Wide_Wide_Character'Val (28);
+ GS : constant Wide_Wide_Character := Wide_Wide_Character'Val (29);
+ RS : constant Wide_Wide_Character := Wide_Wide_Character'Val (30);
+ US : constant Wide_Wide_Character := Wide_Wide_Character'Val (31);
+
+ -------------------------------------
+ -- ISO 646 Graphic Wide_Wide_Characters --
+ -------------------------------------
+
+ Space : constant Wide_Wide_Character := ' '; -- WC'Val(32)
+ Exclamation : constant Wide_Wide_Character := '!'; -- WC'Val(33)
+ Quotation : constant Wide_Wide_Character := '"'; -- WC'Val(34)
+ Number_Sign : constant Wide_Wide_Character := '#'; -- WC'Val(35)
+ Dollar_Sign : constant Wide_Wide_Character := '$'; -- WC'Val(36)
+ Percent_Sign : constant Wide_Wide_Character := '%'; -- WC'Val(37)
+ Ampersand : constant Wide_Wide_Character := '&'; -- WC'Val(38)
+ Apostrophe : constant Wide_Wide_Character := '''; -- WC'Val(39)
+ Left_Parenthesis : constant Wide_Wide_Character := '('; -- WC'Val(40)
+ Right_Parenthesis : constant Wide_Wide_Character := ')'; -- WC'Val(41)
+ Asterisk : constant Wide_Wide_Character := '*'; -- WC'Val(42)
+ Plus_Sign : constant Wide_Wide_Character := '+'; -- WC'Val(43)
+ Comma : constant Wide_Wide_Character := ','; -- WC'Val(44)
+ Hyphen : constant Wide_Wide_Character := '-'; -- WC'Val(45)
+ Minus_Sign : Wide_Wide_Character renames Hyphen;
+ Full_Stop : constant Wide_Wide_Character := '.'; -- WC'Val(46)
+ Solidus : constant Wide_Wide_Character := '/'; -- WC'Val(47)
+
+ -- Decimal digits '0' though '9' are at positions 48 through 57
+
+ Colon : constant Wide_Wide_Character := ':'; -- WC'Val(58)
+ Semicolon : constant Wide_Wide_Character := ';'; -- WC'Val(59)
+ Less_Than_Sign : constant Wide_Wide_Character := '<'; -- WC'Val(60)
+ Equals_Sign : constant Wide_Wide_Character := '='; -- WC'Val(61)
+ Greater_Than_Sign : constant Wide_Wide_Character := '>'; -- WC'Val(62)
+ Question : constant Wide_Wide_Character := '?'; -- WC'Val(63)
+
+ Commercial_At : constant Wide_Wide_Character := '@'; -- WC'Val(64)
+
+ -- Letters 'A' through 'Z' are at positions 65 through 90
+
+ Left_Square_Bracket : constant Wide_Wide_Character := '['; -- WC'Val (91)
+ Reverse_Solidus : constant Wide_Wide_Character := '\'; -- WC'Val (92)
+ Right_Square_Bracket : constant Wide_Wide_Character := ']'; -- WC'Val (93)
+ Circumflex : constant Wide_Wide_Character := '^'; -- WC'Val (94)
+ Low_Line : constant Wide_Wide_Character := '_'; -- WC'Val (95)
+
+ Grave : constant Wide_Wide_Character := '`'; -- WC'Val (96)
+ LC_A : constant Wide_Wide_Character := 'a'; -- WC'Val (97)
+ LC_B : constant Wide_Wide_Character := 'b'; -- WC'Val (98)
+ LC_C : constant Wide_Wide_Character := 'c'; -- WC'Val (99)
+ LC_D : constant Wide_Wide_Character := 'd'; -- WC'Val (100)
+ LC_E : constant Wide_Wide_Character := 'e'; -- WC'Val (101)
+ LC_F : constant Wide_Wide_Character := 'f'; -- WC'Val (102)
+ LC_G : constant Wide_Wide_Character := 'g'; -- WC'Val (103)
+ LC_H : constant Wide_Wide_Character := 'h'; -- WC'Val (104)
+ LC_I : constant Wide_Wide_Character := 'i'; -- WC'Val (105)
+ LC_J : constant Wide_Wide_Character := 'j'; -- WC'Val (106)
+ LC_K : constant Wide_Wide_Character := 'k'; -- WC'Val (107)
+ LC_L : constant Wide_Wide_Character := 'l'; -- WC'Val (108)
+ LC_M : constant Wide_Wide_Character := 'm'; -- WC'Val (109)
+ LC_N : constant Wide_Wide_Character := 'n'; -- WC'Val (110)
+ LC_O : constant Wide_Wide_Character := 'o'; -- WC'Val (111)
+ LC_P : constant Wide_Wide_Character := 'p'; -- WC'Val (112)
+ LC_Q : constant Wide_Wide_Character := 'q'; -- WC'Val (113)
+ LC_R : constant Wide_Wide_Character := 'r'; -- WC'Val (114)
+ LC_S : constant Wide_Wide_Character := 's'; -- WC'Val (115)
+ LC_T : constant Wide_Wide_Character := 't'; -- WC'Val (116)
+ LC_U : constant Wide_Wide_Character := 'u'; -- WC'Val (117)
+ LC_V : constant Wide_Wide_Character := 'v'; -- WC'Val (118)
+ LC_W : constant Wide_Wide_Character := 'w'; -- WC'Val (119)
+ LC_X : constant Wide_Wide_Character := 'x'; -- WC'Val (120)
+ LC_Y : constant Wide_Wide_Character := 'y'; -- WC'Val (121)
+ LC_Z : constant Wide_Wide_Character := 'z'; -- WC'Val (122)
+ Left_Curly_Bracket : constant Wide_Wide_Character := '{'; -- WC'Val (123)
+ Vertical_Line : constant Wide_Wide_Character := '|'; -- WC'Val (124)
+ Right_Curly_Bracket : constant Wide_Wide_Character := '}'; -- WC'Val (125)
+ Tilde : constant Wide_Wide_Character := '~'; -- WC'Val (126)
+ DEL : constant Wide_Wide_Character :=
+ Wide_Wide_Character'Val (127);
+
+ --------------------------------------
+ -- ISO 6429 Control Wide_Wide_Characters --
+ --------------------------------------
+
+ IS4 : Wide_Wide_Character renames FS;
+ IS3 : Wide_Wide_Character renames GS;
+ IS2 : Wide_Wide_Character renames RS;
+ IS1 : Wide_Wide_Character renames US;
+
+ Reserved_128
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (128);
+ Reserved_129
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (129);
+ BPH : constant Wide_Wide_Character := Wide_Wide_Character'Val (130);
+ NBH : constant Wide_Wide_Character := Wide_Wide_Character'Val (131);
+ Reserved_132
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (132);
+ NEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (133);
+ SSA : constant Wide_Wide_Character := Wide_Wide_Character'Val (134);
+ ESA : constant Wide_Wide_Character := Wide_Wide_Character'Val (135);
+ HTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (136);
+ HTJ : constant Wide_Wide_Character := Wide_Wide_Character'Val (137);
+ VTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (138);
+ PLD : constant Wide_Wide_Character := Wide_Wide_Character'Val (139);
+ PLU : constant Wide_Wide_Character := Wide_Wide_Character'Val (140);
+ RI : constant Wide_Wide_Character := Wide_Wide_Character'Val (141);
+ SS2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (142);
+ SS3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (143);
+
+ DCS : constant Wide_Wide_Character := Wide_Wide_Character'Val (144);
+ PU1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (145);
+ PU2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (146);
+ STS : constant Wide_Wide_Character := Wide_Wide_Character'Val (147);
+ CCH : constant Wide_Wide_Character := Wide_Wide_Character'Val (148);
+ MW : constant Wide_Wide_Character := Wide_Wide_Character'Val (149);
+ SPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (150);
+ EPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (151);
+
+ SOS : constant Wide_Wide_Character := Wide_Wide_Character'Val (152);
+ Reserved_153
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (153);
+ SCI : constant Wide_Wide_Character := Wide_Wide_Character'Val (154);
+ CSI : constant Wide_Wide_Character := Wide_Wide_Character'Val (155);
+ ST : constant Wide_Wide_Character := Wide_Wide_Character'Val (156);
+ OSC : constant Wide_Wide_Character := Wide_Wide_Character'Val (157);
+ PM : constant Wide_Wide_Character := Wide_Wide_Character'Val (158);
+ APC : constant Wide_Wide_Character := Wide_Wide_Character'Val (159);
+
+ -----------------------------------
+ -- Other Graphic Wide_Wide_Characters --
+ -----------------------------------
+
+ -- Wide_Wide_Character positions 160 (16#A0#) .. 175 (16#AF#)
+
+ No_Break_Space
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (160);
+ NBSP : Wide_Wide_Character renames No_Break_Space;
+ Inverted_Exclamation
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (161);
+ Cent_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (162);
+ Pound_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (163);
+ Euro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (164);
+ Yen_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (165);
+ UC_S_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (166);
+ Section_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (167);
+ LC_S_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (168);
+ Copyright_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (169);
+ Feminine_Ordinal_Indicator
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (170);
+ Left_Angle_Quotation
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (171);
+ Not_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (172);
+ Soft_Hyphen : constant Wide_Wide_Character := Wide_Wide_Character'Val (173);
+ Registered_Trade_Mark_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (174);
+ Macron : constant Wide_Wide_Character := Wide_Wide_Character'Val (175);
+
+ -- Wide_Wide_Character positions 176 (16#B0#) .. 191 (16#BF#)
+
+ Degree_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (176);
+ Ring_Above : Wide_Wide_Character renames Degree_Sign;
+ Plus_Minus_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (177);
+ Superscript_Two
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (178);
+ Superscript_Three
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (179);
+ UC_Z_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (180);
+ Micro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (181);
+ Pilcrow_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (182);
+ Paragraph_Sign
+ : Wide_Wide_Character renames Pilcrow_Sign;
+ Middle_Dot : constant Wide_Wide_Character := Wide_Wide_Character'Val (183);
+ LC_Z_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (184);
+ Superscript_One
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (185);
+ Masculine_Ordinal_Indicator
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (186);
+ Right_Angle_Quotation
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (187);
+ UC_Ligature_OE
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (188);
+ LC_Ligature_OE
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (189);
+ UC_Y_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (190);
+ Inverted_Question
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (191);
+
+ -- Wide_Wide_Character positions 192 (16#C0#) .. 207 (16#CF#)
+
+ UC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (192);
+ UC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (193);
+ UC_A_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (194);
+ UC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (195);
+ UC_A_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (196);
+ UC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (197);
+ UC_AE_Diphthong
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (198);
+ UC_C_Cedilla
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (199);
+ UC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (200);
+ UC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (201);
+ UC_E_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (202);
+ UC_E_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (203);
+ UC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (204);
+ UC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (205);
+ UC_I_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (206);
+ UC_I_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (207);
+
+ -- Wide_Wide_Character positions 208 (16#D0#) .. 223 (16#DF#)
+
+ UC_Icelandic_Eth
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (208);
+ UC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (209);
+ UC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (210);
+ UC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (211);
+ UC_O_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (212);
+ UC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (213);
+ UC_O_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (214);
+ Multiplication_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (215);
+ UC_O_Oblique_Stroke
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (216);
+ UC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (217);
+ UC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (218);
+ UC_U_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (219);
+ UC_U_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (220);
+ UC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (221);
+ UC_Icelandic_Thorn
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (222);
+ LC_German_Sharp_S
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (223);
+
+ -- Wide_Wide_Character positions 224 (16#E0#) .. 239 (16#EF#)
+
+ LC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (224);
+ LC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (225);
+ LC_A_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (226);
+ LC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (227);
+ LC_A_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (228);
+ LC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (229);
+ LC_AE_Diphthong
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (230);
+ LC_C_Cedilla
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (231);
+ LC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (232);
+ LC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (233);
+ LC_E_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (234);
+ LC_E_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (235);
+ LC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (236);
+ LC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (237);
+ LC_I_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (238);
+ LC_I_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (239);
+
+ -- Wide_Wide_Character positions 240 (16#F0#) .. 255 (16#FF)
+
+ LC_Icelandic_Eth
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (240);
+ LC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (241);
+ LC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (242);
+ LC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (243);
+ LC_O_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (244);
+ LC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (245);
+ LC_O_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (246);
+ Division_Sign
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (247);
+ LC_O_Oblique_Stroke
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (248);
+ LC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (249);
+ LC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (250);
+ LC_U_Circumflex
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (251);
+ LC_U_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (252);
+ LC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (253);
+ LC_Icelandic_Thorn
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (254);
+ LC_Y_Diaeresis
+ : constant Wide_Wide_Character := Wide_Wide_Character'Val (255);
+
+ ------------------------------------------------
+ -- Summary of Changes from Latin-1 => Latin-9 --
+ ------------------------------------------------
+
+ -- 164 Currency => Euro_Sign
+ -- 166 Broken_Bar => UC_S_Caron
+ -- 168 Diaeresis => LC_S_Caron
+ -- 180 Acute => UC_Z_Caron
+ -- 184 Cedilla => LC_Z_Caron
+ -- 188 Fraction_One_Quarter => UC_Ligature_OE
+ -- 189 Fraction_One_Half => LC_Ligature_OE
+ -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis
+
+end Ada.Characters.Wide_Wide_Latin_9;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with System; use type System.Address;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Delete_Node
+ (Container : in out List;
+ Node : in out Node_Access);
+
+ procedure Insert_Internal
+ (Container : in out List;
+ Before : Node_Access;
+ New_Node : Node_Access);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : List) return Boolean is
+ L : Node_Access;
+ R : Node_Access;
+
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ if Left.Length /= Right.Length then
+ return False;
+ end if;
+
+ L := Left.First;
+ R := Right.First;
+ for J in 1 .. Left.Length loop
+ if L.Element = null then
+ if R.Element /= null then
+ return False;
+ end if;
+
+ elsif R.Element = null then
+ return False;
+
+ elsif L.Element.all /= R.Element.all then
+ return False;
+ end if;
+
+ L := L.Next;
+ R := R.Next;
+ end loop;
+
+ return True;
+ end "=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out List) is
+ Src : Node_Access := Container.First;
+ Dst : Node_Access;
+
+ begin
+ if Src = null then
+ pragma Assert (Container.Last = null);
+ pragma Assert (Container.Length = 0);
+ return;
+ end if;
+
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+ pragma Assert (Container.Length > 0);
+
+ Container.First := null;
+ Container.Last := null;
+ Container.Length := 0;
+
+ Dst := new Node_Type'(null, null, null);
+
+ if Src.Element /= null then
+ begin
+ Dst.Element := new Element_Type'(Src.Element.all);
+ exception
+ when others =>
+ Free (Dst);
+ raise;
+ end;
+ end if;
+
+ Container.First := Dst;
+
+ Container.Last := Dst;
+ loop
+ Container.Length := Container.Length + 1;
+ Src := Src.Next;
+ exit when Src = null;
+
+ Dst := new Node_Type'(null, Prev => Container.Last, Next => null);
+
+ if Src.Element /= null then
+ begin
+ Dst.Element := new Element_Type'(Src.Element.all);
+ exception
+ when others =>
+ Free (Dst);
+ raise;
+ end;
+ end if;
+
+ Container.Last.Next := Dst;
+ Container.Last := Dst;
+ end loop;
+ end Adjust;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ begin
+ Insert (Container, No_Element, New_Item, Count);
+ end Append;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out List) is
+ begin
+ Delete_Last (Container, Count => Container.Length);
+ end Clear;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (Container : List;
+ Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out List;
+ Position : in out Cursor;
+ Count : Count_Type := 1)
+ is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ for Index in 1 .. Count loop
+ Delete_Node (Container, Position.Node);
+
+ if Position.Node = null then
+ Position.Container := null;
+ return;
+ end if;
+ end loop;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First
+ (Container : in out List;
+ Count : Count_Type := 1)
+ is
+ Node : Node_Access := Container.First;
+ begin
+ for J in 1 .. Count_Type'Min (Count, Container.Length) loop
+ Delete_Node (Container, Node);
+ end loop;
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last
+ (Container : in out List;
+ Count : Count_Type := 1)
+ is
+ Node : Node_Access;
+ begin
+ for J in 1 .. Count_Type'Min (Count, Container.Length) loop
+ Node := Container.Last;
+ Delete_Node (Container, Node);
+ end loop;
+ end Delete_Last;
+
+ -----------------
+ -- Delete_Node --
+ -----------------
+
+ procedure Delete_Node
+ (Container : in out List;
+ Node : in out Node_Access)
+ is
+ X : Node_Access := Node;
+
+ begin
+ Node := X.Next;
+ Container.Length := Container.Length - 1;
+
+ if X = Container.First then
+ Container.First := X.Next;
+
+ if X = Container.Last then
+ pragma Assert (Container.First = null);
+ pragma Assert (Container.Length = 0);
+ Container.Last := null;
+ else
+ pragma Assert (Container.Length > 0);
+ Container.First.Prev := null;
+ end if;
+
+ elsif X = Container.Last then
+ pragma Assert (Container.Length > 0);
+
+ Container.Last := X.Prev;
+ Container.Last.Next := null;
+
+ else
+ pragma Assert (Container.Length > 0);
+
+ X.Next.Prev := X.Prev;
+ X.Prev.Next := X.Next;
+
+ end if;
+
+ Free (X.Element);
+ Free (X);
+ end Delete_Node;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element.all;
+ end Element;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor
+ is
+ Node : Node_Access := Position.Node;
+
+ begin
+ if Node = null then
+ Node := Container.First;
+ elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ while Node /= null loop
+ if Node.Element /= null
+ and then Node.Element.all = Item
+ then
+ return Cursor'(Container'Unchecked_Access, Node);
+ end if;
+
+ Node := Node.Next;
+ end loop;
+
+ return No_Element;
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : List) return Cursor is
+ begin
+ if Container.First = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : List) return Element_Type is
+ begin
+ return Container.First.Element.all;
+ end First_Element;
+
+ -------------------
+ -- Generic_Merge --
+ -------------------
+
+ procedure Generic_Merge
+ (Target : in out List;
+ Source : in out List)
+ is
+ LI : Cursor;
+ RI : Cursor;
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ LI := First (Target);
+ RI := First (Source);
+ while RI.Node /= null loop
+ if LI.Node = null then
+ Splice (Target, No_Element, Source);
+ return;
+ end if;
+
+ if LI.Node.Element = null then
+ LI.Node := LI.Node.Next;
+
+ elsif RI.Node.Element = null
+ or else RI.Node.Element.all < LI.Node.Element.all
+ then
+ declare
+ RJ : constant Cursor := RI;
+ begin
+ RI.Node := RI.Node.Next;
+ Splice (Target, LI, Source, RJ);
+ end;
+
+ else
+ LI.Node := LI.Node.Next;
+ end if;
+ end loop;
+ end Generic_Merge;
+
+ ------------------
+ -- Generic_Sort --
+ ------------------
+
+ procedure Generic_Sort (Container : in out List) is
+ procedure Partition (Pivot : Node_Access; Back : Node_Access);
+
+ procedure Sort (Front, Back : Node_Access);
+
+ ---------------
+ -- Partition --
+ ---------------
+
+ procedure Partition (Pivot : Node_Access; Back : Node_Access) is
+ Node : Node_Access := Pivot.Next;
+
+ begin
+ while Node /= Back loop
+ if Pivot.Element = null then
+ Node := Node.Next;
+
+ elsif Node.Element = null
+ or else Node.Element.all < Pivot.Element.all
+ then
+ declare
+ Prev : constant Node_Access := Node.Prev;
+ Next : constant Node_Access := Node.Next;
+ begin
+ Prev.Next := Next;
+
+ if Next = null then
+ Container.Last := Prev;
+ else
+ Next.Prev := Prev;
+ end if;
+
+ Node.Next := Pivot;
+ Node.Prev := Pivot.Prev;
+
+ Pivot.Prev := Node;
+
+ if Node.Prev = null then
+ Container.First := Node;
+ else
+ Node.Prev.Next := Node;
+ end if;
+
+ Node := Next;
+ end;
+
+ else
+ Node := Node.Next;
+ end if;
+ end loop;
+ end Partition;
+
+ ----------
+ -- Sort --
+ ----------
+
+ procedure Sort (Front, Back : Node_Access) is
+ Pivot : Node_Access;
+
+ begin
+ if Front = null then
+ Pivot := Container.First;
+ else
+ Pivot := Front.Next;
+ end if;
+
+ if Pivot /= Back then
+ Partition (Pivot, Back);
+ Sort (Front, Pivot);
+ Sort (Pivot, Back);
+ end if;
+ end Sort;
+
+ -- Start of processing for Generic_Sort
+
+ begin
+ Sort (Front => null, Back => null);
+
+ pragma Assert (Container.Length = 0
+ or else (Container.First.Prev = null
+ and Container.Last.Next = null));
+ end Generic_Sort;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position.Container /= null and then Position.Node /= null;
+ end Has_Element;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ New_Node : Node_Access;
+
+ begin
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Count = 0 then
+ Position := Before;
+ return;
+ end if;
+
+ declare
+ Element : Element_Access := new Element_Type'(New_Item);
+ begin
+ New_Node := new Node_Type'(Element, null, null);
+ exception
+ when others =>
+ Free (Element);
+ raise;
+ end;
+
+ Insert_Internal (Container, Before.Node, New_Node);
+ Position := Cursor'(Before.Container, New_Node);
+
+ for J in Count_Type'(2) .. Count loop
+
+ declare
+ Element : Element_Access := new Element_Type'(New_Item);
+ begin
+ New_Node := new Node_Type'(Element, null, null);
+ exception
+ when others =>
+ Free (Element);
+ raise;
+ end;
+
+ Insert_Internal (Container, Before.Node, New_Node);
+ end loop;
+ end Insert;
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ Position : Cursor;
+ begin
+ Insert (Container, Before, New_Item, Position, Count);
+ end Insert;
+
+ ---------------------
+ -- Insert_Internal --
+ ---------------------
+
+ procedure Insert_Internal
+ (Container : in out List;
+ Before : Node_Access;
+ New_Node : Node_Access)
+ is
+ begin
+ if Container.Length = 0 then
+ pragma Assert (Before = null);
+ pragma Assert (Container.First = null);
+ pragma Assert (Container.Last = null);
+
+ Container.First := New_Node;
+ Container.Last := New_Node;
+
+ elsif Before = null then
+ pragma Assert (Container.Last.Next = null);
+
+ Container.Last.Next := New_Node;
+ New_Node.Prev := Container.Last;
+
+ Container.Last := New_Node;
+
+ elsif Before = Container.First then
+ pragma Assert (Container.First.Prev = null);
+
+ Container.First.Prev := New_Node;
+ New_Node.Next := Container.First;
+
+ Container.First := New_Node;
+
+ else
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ New_Node.Next := Before;
+ New_Node.Prev := Before.Prev;
+
+ Before.Prev.Next := New_Node;
+ Before.Prev := New_Node;
+ end if;
+
+ Container.Length := Container.Length + 1;
+ end Insert_Internal;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : List) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : List;
+ Process : not null access procedure (Position : in Cursor))
+ is
+ Node : Node_Access := Container.First;
+ begin
+ while Node /= null loop
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ Node := Node.Next;
+ end loop;
+ end Iterate;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out List; Source : in out List) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Length > 0 then
+ raise Constraint_Error;
+ end if;
+
+ Target.First := Source.First;
+ Source.First := null;
+
+ Target.Last := Source.Last;
+ Source.Last := null;
+
+ Target.Length := Source.Length;
+ Source.Length := 0;
+ end Move;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : List) return Cursor is
+ begin
+ if Container.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : List) return Element_Type is
+ begin
+ return Container.Last.Element.all;
+ end Last_Element;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : List) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ if Position.Node = null then
+ return;
+ end if;
+
+ Position.Node := Position.Node.Next;
+
+ if Position.Node = null then
+ Position.Container := null;
+ end if;
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ return No_Element;
+ end if;
+
+ declare
+ Next_Node : constant Node_Access := Position.Node.Next;
+ begin
+ if Next_Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Next_Node);
+ end;
+ end Next;
+
+ -------------
+ -- Prepend --
+ -------------
+
+ procedure Prepend
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ begin
+ Insert (Container, First (Container), New_Item, Count);
+ end Prepend;
+
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ if Position.Node = null then
+ return;
+ end if;
+
+ Position.Node := Position.Node.Prev;
+
+ if Position.Node = null then
+ Position.Container := null;
+ end if;
+ end Previous;
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ return No_Element;
+ end if;
+
+ declare
+ Prev_Node : constant Node_Access := Position.Node.Prev;
+ begin
+ if Prev_Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Prev_Node);
+ end;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in Element_Type))
+ is
+ begin
+ Process (Position.Node.Element.all);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Item : out List)
+ is
+ N : Count_Type'Base;
+ X : Node_Access;
+
+ begin
+ Clear (Item); -- ???
+
+ Count_Type'Base'Read (Stream, N);
+
+ if N = 0 then
+ return;
+ end if;
+
+ X := new Node_Type;
+
+ begin
+ X.Element := new Element_Type'(Element_Type'Input (Stream));
+ exception
+ when others =>
+ Free (X);
+ raise;
+ end;
+
+ Item.First := X;
+
+ Item.Last := X;
+ loop
+ Item.Length := Item.Length + 1;
+ exit when Item.Length = N;
+
+ X := new Node_Type;
+
+ begin
+ X.Element := new Element_Type'(Element_Type'Input (Stream));
+ exception
+ when others =>
+ Free (X);
+ raise;
+ end;
+
+ X.Prev := Item.Last;
+ Item.Last.Next := X;
+ Item.Last := X;
+ end loop;
+ end Read;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Position : Cursor;
+ By : Element_Type)
+ is
+ X : Element_Access := Position.Node.Element;
+ begin
+ Position.Node.Element := new Element_Type'(By);
+ Free (X);
+ end Replace_Element;
+
+ ------------------
+ -- Reverse_Find --
+ ------------------
+
+ function Reverse_Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor
+ is
+ Node : Node_Access := Position.Node;
+
+ begin
+ if Node = null then
+ Node := Container.Last;
+ elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ while Node /= null loop
+ if Node.Element /= null
+ and then Node.Element.all = Item
+ then
+ return Cursor'(Container'Unchecked_Access, Node);
+ end if;
+
+ Node := Node.Prev;
+ end loop;
+
+ return No_Element;
+ end Reverse_Find;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : List;
+ Process : not null access procedure (Position : in Cursor))
+ is
+ Node : Node_Access := Container.Last;
+
+ begin
+ while Node /= null loop
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ Node := Node.Prev;
+ end loop;
+ end Reverse_Iterate;
+
+ ------------------
+ -- Reverse_List --
+ ------------------
+
+ procedure Reverse_List (Container : in out List) is
+ I : Node_Access := Container.First;
+ J : Node_Access := Container.Last;
+
+ procedure Swap (L, R : Node_Access);
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (L, R : Node_Access) is
+ LN : constant Node_Access := L.Next;
+ LP : constant Node_Access := L.Prev;
+
+ RN : constant Node_Access := R.Next;
+ RP : constant Node_Access := R.Prev;
+
+ begin
+ if LP /= null then
+ LP.Next := R;
+ end if;
+
+ if RN /= null then
+ RN.Prev := L;
+ end if;
+
+ L.Next := RN;
+ R.Prev := LP;
+
+ if LN = R then
+ pragma Assert (RP = L);
+
+ L.Prev := R;
+ R.Next := L;
+
+ else
+ L.Prev := RP;
+ RP.Next := L;
+
+ R.Next := LN;
+ LN.Prev := R;
+ end if;
+ end Swap;
+
+ -- Start of processing for Reverse_List
+
+ begin
+ if Container.Length <= 1 then
+ return;
+ end if;
+
+ Container.First := J;
+ Container.Last := I;
+ loop
+ Swap (L => I, R => J);
+
+ J := J.Next;
+ exit when I = J;
+
+ I := I.Prev;
+ exit when I = J;
+
+ Swap (L => J, R => I);
+
+ I := I.Next;
+ exit when I = J;
+
+ J := J.Prev;
+ exit when I = J;
+ end loop;
+
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+ end Reverse_List;
+
+ ------------
+ -- Splice --
+ ------------
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List)
+ is
+ begin
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Target'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Target'Address = Source'Address
+ or else Source.Length = 0
+ then
+ return;
+ end if;
+
+ if Target.Length = 0 then
+ pragma Assert (Before = No_Element);
+
+ Target.First := Source.First;
+ Target.Last := Source.Last;
+
+ elsif Before.Node = null then
+ pragma Assert (Target.Last.Next = null);
+
+ Target.Last.Next := Source.First;
+ Source.First.Prev := Target.Last;
+
+ Target.Last := Source.Last;
+
+ elsif Before.Node = Target.First then
+ pragma Assert (Target.First.Prev = null);
+
+ Source.Last.Next := Target.First;
+ Target.First.Prev := Source.Last;
+
+ Target.First := Source.First;
+
+ else
+ Before.Node.Prev.Next := Source.First;
+ Source.First.Prev := Before.Node.Prev;
+
+ Before.Node.Prev := Source.Last;
+ Source.Last.Next := Before.Node;
+ end if;
+
+ Source.First := null;
+ Source.Last := null;
+
+ Target.Length := Target.Length + Source.Length;
+ Source.Length := 0;
+ end Splice;
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Position : Cursor)
+ is
+ X : Node_Access := Position.Node;
+
+ begin
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Target'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Position.Container /= null
+ and then Position.Container /= List_Access'(Target'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if X = null
+ or else X = Before.Node
+ or else X.Next = Before.Node
+ then
+ return;
+ end if;
+
+ pragma Assert (Target.Length > 0);
+
+ if Before.Node = null then
+ pragma Assert (X /= Target.Last);
+
+ if X = Target.First then
+ Target.First := X.Next;
+ Target.First.Prev := null;
+ else
+ X.Prev.Next := X.Next;
+ X.Next.Prev := X.Prev;
+ end if;
+
+ Target.Last.Next := X;
+ X.Prev := Target.Last;
+
+ Target.Last := X;
+ Target.Last.Next := null;
+
+ return;
+ end if;
+
+ if Before.Node = Target.First then
+ pragma Assert (X /= Target.First);
+
+ if X = Target.Last then
+ Target.Last := X.Prev;
+ Target.Last.Next := null;
+ else
+ X.Prev.Next := X.Next;
+ X.Next.Prev := X.Prev;
+ end if;
+
+ Target.First.Prev := X;
+ X.Next := Target.First;
+
+ Target.First := X;
+ Target.First.Prev := null;
+
+ return;
+ end if;
+
+ if X = Target.First then
+ Target.First := X.Next;
+ Target.First.Prev := null;
+
+ elsif X = Target.Last then
+ Target.Last := X.Prev;
+ Target.Last.Next := null;
+
+ else
+ X.Prev.Next := X.Next;
+ X.Next.Prev := X.Prev;
+ end if;
+
+ Before.Node.Prev.Next := X;
+ X.Prev := Before.Node.Prev;
+
+ Before.Node.Prev := X;
+ X.Next := Before.Node;
+ end Splice;
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List;
+ Position : Cursor)
+ is
+ X : Node_Access := Position.Node;
+
+ begin
+ if Target'Address = Source'Address then
+ Splice (Target, Before, Position);
+ return;
+ end if;
+
+ if Before.Container /= null
+ and then Before.Container /= List_Access'(Target'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Position.Container /= null
+ and then Position.Container /= List_Access'(Source'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if X = null then
+ return;
+ end if;
+
+ pragma Assert (Source.Length > 0);
+ pragma Assert (Source.First.Prev = null);
+ pragma Assert (Source.Last.Next = null);
+
+ if X = Source.First then
+ Source.First := X.Next;
+ Source.First.Prev := null;
+
+ if X = Source.Last then
+ pragma Assert (Source.First = null);
+ pragma Assert (Source.Length = 1);
+ Source.Last := null;
+ end if;
+
+ elsif X = Source.Last then
+ Source.Last := X.Prev;
+ Source.Last.Next := null;
+
+ else
+ X.Prev.Next := X.Next;
+ X.Next.Prev := X.Prev;
+ end if;
+
+ if Target.Length = 0 then
+ pragma Assert (Before = No_Element);
+ pragma Assert (Target.First = null);
+ pragma Assert (Target.Last = null);
+
+ Target.First := X;
+ Target.Last := X;
+
+ elsif Before.Node = null then
+ Target.Last.Next := X;
+ X.Next := Target.Last;
+
+ Target.Last := X;
+ Target.Last.Next := null;
+
+ elsif Before.Node = Target.First then
+ Target.First.Prev := X;
+ X.Next := Target.First;
+
+ Target.First := X;
+ Target.First.Prev := null;
+
+ else
+ Before.Node.Prev.Next := X;
+ X.Prev := Before.Node.Prev;
+
+ Before.Node.Prev := X;
+ X.Next := Before.Node;
+ end if;
+
+ Target.Length := Target.Length + 1;
+ Source.Length := Source.Length - 1;
+ end Splice;
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (I, J : Cursor) is
+
+ -- Is this op legal when I and J designate elements in different
+ -- containers, or should it raise an exception (e.g. Program_Error).
+
+ EI : constant Element_Access := I.Node.Element;
+
+ begin
+ I.Node.Element := J.Node.Element;
+ J.Node.Element := EI;
+ end Swap;
+
+ ----------------
+ -- Swap_Links --
+ ----------------
+
+ procedure Swap_Links
+ (Container : in out List;
+ I, J : Cursor)
+ is
+ begin
+ if I = No_Element
+ or else J = No_Element
+ then
+ raise Constraint_Error;
+ end if;
+
+ if I.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ if J.Container /= I.Container then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length >= 1);
+
+ if I.Node = J.Node then
+ return;
+ end if;
+
+ pragma Assert (Container.Length >= 2);
+
+ declare
+ I_Next : constant Cursor := Next (I);
+
+ begin
+ if I_Next = J then
+ Splice (Container, Before => I, Position => J);
+
+ else
+ declare
+ J_Next : constant Cursor := Next (J);
+ begin
+ if J_Next = I then
+ Splice (Container, Before => J, Position => I);
+
+ else
+ pragma Assert (Container.Length >= 3);
+
+ Splice (Container, Before => I_Next, Position => J);
+ Splice (Container, Before => J_Next, Position => I);
+ end if;
+ end;
+ end if;
+ end;
+ end Swap_Links;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ Process (Position.Node.Element.all);
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Item : List)
+ is
+ Node : Node_Access := Item.First;
+ begin
+ Count_Type'Base'Write (Stream, Item.Length);
+ while Node /= null loop
+ Element_Type'Output (Stream, Node.Element.all); -- X.all
+ Node := Node.Next;
+ end loop;
+ end Write;
+
+end Ada.Containers.Indefinite_Doubly_Linked_Lists;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+
+ type Element_Type (<>) is private;
+
+ with function "=" (Left, Right : Element_Type)
+ return Boolean is <>;
+
+package Ada.Containers.Indefinite_Doubly_Linked_Lists is
+ pragma Preelaborate (Indefinite_Doubly_Linked_Lists);
+
+ type List is tagged private;
+
+ type Cursor is private;
+
+ Empty_List : constant List;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : List) return Boolean;
+
+ function Length (Container : List) return Count_Type;
+
+ function Is_Empty (Container : List) return Boolean;
+
+ procedure Clear (Container : in out List);
+
+ function Element (Position : Cursor)
+ return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Replace_Element
+ (Position : Cursor;
+ By : Element_Type);
+
+ procedure Move
+ (Target : in out List;
+ Source : in out List);
+
+ procedure Prepend
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Append
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete
+ (Container : in out List;
+ Position : in out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete_First
+ (Container : in out List;
+ Count : Count_Type := 1);
+
+ procedure Delete_Last
+ (Container : in out List;
+ Count : Count_Type := 1);
+
+ generic
+ with function "<" (Left, Right : Element_Type)
+ return Boolean is <>;
+ procedure Generic_Sort (Container : in out List);
+
+ generic
+ with function "<" (Left, Right : Element_Type)
+ return Boolean is <>;
+ procedure Generic_Merge
+ (Target : in out List;
+ Source : in out List);
+
+ procedure Reverse_List (Container : in out List);
+
+ procedure Swap (I, J : Cursor);
+
+ procedure Swap_Links (Container : in out List; I, J : Cursor);
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List);
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Position : Cursor);
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List;
+ Position : Cursor);
+
+ function First (Container : List) return Cursor;
+
+ function First_Element (Container : List) return Element_Type;
+
+ function Last (Container : List) return Cursor;
+
+ function Last_Element (Container : List) return Element_Type;
+
+ function Contains
+ (Container : List;
+ Item : Element_Type) return Boolean;
+
+ function Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Reverse_Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : List;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : List;
+ Process : not null access procedure (Position : Cursor));
+
+private
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ type Element_Access is access Element_Type;
+
+ type Node_Type is
+ record
+ Element : Element_Access;
+ Next : Node_Access;
+ Prev : Node_Access;
+ end record;
+
+ function "=" (L, R : Node_Type) return Boolean is abstract;
+
+ use Ada.Finalization;
+
+ type List is
+ new Controlled with record
+ First : Node_Access;
+ Last : Node_Access;
+ Length : Count_Type := 0;
+ end record;
+
+ procedure Adjust (Container : in out List);
+
+ procedure Finalize (Container : in out List) renames Clear;
+
+ use Ada.Streams;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Item : out List);
+
+ for List'Read use Read;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Item : List);
+
+ for List'Write use Write;
+
+ Empty_List : constant List := List'(Controlled with null, null, 0);
+
+ type List_Access is access constant List;
+ for List_Access'Storage_Size use 0;
+
+ type Cursor is
+ record
+ Container : List_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, null);
+
+end Ada.Containers.Indefinite_Doubly_Linked_Lists;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS --
+-- --
+-- 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.Hash_Tables.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
+
+with Ada.Containers.Hash_Tables.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
+
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Containers.Indefinite_Hashed_Maps is
+
+ type Key_Access is access Key_Type;
+ type Element_Access is access Element_Type;
+
+ type Node_Type is limited record
+ Key : Key_Access;
+ Element : Element_Access;
+ Next : Node_Access;
+ end record;
+
+ procedure Free_Key is
+ new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
+
+ procedure Free_Element is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Copy_Node (Node : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ function Find_Equal_Key
+ (R_Map : Map;
+ L_Node : Node_Access) return Boolean;
+
+ procedure Free (X : in out Node_Access);
+ pragma Inline (Free);
+
+ function Hash_Node (Node : Node_Access) return Hash_Type;
+ pragma Inline (Hash_Node);
+
+ function Next (Node : Node_Access) return Node_Access;
+ pragma Inline (Next);
+
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+
+ procedure Set_Next (Node : Node_Access; Next : Node_Access);
+ pragma Inline (Set_Next);
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package HT_Ops is
+ new Ada.Containers.Hash_Tables.Generic_Operations
+ (HT_Types => HT_Types,
+ Hash_Table_Type => Map,
+ Null_Node => null,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next,
+ Copy_Node => Copy_Node,
+ Free => Free);
+
+ package Key_Ops is
+ new Hash_Tables.Generic_Keys
+ (HT_Types => HT_Types,
+ HT_Type => Map,
+ Null_Node => null,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Key_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Keys);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
+
+ function "=" (Left, Right : Map) return Boolean renames Is_Equal;
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Map) renames HT_Ops.Adjust;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Map)
+ return Count_Type renames HT_Ops.Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Map) renames HT_Ops.Clear;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ function Copy_Node (Node : Node_Access) return Node_Access is
+ K : Key_Access := new Key_Type'(Node.Key.all);
+ E : Element_Access;
+
+ begin
+ E := new Element_Type'(Node.Element.all);
+ return new Node_Type'(K, E, null);
+
+ exception
+ when others =>
+ Free_Key (K);
+ Free_Element (E);
+ raise;
+ end Copy_Node;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Map; Key : Key_Type) is
+ X : Node_Access;
+
+ begin
+ Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Free (X);
+ end Delete;
+
+ procedure Delete (Container : in out Map; Position : in out Cursor) is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Map_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type is
+ C : constant Cursor := Find (Container, Key);
+ begin
+ return C.Node.Element.all;
+ end Element;
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element.all;
+ end Element;
+
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean
+ is
+ begin
+ return Equivalent_Keys (Key, Node.Key.all);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys (Left, Right : Cursor) return Boolean is
+ begin
+ return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys
+ (Left : Cursor;
+ Right : Key_Type) return Boolean
+ is
+ begin
+ return Equivalent_Keys (Left.Node.Key.all, Right);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Cursor) return Boolean
+ is
+ begin
+ return Equivalent_Keys (Left, Right.Node.Key.all);
+ end Equivalent_Keys;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Map; Key : Key_Type) is
+ X : Node_Access;
+ begin
+ Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Free (X);
+ end Exclude;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Container : in out Map) renames HT_Ops.Finalize;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ --------------------
+ -- Find_Equal_Key --
+ --------------------
+
+ function Find_Equal_Key
+ (R_Map : Map;
+ L_Node : Node_Access) return Boolean
+ is
+ R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key.all);
+ R_Node : Node_Access := R_Map.Buckets (R_Index);
+
+ begin
+ while R_Node /= null loop
+ if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
+ return L_Node.Element.all = R_Node.Element.all;
+ end if;
+
+ R_Node := R_Node.Next;
+ end loop;
+
+ return False;
+ end Find_Equal_Key;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Map) return Cursor is
+ Node : constant Node_Access := HT_Ops.First (Container);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end First;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ begin
+ if X /= null then
+ Free_Key (X.Key);
+ Free_Element (X.Element);
+ Deallocate (X);
+ end if;
+ end Free;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ ---------------
+ -- Hash_Node --
+ ---------------
+
+ function Hash_Node (Node : Node_Access) return Hash_Type is
+ begin
+ return Hash (Node.Key.all);
+ end Hash_Node;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ K : Key_Access;
+ E : Element_Access;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ K := Position.Node.Key;
+ E := Position.Node.Element;
+
+ Position.Node.Key := new Key_Type'(Key);
+ Position.Node.Element := new Element_Type'(New_Item);
+
+ Free_Key (K);
+ Free_Element (E);
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node (Next : Node_Access) return Node_Access;
+
+ procedure Insert is
+ new Key_Ops.Generic_Conditional_Insert (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ K : Key_Access := new Key_Type'(Key);
+ E : Element_Access;
+ begin
+ E := new Element_Type'(New_Item);
+ return new Node_Type'(K, E, Next);
+ exception
+ when others =>
+ Free_Key (K);
+ Free_Element (E);
+ raise;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
+ Insert (Container, Key, Position.Node, Inserted);
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+ end Insert;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Map) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing Iterate
+
+ begin
+ Iterate (Container);
+ end Iterate;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Position.Node.Key.all;
+ end Key;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Map) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Target : in out Map;
+ Source : in out Map) renames HT_Ops.Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Next;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ M : Map renames Position.Container.all;
+ Node : constant Node_Access := HT_Ops.Next (M, Position.Node);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ Process (Position.Node.Key.all, Position.Node.Element.all);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Map) renames Read_Nodes;
+
+ ---------------
+ -- Read_Node --
+ ---------------
+
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ begin
+ Node.Key := new Key_Type'(Key_Type'Input (Stream));
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end;
+
+ begin
+ Node.Element := new Element_Type'(Element_Type'Input (Stream));
+ exception
+ when others =>
+ Free_Key (Node.Key);
+ Free (Node);
+ raise;
+ end;
+
+ return Node;
+ end Read_Node;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access := Key_Ops.Find (Container, Key);
+
+ K : Key_Access;
+ E : Element_Access;
+
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
+ K := Node.Key;
+ E := Node.Element;
+
+ Node.Key := new Key_Type'(Key);
+ Node.Element := new Element_Type'(New_Item);
+
+ Free_Key (K);
+ Free_Element (E);
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ X : Element_Access := Position.Node.Element;
+ begin
+ Position.Node.Element := new Element_Type'(By);
+ Free_Element (X);
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Map;
+ Capacity : Count_Type) renames HT_Ops.Ensure_Capacity;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (Node : Node_Access; Next : Node_Access) is
+ begin
+ Node.Next := Next;
+ end Set_Next;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ Process (Position.Node.Key.all, Position.Node.Element.all);
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Map) renames Write_Nodes;
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
+ begin
+ Key_Type'Output (Stream, Node.Key.all);
+ Element_Type'Output (Stream, Node.Element.all);
+ end Write_Node;
+
+end Ada.Containers.Indefinite_Hashed_Maps;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Hash_Tables;
+with Ada.Streams;
+
+generic
+ type Key_Type (<>) is private;
+ type Element_Type (<>) is private;
+
+ with function Hash (Key : Key_Type) return Hash_Type;
+ with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Hashed_Maps is
+ pragma Preelaborate (Indefinite_Hashed_Maps);
+
+ type Map is tagged private;
+ type Cursor is private;
+
+ Empty_Map : constant Map;
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Map) return Boolean;
+
+ function Length (Container : Map) return Count_Type;
+
+ function Is_Empty (Container : Map) return Boolean;
+
+ procedure Clear (Container : in out Map);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : Element_Type));
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type));
+
+ procedure Replace_Element
+ (Position : Cursor;
+ By : Element_Type);
+
+ procedure Move (Target : in out Map; Source : in out Map);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Map;
+ Key : Key_Type);
+
+ procedure Exclude
+ (Container : in out Map;
+ Key : Key_Type);
+
+ procedure Delete
+ (Container : in out Map;
+ Position : in out Cursor);
+
+ function Contains
+ (Container : Map;
+ Key : Key_Type) return Boolean;
+
+ function Find
+ (Container : Map;
+ Key : Key_Type) return Cursor;
+
+ function Element
+ (Container : Map;
+ Key : Key_Type) return Element_Type;
+
+ function Capacity (Container : Map) return Count_Type;
+
+ procedure Reserve_Capacity
+ (Container : in out Map;
+ Capacity : Count_Type);
+
+ function First (Container : Map) return Cursor;
+
+ function Next (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Equivalent_Keys (Left, Right : Cursor)
+ return Boolean;
+
+ function Equivalent_Keys
+ (Left : Cursor;
+ Right : Key_Type) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+
+private
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package HT_Types is
+ new Hash_Tables.Generic_Hash_Table_Types (Node_Access);
+
+ use HT_Types;
+
+ type Map is new Hash_Table_Type with null record;
+
+ procedure Adjust (Container : in out Map);
+
+ procedure Finalize (Container : in out Map);
+
+ type Map_Access is access constant Map;
+ for Map_Access'Storage_Size use 0;
+
+ type Cursor is
+ record
+ Container : Map_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor :=
+ (Container => null,
+ Node => null);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Map);
+
+ for Map'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Map);
+
+ for Map'Read use Read;
+
+ Empty_Map : constant Map := (Hash_Table_Type with null record);
+
+end Ada.Containers.Indefinite_Hashed_Maps;
+
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
+-- --
+-- 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.Unchecked_Deallocation;
+
+with Ada.Containers.Hash_Tables.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
+
+with Ada.Containers.Hash_Tables.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
+
+with System; use type System.Address;
+
+with Ada.Containers.Prime_Numbers;
+
+with Ada.Finalization; use Ada.Finalization;
+
+package body Ada.Containers.Indefinite_Hashed_Sets is
+
+ type Element_Access is access Element_Type;
+
+ type Node_Type is
+ limited record
+ Element : Element_Access;
+ Next : Node_Access;
+ end record;
+
+ function Hash_Node
+ (Node : Node_Access) return Hash_Type;
+ pragma Inline (Hash_Node);
+
+ function Hash_Node
+ (Node : Node_Access) return Hash_Type is
+ begin
+ return Hash (Node.Element.all);
+ end Hash_Node;
+
+ function Next
+ (Node : Node_Access) return Node_Access;
+ pragma Inline (Next);
+
+ function Next
+ (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Next;
+ end Next;
+
+ procedure Set_Next
+ (Node : Node_Access;
+ Next : Node_Access);
+ pragma Inline (Set_Next);
+
+ procedure Set_Next
+ (Node : Node_Access;
+ Next : Node_Access) is
+ begin
+ Node.Next := Next;
+ end Set_Next;
+
+ function Equivalent_Keys
+ (Key : Element_Type;
+ Node : Node_Access) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ function Equivalent_Keys
+ (Key : Element_Type;
+ Node : Node_Access) return Boolean is
+ begin
+ return Equivalent_Keys (Key, Node.Element.all);
+ end Equivalent_Keys;
+
+ function Copy_Node
+ (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Copy_Node
+ (Source : Node_Access) return Node_Access is
+
+ Target : constant Node_Access :=
+ new Node_Type'(Element => Source.Element,
+ Next => null);
+ begin
+ return Target;
+ end Copy_Node;
+
+
+ procedure Free_Element is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ procedure Free (X : in out Node_Access);
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ begin
+ if X /= null then
+ Free_Element (X.Element);
+ Deallocate (X);
+ end if;
+ end Free;
+
+ package HT_Ops is
+ new Hash_Tables.Generic_Operations
+ (HT_Types => HT_Types,
+ Hash_Table_Type => Set,
+ Null_Node => null,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next,
+ Copy_Node => Copy_Node,
+ Free => Free);
+
+ package Element_Keys is
+ new Hash_Tables.Generic_Keys
+ (HT_Types => HT_Types,
+ HT_Type => Set,
+ Null_Node => null,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Element_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Keys);
+
+
+ procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;
+
+ procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;
+
+
+ function Find_Equal_Key
+ (R_Set : Set;
+ L_Node : Node_Access) return Boolean;
+
+ function Find_Equal_Key
+ (R_Set : Set;
+ L_Node : Node_Access) return Boolean is
+
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_Set, L_Node.Element.all);
+
+ R_Node : Node_Access := R_Set.Buckets (R_Index);
+
+ begin
+
+ loop
+
+ if R_Node = null then
+ return False;
+ end if;
+
+ if L_Node.Element.all = R_Node.Element.all then
+ return True;
+ end if;
+
+ R_Node := Next (R_Node);
+
+ end loop;
+
+ end Find_Equal_Key;
+
+ function Is_Equal is
+ new HT_Ops.Generic_Equal (Find_Equal_Key);
+
+ function "=" (Left, Right : Set) return Boolean renames Is_Equal;
+
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+
+ procedure Clear (Container : in out Set) renames HT_Ops.Clear;
+
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element.all;
+ end Element;
+
+
+ procedure Query_Element
+ (Position : in Cursor;
+ Process : not null access procedure (Element : in Element_Type)) is
+ begin
+ Process (Position.Node.Element.all);
+ end Query_Element;
+
+
+-- TODO:
+-- procedure Replace_Element (Container : in out Set;
+-- Position : in Node_Access;
+-- By : in Element_Type);
+
+-- procedure Replace_Element (Container : in out Set;
+-- Position : in Node_Access;
+-- By : in Element_Type) is
+
+-- Node : Node_Access := Position;
+
+-- begin
+
+-- if Equivalent_Keys (Node.Element.all, By) then
+
+-- declare
+-- X : Element_Access := Node.Element;
+-- begin
+-- Node.Element := new Element_Type'(By);
+-- --
+-- -- NOTE: If there's an exception here, then just
+-- -- let it propagate. We haven't modified the
+-- -- state of the container, so there's nothing else
+-- -- we need to do.
+
+-- Free_Element (X);
+-- end;
+
+-- return;
+
+-- end if;
+
+-- HT_Ops.Delete_Node_Sans_Free (Container, Node);
+
+-- begin
+-- Free_Element (Node.Element);
+-- exception
+-- when others =>
+-- Node.Element := null; -- don't attempt to dealloc X.E again
+-- Free (Node);
+-- raise;
+-- end;
+
+-- begin
+-- Node.Element := new Element_Type'(By);
+-- exception
+-- when others =>
+-- Free (Node);
+-- raise;
+-- end;
+
+-- declare
+-- function New_Node (Next : Node_Access) return Node_Access;
+-- pragma Inline (New_Node);
+
+-- function New_Node (Next : Node_Access) return Node_Access is
+-- begin
+-- Node.Next := Next;
+-- return Node;
+-- end New_Node;
+
+-- procedure Insert is
+-- new Element_Keys.Generic_Conditional_Insert (New_Node);
+
+-- Result : Node_Access;
+-- Success : Boolean;
+-- begin
+-- Insert
+-- (HT => Container,
+-- Key => Node.Element.all,
+-- Node => Result,
+-- Success => Success);
+
+-- if not Success then
+-- Free (Node);
+-- raise Program_Error;
+-- end if;
+
+-- pragma Assert (Result = Node);
+-- end;
+
+-- end Replace_Element;
+
+
+-- procedure Replace_Element (Container : in out Set;
+-- Position : in Cursor;
+-- By : in Element_Type) is
+-- begin
+
+-- if Position.Container = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+-- raise Program_Error;
+-- end if;
+
+-- Replace_Element (Container, Position.Node, By);
+
+-- end Replace_Element;
+
+
+ procedure Move (Target : in out Set;
+ Source : in out Set) renames HT_Ops.Move;
+
+
+ procedure Insert (Container : in out Set;
+ New_Item : in Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean) is
+
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ Element : Element_Access := new Element_Type'(New_Item);
+ begin
+ return new Node_Type'(Element, Next);
+ exception
+ when others =>
+ Free_Element (Element);
+ raise;
+ end New_Node;
+
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
+
+ begin
+
+ HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
+ Insert (Container, New_Item, Position.Node, Inserted);
+ Position.Container := Container'Unchecked_Access;
+
+ end Insert;
+
+
+ procedure Insert (Container : in out Set;
+ New_Item : in Element_Type) is
+
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+
+ end Insert;
+
+
+ procedure Replace (Container : in out Set;
+ New_Item : in Element_Type) is
+
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container, New_Item);
+
+ X : Element_Access;
+
+ begin
+
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
+ X := Node.Element;
+
+ Node.Element := new Element_Type'(New_Item);
+
+ Free_Element (X);
+
+ end Replace;
+
+
+ procedure Include (Container : in out Set;
+ New_Item : in Element_Type) is
+
+ Position : Cursor;
+ Inserted : Boolean;
+
+ X : Element_Access;
+
+ begin
+
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+
+ X := Position.Node.Element;
+
+ Position.Node.Element := new Element_Type'(New_Item);
+
+ Free_Element (X);
+
+ end if;
+
+ end Include;
+
+
+ procedure Delete (Container : in out Set;
+ Item : in Element_Type) is
+
+ X : Node_Access;
+
+ begin
+
+ Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Free (X);
+
+ end Delete;
+
+
+ procedure Exclude (Container : in out Set;
+ Item : in Element_Type) is
+
+ X : Node_Access;
+
+ begin
+
+ Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+ Free (X);
+
+ end Exclude;
+
+
+ procedure Delete (Container : in out Set;
+ Position : in out Cursor) is
+ begin
+
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+
+ end Delete;
+
+
+
+ procedure Union (Target : in out Set;
+ Source : in Set) is
+
+ procedure Process (Src_Node : in Node_Access);
+
+ procedure Process (Src_Node : in Node_Access) is
+
+ Src : Element_Type renames Src_Node.Element.all;
+
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ Tgt : Element_Access := new Element_Type'(Src);
+ begin
+ return new Node_Type'(Tgt, Next);
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end New_Node;
+
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
+
+ Tgt_Node : Node_Access;
+ Success : Boolean;
+
+ begin
+
+ Insert (Target, Src, Tgt_Node, Success);
+
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ begin
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
+
+ Iterate (Source);
+
+ end Union;
+
+
+
+ function Union (Left, Right : Set) return Set is
+
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+
+ begin
+
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ if Left.Length = 0 then
+ return Right;
+ end if;
+
+ declare
+ Size : constant Hash_Type :=
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+
+ declare
+ procedure Process (L_Node : Node_Access);
+
+ procedure Process (L_Node : Node_Access) is
+ I : constant Hash_Type :=
+ Hash (L_Node.Element.all) mod Buckets'Length;
+ begin
+ Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Left);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ Length := Left.Length;
+
+ declare
+ procedure Process (Src_Node : Node_Access);
+
+ procedure Process (Src_Node : Node_Access) is
+
+ Src : Element_Type renames Src_Node.Element.all;
+
+ I : constant Hash_Type :=
+ Hash (Src) mod Buckets'Length;
+
+ Tgt_Node : Node_Access := Buckets (I);
+
+ begin
+
+ while Tgt_Node /= null loop
+
+ if Equivalent_Keys (Src, Tgt_Node.Element.all) then
+ return;
+ end if;
+
+ Tgt_Node := Next (Tgt_Node);
+
+ end loop;
+
+ declare
+ Tgt : Element_Access := new Element_Type'(Src);
+ begin
+ Buckets (I) := new Node_Type'(Tgt, Buckets (I));
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end;
+
+ Length := Length + 1;
+
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Right);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ return (Controlled with Buckets, Length);
+
+ end Union;
+
+
+ function Is_In
+ (HT : Set;
+ Key : Node_Access) return Boolean;
+ pragma Inline (Is_In);
+
+ function Is_In
+ (HT : Set;
+ Key : Node_Access) return Boolean is
+ begin
+ return Element_Keys.Find (HT, Key.Element.all) /= null;
+ end Is_In;
+
+
+ procedure Intersection (Target : in out Set;
+ Source : in Set) is
+
+ Tgt_Node : Node_Access;
+
+ begin
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ Clear (Target);
+ return;
+ end if;
+
+ -- TODO: optimize this to use an explicit
+ -- loop instead of an active iterator
+ -- (similar to how a passive iterator is
+ -- implemented).
+ --
+ -- Another possibility is to test which
+ -- set is smaller, and iterate over the
+ -- smaller set.
+
+ Tgt_Node := HT_Ops.First (Target);
+
+ while Tgt_Node /= null loop
+
+ if Is_In (Source, Tgt_Node) then
+
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+
+ else
+
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, X);
+ Free (X);
+ end;
+
+ end if;
+
+ end loop;
+
+ end Intersection;
+
+
+ function Intersection (Left, Right : Set) return Set is
+
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+
+ begin
+
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ Length := Count_Type'Min (Left.Length, Right.Length);
+
+ if Length = 0 then
+ return Empty_Set;
+ end if;
+
+ declare
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+
+ Length := 0;
+
+ declare
+ procedure Process (L_Node : Node_Access);
+
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if Is_In (Right, L_Node) then
+
+ declare
+ I : constant Hash_Type :=
+ Hash (L_Node.Element.all) mod Buckets'Length;
+ begin
+ Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
+ end;
+
+ Length := Length + 1;
+
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Left);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ return (Controlled with Buckets, Length);
+
+ end Intersection;
+
+
+ procedure Difference (Target : in out Set;
+ Source : in Set) is
+
+
+ Tgt_Node : Node_Access;
+
+ begin
+
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ return;
+ end if;
+
+ -- TODO: As I noted above, this can be
+ -- written in terms of a loop instead as
+ -- active-iterator style, sort of like a
+ -- passive iterator.
+
+ Tgt_Node := HT_Ops.First (Target);
+
+ while Tgt_Node /= null loop
+
+ if Is_In (Source, Tgt_Node) then
+
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, X);
+ Free (X);
+ end;
+
+ else
+
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+
+ end if;
+
+ end loop;
+
+ end Difference;
+
+
+
+ function Difference (Left, Right : Set) return Set is
+
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+
+ begin
+
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ if Left.Length = 0 then
+ return Empty_Set;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ declare
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+
+ Length := 0;
+
+ declare
+ procedure Process (L_Node : Node_Access);
+
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if not Is_In (Right, L_Node) then
+
+ declare
+ I : constant Hash_Type :=
+ Hash (L_Node.Element.all) mod Buckets'Length;
+ begin
+ Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
+ end;
+
+ Length := Length + 1;
+
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Left);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ return (Controlled with Buckets, Length);
+
+ end Difference;
+
+
+
+ procedure Symmetric_Difference (Target : in out Set;
+ Source : in Set) is
+ begin
+
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
+
+ if Target.Length = 0 then
+
+ declare
+ procedure Process (Src_Node : Node_Access);
+
+ procedure Process (Src_Node : Node_Access) is
+ E : Element_Type renames Src_Node.Element.all;
+ B : Buckets_Type renames Target.Buckets.all;
+ I : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.Length;
+ begin
+ declare
+ X : Element_Access := new Element_Type'(E);
+ begin
+ B (I) := new Node_Type'(X, B (I));
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end;
+
+ N := N + 1;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Source);
+ end;
+
+ else
+
+ declare
+ procedure Process (Src_Node : Node_Access);
+
+ procedure Process (Src_Node : Node_Access) is
+ E : Element_Type renames Src_Node.Element.all;
+ B : Buckets_Type renames Target.Buckets.all;
+ I : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.Length;
+ begin
+ if B (I) = null then
+
+ declare
+ X : Element_Access := new Element_Type'(E);
+ begin
+ B (I) := new Node_Type'(X, null);
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end;
+
+ N := N + 1;
+
+ elsif Equivalent_Keys (E, B (I).Element.all) then
+
+ declare
+ X : Node_Access := B (I);
+ begin
+ B (I) := B (I).Next;
+ N := N - 1;
+ Free (X);
+ end;
+
+ else
+
+ declare
+ Prev : Node_Access := B (I);
+ Curr : Node_Access := Prev.Next;
+ begin
+ while Curr /= null loop
+ if Equivalent_Keys (E, Curr.Element.all) then
+ Prev.Next := Curr.Next;
+ N := N - 1;
+ Free (Curr);
+ return;
+ end if;
+
+ Prev := Curr;
+ Curr := Prev.Next;
+ end loop;
+
+ declare
+ X : Element_Access := new Element_Type'(E);
+ begin
+ B (I) := new Node_Type'(X, B (I));
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end;
+
+ N := N + 1;
+ end;
+
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Source);
+ end;
+
+ end if;
+
+ end Symmetric_Difference;
+
+
+ function Symmetric_Difference (Left, Right : Set) return Set is
+
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+
+ begin
+
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ if Left.Length = 0 then
+ return Right;
+ end if;
+
+ declare
+ Size : constant Hash_Type :=
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+
+ Length := 0;
+
+ declare
+ procedure Process (L_Node : Node_Access);
+
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if not Is_In (Right, L_Node) then
+ declare
+ E : Element_Type renames L_Node.Element.all;
+ I : constant Hash_Type := Hash (E) mod Buckets'Length;
+ begin
+
+ declare
+ X : Element_Access := new Element_Type'(E);
+ begin
+ Buckets (I) := new Node_Type'(X, Buckets (I));
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end;
+
+ Length := Length + 1;
+ end;
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Left);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ declare
+ procedure Process (R_Node : Node_Access);
+
+ procedure Process (R_Node : Node_Access) is
+ begin
+ if not Is_In (Left, R_Node) then
+ declare
+ E : Element_Type renames R_Node.Element.all;
+ I : constant Hash_Type := Hash (E) mod Buckets'Length;
+ begin
+
+ declare
+ X : Element_Access := new Element_Type'(E);
+ begin
+ Buckets (I) := new Node_Type'(X, Buckets (I));
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end;
+
+ Length := Length + 1;
+
+ end;
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Right);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ return (Controlled with Buckets, Length);
+
+ end Symmetric_Difference;
+
+
+ function Is_Subset (Subset : Set;
+ Of_Set : Set) return Boolean is
+
+ Subset_Node : Node_Access;
+
+ begin
+
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ if Subset.Length > Of_Set.Length then
+ return False;
+ end if;
+
+ -- TODO: rewrite this to loop in the
+ -- style of a passive iterator.
+
+ Subset_Node := HT_Ops.First (Subset);
+
+ while Subset_Node /= null loop
+ if not Is_In (Of_Set, Subset_Node) then
+ return False;
+ end if;
+
+ Subset_Node := HT_Ops.Next (Subset, Subset_Node);
+ end loop;
+
+ return True;
+
+ end Is_Subset;
+
+
+ function Overlap (Left, Right : Set) return Boolean is
+
+ Left_Node : Node_Access;
+
+ begin
+
+ if Right.Length = 0 then
+ return False;
+ end if;
+
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ Left_Node := HT_Ops.First (Left);
+
+ while Left_Node /= null loop
+ if Is_In (Right, Left_Node) then
+ return True;
+ end if;
+
+ Left_Node := HT_Ops.Next (Left, Left_Node);
+ end loop;
+
+ return False;
+
+ end Overlap;
+
+
+ function Find (Container : Set;
+ Item : Element_Type) return Cursor is
+
+ Node : constant Node_Access := Element_Keys.Find (Container, Item);
+
+ begin
+
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+
+ end Find;
+
+
+ function Contains (Container : Set;
+ Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+
+
+ function First (Container : Set) return Cursor is
+ Node : constant Node_Access := HT_Ops.First (Container);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end First;
+
+
+-- function First_Element (Container : Set) return Element_Type is
+-- Node : constant Node_Access := HT_Ops.First (Container);
+-- begin
+-- return Node.Element;
+-- end First_Element;
+
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Container = null
+ or else Position.Node = null
+ then
+ return No_Element;
+ end if;
+
+ declare
+ S : Set renames Position.Container.all;
+ Node : constant Node_Access := HT_Ops.Next (S, Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ if Position.Container = null then
+ return False;
+ end if;
+
+ if Position.Node = null then
+ return False;
+ end if;
+
+ return True;
+ end Has_Element;
+
+
+ function Equivalent_Keys (Left, Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left.Node.Element.all, Right.Node.Element.all);
+ end Equivalent_Keys;
+
+
+ function Equivalent_Keys (Left : Cursor;
+ Right : Element_Type)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left.Node.Element.all, Right);
+ end Equivalent_Keys;
+
+
+ function Equivalent_Keys (Left : Element_Type;
+ Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left, Right.Node.Element.all);
+ end Equivalent_Keys;
+
+
+ procedure Iterate
+ (Container : in Set;
+ Process : not null access procedure (Position : in Cursor)) is
+
+ procedure Process_Node (Node : in Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Process_Node (Node : in Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process_Node);
+ begin
+ Iterate (Container);
+ end Iterate;
+
+
+ function Capacity (Container : Set) return Count_Type
+ renames HT_Ops.Capacity;
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : in Count_Type)
+ renames HT_Ops.Ensure_Capacity;
+
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : in Node_Access);
+ pragma Inline (Write_Node);
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : in Node_Access) is
+ begin
+ Element_Type'Output (Stream, Node.Element.all);
+ end Write_Node;
+
+ procedure Write_Nodes is
+ new HT_Ops.Generic_Write (Write_Node);
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : in Set) renames Write_Nodes;
+
+
+ function Read_Node (Stream : access Root_Stream_Type'Class)
+ return Node_Access;
+ pragma Inline (Read_Node);
+
+ function Read_Node (Stream : access Root_Stream_Type'Class)
+ return Node_Access is
+
+ X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
+ begin
+ return new Node_Type'(X, null);
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end Read_Node;
+
+ procedure Read_Nodes is
+ new HT_Ops.Generic_Read (Read_Node);
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set) renames Read_Nodes;
+
+
+ package body Generic_Keys is
+
+ function Equivalent_Keys (Left : Cursor;
+ Right : Key_Type)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Right, Left.Node.Element.all);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys (Left : Key_Type;
+ Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left, Right.Node.Element.all);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean is
+ begin
+ return Equivalent_Keys (Key, Node.Element.all);
+ end Equivalent_Keys;
+
+ package Key_Keys is
+ new Hash_Tables.Generic_Keys
+ (HT_Types => HT_Types,
+ HT_Type => Set,
+ Null_Node => null,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Key_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Keys);
+
+
+ function Find (Container : Set;
+ Key : Key_Type)
+ return Cursor is
+
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container, Key);
+
+ begin
+
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+
+ end Find;
+
+
+ function Contains (Container : Set;
+ Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+
+ function Element (Container : Set;
+ Key : Key_Type)
+ return Element_Type is
+
+ Node : constant Node_Access := Key_Keys.Find (Container, Key);
+ begin
+ return Node.Element.all;
+ end Element;
+
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Key (Position.Node.Element.all);
+ end Key;
+
+
+-- TODO:
+-- procedure Replace (Container : in out Set;
+-- Key : in Key_Type;
+-- New_Item : in Element_Type) is
+
+-- Node : constant Node_Access :=
+-- Key_Keys.Find (Container, Key);
+
+-- begin
+
+-- if Node = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- Replace_Element (Container, Node, New_Item);
+
+-- end Replace;
+
+
+ procedure Delete (Container : in out Set;
+ Key : in Key_Type) is
+
+ X : Node_Access;
+
+ begin
+
+ Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Free (X);
+
+ end Delete;
+
+
+ procedure Exclude (Container : in out Set;
+ Key : in Key_Type) is
+
+ X : Node_Access;
+
+ begin
+
+ Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+ Free (X);
+
+ end Exclude;
+
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : in Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type)) is
+
+ begin
+
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ declare
+ Old_Key : Key_Type renames Key (Position.Node.Element.all);
+ begin
+ Process (Position.Node.Element.all);
+
+ if Equivalent_Keys (Old_Key, Position.Node.Element.all) then
+ return;
+ end if;
+ end;
+
+ declare
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ begin
+ Position.Node.Next := Next;
+ return Position.Node;
+ end New_Node;
+
+ procedure Insert is
+ new Key_Keys.Generic_Conditional_Insert (New_Node);
+
+ Result : Node_Access;
+ Success : Boolean;
+ begin
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+
+ Insert
+ (HT => Container,
+ Key => Key (Position.Node.Element.all),
+ Node => Result,
+ Success => Success);
+
+ if not Success then
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ Free (X);
+ end;
+
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Result = Position.Node);
+ end;
+
+ end Checked_Update_Element;
+
+ end Generic_Keys;
+
+end Ada.Containers.Indefinite_Hashed_Sets;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Hash_Tables;
+with Ada.Streams;
+
+generic
+ type Element_Type (<>) is private;
+
+ with function Hash (Element : Element_Type) return Hash_Type;
+
+ -- TODO: get a ruling from ARG in Atlanta re the name and
+ -- order of these declarations ???
+
+ with function Equivalent_Keys (Left, Right : Element_Type) return Boolean;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Hashed_Sets is
+
+ pragma Preelaborate (Indefinite_Hashed_Sets);
+
+ type Set is tagged private;
+
+ type Cursor is private;
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+-- TODO: resolve in atlanta ???
+-- procedure Replace_Element (Container : in out Set;
+-- Position : Cursor;
+-- By : Element_Type);
+
+ procedure Move
+ (Target : in out Set;
+ Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert (Container : in out Set; New_Item : Element_Type);
+
+ procedure Include (Container : in out Set; New_Item : Element_Type);
+
+ procedure Replace (Container : in out Set; New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Item : Element_Type);
+
+ procedure Exclude (Container : in out Set; Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Position : in out Cursor);
+
+ procedure Union (Target : in out Set; Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set; Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set
+ renames Symmetric_Difference;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Find (Container : Set; Item : Element_Type) return Cursor;
+
+ function Capacity (Container : Set) return Count_Type;
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : Count_Type);
+
+ function First (Container : Set) return Cursor;
+
+ function Next (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function Equivalent_Keys (Left, Right : Cursor) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Cursor;
+ Right : Element_Type) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Element_Type;
+ Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ generic
+ type Key_Type (<>) is limited private;
+
+ with function Key (Element : Element_Type) return Key_Type;
+
+ with function Hash (Key : Key_Type) return Hash_Type;
+
+ with function Equivalent_Keys
+ (Key : Key_Type;
+ Element : Element_Type) return Boolean;
+
+ package Generic_Keys is
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+
+-- TODO: resolve in atlanta???
+-- procedure Replace (Container : in out Set;
+-- Key : Key_Type;
+-- New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ function Equivalent_Keys
+ (Left : Cursor;
+ Right : Key_Type) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Cursor) return Boolean;
+ end Generic_Keys;
+
+private
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package HT_Types is
+ new Hash_Tables.Generic_Hash_Table_Types (Node_Access);
+
+ use HT_Types;
+
+ type Set is new Hash_Table_Type with null record;
+
+ procedure Adjust (Container : in out Set);
+
+ procedure Finalize (Container : in out Set);
+
+ type Set_Access is access constant Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Cursor is
+ record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor :=
+ (Container => null,
+ Node => null);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set := (Hash_Table_Type with null record);
+
+end Ada.Containers.Indefinite_Hashed_Sets;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Ada.Containers.Red_Black_Trees.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
+
+with Ada.Containers.Red_Black_Trees.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
+
+with System; use type System.Address;
+
+package body Ada.Containers.Indefinite_Ordered_Maps is
+
+ use Red_Black_Trees;
+
+ type Key_Access is access Key_Type;
+ type Element_Access is access Element_Type;
+
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red;
+ Key : Key_Access;
+ Element : Element_Access;
+ end record;
+
+ -----------------------------
+ -- Node Access Subprograms --
+ -----------------------------
+
+ -- These subprograms provide a functional interface to access fields
+ -- of a node, and a procedural interface for modifying these values.
+
+ function Color (Node : Node_Access) return Color_Type;
+ pragma Inline (Color);
+
+ function Left (Node : Node_Access) return Node_Access;
+ pragma Inline (Left);
+
+ function Parent (Node : Node_Access) return Node_Access;
+ pragma Inline (Parent);
+
+ function Right (Node : Node_Access) return Node_Access;
+ pragma Inline (Right);
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
+ pragma Inline (Set_Parent);
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access);
+ pragma Inline (Set_Left);
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access);
+ pragma Inline (Set_Right);
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type);
+ pragma Inline (Set_Color);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access;
+
+ procedure Delete_Tree (X : in out Node_Access);
+
+ procedure Free (X : in out Node_Access);
+
+ function Is_Equal_Node_Node
+ (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equal_Node_Node);
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Key_Node);
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Key_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Tree_Operations is
+ new Red_Black_Trees.Generic_Operations
+ (Tree_Types => Tree_Types,
+ Null_Node => Node_Access'(null));
+
+ use Tree_Operations;
+
+ package Key_Ops is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Key_Type,
+ Is_Less_Key_Node => Is_Less_Key_Node,
+ Is_Greater_Key_Node => Is_Greater_Key_Node);
+
+ procedure Free_Key is
+ new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
+
+ procedure Free_Element is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ function Is_Equal is
+ new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Cursor) return Boolean is
+ begin
+ return Left.Node.Key.all < Right.Node.Key.all;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Left.Node.Key.all < Right;
+ end "<";
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Key.all;
+ end "<";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Map) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ return Is_Equal (Left.Tree, Right.Tree);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Cursor) return Boolean is
+ begin
+ return Right.Node.Key.all < Left.Node.Key.all;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right < Left.Node.Key.all;
+ end ">";
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Right.Node.Key.all < Left;
+ end ">";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Map) is
+ Tree : Tree_Type renames Container.Tree;
+
+ N : constant Count_Type := Tree.Length;
+ X : constant Node_Access := Tree.Root;
+
+ begin
+ if N = 0 then
+ pragma Assert (X = null);
+ return;
+ end if;
+
+ Tree := (Length => 0, others => null);
+
+ Tree.Root := Copy_Tree (X);
+ Tree.First := Min (Tree.Root);
+ Tree.Last := Max (Tree.Root);
+ Tree.Length := N;
+ end Adjust;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
+ begin
+ if Node = null then
+ return No_Element;
+ else
+ return Cursor'(Container'Unchecked_Access, Node);
+ end if;
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Map) is
+ Tree : Tree_Type renames Container.Tree;
+ Root : Node_Access := Tree.Root;
+ begin
+ Tree := (Length => 0, others => null);
+ Delete_Tree (Root);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Access) return Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access is
+ Target : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Source.Color,
+ Key => Source.Key,
+ Element => Source.Element);
+ begin
+ return Target;
+ end Copy_Node;
+
+ ---------------
+ -- Copy_Tree --
+ ---------------
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access is
+ Target_Root : Node_Access := Copy_Node (Source_Root);
+
+ P, X : Node_Access;
+
+ begin
+ if Source_Root.Right /= null then
+ Target_Root.Right := Copy_Tree (Source_Root.Right);
+ Target_Root.Right.Parent := Target_Root;
+ end if;
+
+ P := Target_Root;
+ X := Source_Root.Left;
+ while X /= null loop
+ declare
+ Y : Node_Access := Copy_Node (X);
+
+ begin
+ P.Left := Y;
+ Y.Parent := P;
+
+ if X.Right /= null then
+ Y.Right := Copy_Tree (X.Right);
+ Y.Right.Parent := Y;
+ end if;
+
+ P := Y;
+ X := X.Left;
+ end;
+ end loop;
+
+ return Target_Root;
+
+ exception
+ when others =>
+ Delete_Tree (Target_Root);
+ raise;
+ end Copy_Tree;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out Map;
+ Position : in out Cursor)
+ is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Map_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+ end Delete;
+
+ procedure Delete (Container : in out Map; Key : Key_Type) is
+ X : Node_Access := Key_Ops.Find (Container.Tree, Key);
+ begin
+ if X = null then
+ raise Constraint_Error;
+ else
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Map) is
+ Position : Cursor := First (Container);
+ begin
+ Delete (Container, Position);
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Map) is
+ Position : Cursor := Last (Container);
+ begin
+ Delete (Container, Position);
+ end Delete_Last;
+
+ -----------------
+ -- Delete_Tree --
+ -----------------
+
+ procedure Delete_Tree (X : in out Node_Access) is
+ Y : Node_Access;
+ begin
+ while X /= null loop
+ Y := X.Right;
+ Delete_Tree (Y);
+ Y := X.Left;
+ Free (X);
+ X := Y;
+ end loop;
+ end Delete_Tree;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element.all;
+ end Element;
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type is
+ Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
+ begin
+ return Node.Element.all;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Map; Key : Key_Type) is
+ X : Node_Access := Key_Ops.Find (Container.Tree, Key);
+
+ begin
+ if X /= null then
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
+ begin
+ if Node = null then
+ return No_Element;
+ else
+ return Cursor'(Container'Unchecked_Access, Node);
+ end if;
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Map) return Cursor is
+ begin
+ if Container.Tree.First = null then
+ return No_Element;
+ else
+ return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ end if;
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Map) return Element_Type is
+ begin
+ return Container.Tree.First.Element.all;
+ end First_Element;
+
+ ---------------
+ -- First_Key --
+ ---------------
+
+ function First_Key (Container : Map) return Key_Type is
+ begin
+ return Container.Tree.First.Key.all;
+ end First_Key;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
+ begin
+ if Node = null then
+ return No_Element;
+ else
+ return Cursor'(Container'Unchecked_Access, Node);
+ end if;
+ end Floor;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ begin
+ if X /= null then
+ Free_Key (X.Key);
+ Free_Element (X.Element);
+ Deallocate (X);
+ end if;
+ end Free;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ K : Key_Access;
+ E : Element_Access;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ K := Position.Node.Key;
+ E := Position.Node.Element;
+
+ Position.Node.Key := new Key_Type'(Key);
+ Position.Node.Element := new Element_Type'(New_Item);
+
+ Free_Key (K);
+ Free_Element (E);
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Ops.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Key_Ops.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ Node.Key := new Key_Type'(Key);
+ Node.Element := new Element_Type'(New_Item);
+ return Node;
+
+ exception
+ when others =>
+
+ -- On exception, deallocate key and elem
+
+ Free (Node);
+ raise;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container.Tree,
+ Key,
+ Position.Node,
+ Inserted);
+
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+ end Insert;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Map) return Boolean is
+ begin
+ return Container.Tree.Length = 0;
+ end Is_Empty;
+
+ ------------------------
+ -- Is_Equal_Node_Node --
+ ------------------------
+
+ function Is_Equal_Node_Node
+ (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element.all = R.Element.all;
+ end Is_Equal_Node_Node;
+
+ -------------------------
+ -- Is_Greater_Key_Node --
+ -------------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ -- k > node same as node < k
+
+ return Right.Key.all < Left;
+ end Is_Greater_Key_Node;
+
+ ----------------------
+ -- Is_Less_Key_Node --
+ ----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ return Left < Right.Key.all;
+ end Is_Less_Key_Node;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree);
+ end Iterate;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Position.Node.Key.all;
+ end Key;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Map) return Cursor is
+ begin
+ if Container.Tree.Last = null then
+ return No_Element;
+ else
+ return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ end if;
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Map) return Element_Type is
+ begin
+ return Container.Tree.Last.Element.all;
+ end Last_Element;
+
+ --------------
+ -- Last_Key --
+ --------------
+
+ function Last_Key (Container : Map) return Key_Type is
+ begin
+ return Container.Tree.Last.Key.all;
+ end Last_Key;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Left;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Map) return Count_Type is
+ begin
+ return Container.Tree.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Map; Source : in out Map) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Move (Target => Target.Tree, Source => Source.Tree);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access := Tree_Operations.Next (Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ else
+ return Cursor'(Position.Container, Node);
+ end if;
+ end;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Parent;
+ end Parent;
+
+ --------------
+ -- Previous --
+ --------------
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Previous (Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Previous;
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ Position := Previous (Position);
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ Process (Position.Node.Key.all, Position.Node.Element.all);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Map)
+ is
+ N : Count_Type'Base;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ Node.Key := new Key_Type'(Key_Type'Input (Stream));
+ Node.Element := new Element_Type'(Element_Type'Input (Stream));
+ return Node;
+
+ exception
+ when others =>
+
+ -- Deallocate key and elem too on exception
+
+ Free (Node);
+ raise;
+ end New_Node;
+
+ -- Start of processing for Read
+
+ begin
+ Clear (Container);
+
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+
+ Local_Read (Container.Tree, N);
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access :=
+ Key_Ops.Find (Container.Tree, Key);
+
+ K : Key_Access;
+ E : Element_Access;
+
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
+ K := Node.Key;
+ E := Node.Element;
+
+ Node.Key := new Key_Type'(Key);
+ Node.Element := new Element_Type'(New_Item);
+
+ Free_Key (K);
+ Free_Element (E);
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ X : Element_Access := Position.Node.Element;
+ begin
+ Position.Node.Element := new Element_Type'(By);
+ Free_Element (X);
+ end Replace_Element;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree);
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Right;
+ end Right;
+
+ ---------------
+ -- Set_Color --
+ ---------------
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type) is
+ begin
+ Node.Color := Color;
+ end Set_Color;
+
+ --------------
+ -- Set_Left --
+ --------------
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access) is
+ begin
+ Node.Left := Left;
+ end Set_Left;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
+ begin
+ Node.Parent := Parent;
+ end Set_Parent;
+
+ ---------------
+ -- Set_Right --
+ ---------------
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access) is
+ begin
+ Node.Right := Right;
+ end Set_Right;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ Process (Position.Node.Key.all, Position.Node.Element.all);
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Map)
+ is
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is
+ new Tree_Operations.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Key_Type'Output (Stream, Node.Key.all);
+ Element_Type'Output (Stream, Node.Element.all);
+ end Process;
+
+ -- Start of processing for Write
+
+ begin
+ Count_Type'Base'Write (Stream, Container.Tree.Length);
+ Iterate (Container.Tree);
+ end Write;
+
+end Ada.Containers.Indefinite_Ordered_Maps;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees;
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+
+ type Key_Type (<>) is private;
+
+ type Element_Type (<>) is private;
+
+ with function "<" (Left, Right : Key_Type) return Boolean is <>;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Ordered_Maps is
+pragma Preelaborate (Indefinite_Ordered_Maps);
+
+ type Map is tagged private;
+
+ type Cursor is private;
+
+ Empty_Map : constant Map;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Map) return Boolean;
+
+ function Length (Container : Map) return Count_Type;
+
+ function Is_Empty (Container : Map) return Boolean;
+
+ procedure Clear (Container : in out Map);
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : Element_Type));
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type));
+
+ procedure Replace_Element (Position : Cursor; By : Element_Type);
+
+ procedure Move (Target : in out Map; Source : in out Map);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Map;
+ Key : Key_Type);
+
+ procedure Exclude
+ (Container : in out Map;
+ Key : Key_Type);
+
+ procedure Delete
+ (Container : in out Map;
+ Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Map);
+
+ procedure Delete_Last (Container : in out Map);
+
+ function Contains
+ (Container : Map;
+ Key : Key_Type) return Boolean;
+
+ function Find
+ (Container : Map;
+ Key : Key_Type) return Cursor;
+
+ function Element
+ (Container : Map;
+ Key : Key_Type) return Element_Type;
+
+ function Floor
+ (Container : Map;
+ Key : Key_Type) return Cursor;
+
+ function Ceiling
+ (Container : Map;
+ Key : Key_Type) return Cursor;
+
+ function First (Container : Map) return Cursor;
+
+ function First_Key (Container : Map) return Key_Type;
+
+ function First_Element (Container : Map) return Element_Type;
+
+ function Last (Container : Map) return Cursor;
+
+ function Last_Key (Container : Map) return Key_Type;
+
+ function Last_Element (Container : Map) return Element_Type;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function "<" (Left, Right : Cursor) return Boolean;
+
+ function ">" (Left, Right : Cursor) return Boolean;
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+
+private
+
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Map is new Controlled with record
+ Tree : Tree_Type := (Length => 0, others => null);
+ end record;
+
+ procedure Adjust (Container : in out Map);
+
+ procedure Finalize (Container : in out Map) renames Clear;
+
+ type Map_Access is access constant Map;
+ for Map_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Map_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, null);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Map);
+
+ for Map'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Map);
+
+ for Map'Read use Read;
+
+ Empty_Map : constant Map :=
+ (Controlled with Tree => (Length => 0, others => null));
+
+end Ada.Containers.Indefinite_Ordered_Maps;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Ada.Containers.Red_Black_Trees.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
+
+with Ada.Containers.Red_Black_Trees.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
+
+with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
+
+with System; use type System.Address;
+
+package body Ada.Containers.Indefinite_Ordered_Multisets is
+
+ use Red_Black_Trees;
+
+ type Element_Access is access Element_Type;
+
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red;
+ Element : Element_Access;
+ end record;
+
+ -----------------------------
+ -- Node Access Subprograms --
+ -----------------------------
+
+ -- These subprograms provide a functional interface to access fields
+ -- of a node, and a procedural interface for modifying these values.
+
+ function Color (Node : Node_Access) return Color_Type;
+ pragma Inline (Color);
+
+ function Left (Node : Node_Access) return Node_Access;
+ pragma Inline (Left);
+
+ function Parent (Node : Node_Access) return Node_Access;
+ pragma Inline (Parent);
+
+ function Right (Node : Node_Access) return Node_Access;
+ pragma Inline (Right);
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
+ pragma Inline (Set_Parent);
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access);
+ pragma Inline (Set_Left);
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access);
+ pragma Inline (Set_Right);
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type);
+ pragma Inline (Set_Color);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access;
+
+ procedure Delete_Tree (X : in out Node_Access);
+
+ procedure Free (X : in out Node_Access);
+
+ procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access);
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equal_Node_Node);
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Element_Node);
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Element_Node);
+
+ function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Node_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Tree_Operations is
+ new Red_Black_Trees.Generic_Operations
+ (Tree_Types => Tree_Types,
+ Null_Node => Node_Access'(null));
+
+ use Tree_Operations;
+
+ procedure Free_Element is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ function Is_Equal is
+ new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
+
+ package Set_Ops is
+ new Generic_Set_Operations
+ (Tree_Operations => Tree_Operations,
+ Insert_With_Hint => Insert_With_Hint,
+ Copy_Tree => Copy_Tree,
+ Delete_Tree => Delete_Tree,
+ Is_Less => Is_Less_Node_Node,
+ Free => Free);
+
+ package Element_Keys is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Element_Type,
+ Is_Less_Key_Node => Is_Less_Element_Node,
+ Is_Greater_Key_Node => Is_Greater_Element_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Cursor) return Boolean is
+ begin
+ return Left.Node.Element.all < Right.Node.Element.all;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean is
+ begin
+ return Left.Node.Element.all < Right;
+ end "<";
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Element.all;
+ end "<";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Set) return Boolean is begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ return Is_Equal (Left.Tree, Right.Tree);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean is
+ begin
+ return Right < Left.Node.Element.all;
+ end ">";
+
+ function ">" (Left, Right : Cursor) return Boolean is
+ begin
+ -- L > R same as R < L
+
+ return Right.Node.Element.all < Left.Node.Element.all;
+ end ">";
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean is
+ begin
+ return Right.Node.Element.all < Left;
+ end ">";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+
+ N : constant Count_Type := Tree.Length;
+ X : constant Node_Access := Tree.Root;
+
+ begin
+ if N = 0 then
+ pragma Assert (X = null);
+ return;
+ end if;
+
+ Tree := (Length => 0, others => null);
+
+ Tree.Root := Copy_Tree (X);
+ Tree.First := Min (Tree.Root);
+ Tree.Last := Max (Tree.Root);
+ Tree.Length := N;
+ end Adjust;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Ceiling (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+ Root : Node_Access := Tree.Root;
+ begin
+ Tree := (Length => 0, others => null);
+ Delete_Tree (Root);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Access) return Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access is
+ X : Element_Access := new Element_Type'(Source.Element.all);
+
+ begin
+ return new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Source.Color,
+ Element => X);
+
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end Copy_Node;
+
+ ---------------
+ -- Copy_Tree --
+ ---------------
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access is
+ Target_Root : Node_Access := Copy_Node (Source_Root);
+
+ P, X : Node_Access;
+
+ begin
+ if Source_Root.Right /= null then
+ Target_Root.Right := Copy_Tree (Source_Root.Right);
+ Target_Root.Right.Parent := Target_Root;
+ end if;
+
+ P := Target_Root;
+ X := Source_Root.Left;
+ while X /= null loop
+ declare
+ Y : Node_Access := Copy_Node (X);
+
+ begin
+ P.Left := Y;
+ Y.Parent := P;
+
+ if X.Right /= null then
+ Y.Right := Copy_Tree (X.Right);
+ Y.Right.Parent := Y;
+ end if;
+
+ P := Y;
+ X := X.Left;
+ end;
+ end loop;
+
+ return Target_Root;
+
+ exception
+ when others =>
+ Delete_Tree (Target_Root);
+ raise;
+ end Copy_Tree;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Item : Element_Type) is
+ Tree : Tree_Type renames Container.Tree;
+ Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
+ Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
+ X : Node_Access;
+
+ begin
+ if Node = Done then
+ raise Constraint_Error;
+ end if;
+
+ loop
+ X := Node;
+ Node := Tree_Operations.Next (Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+
+ exit when Node = Done;
+ end loop;
+ end Delete;
+
+ procedure Delete (Container : in out Set; Position : in out Cursor) is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+ X : Node_Access := Tree.First;
+
+ begin
+ if X = null then
+ return;
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+ X : Node_Access := Tree.Last;
+
+ begin
+ if X = null then
+ return;
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end Delete_Last;
+
+ -----------------
+ -- Delete_Tree --
+ -----------------
+
+ procedure Delete_Tree (X : in out Node_Access) is
+ Y : Node_Access;
+ begin
+ while X /= null loop
+ Y := X.Right;
+ Delete_Tree (Y);
+ Y := X.Left;
+ Free (X);
+ X := Y;
+ end loop;
+ end Delete_Tree;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ Set_Ops.Difference (Target.Tree, Source.Tree);
+ end Difference;
+
+ function Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Difference (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Difference;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element.all;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Item : Element_Type) is
+ Tree : Tree_Type renames Container.Tree;
+ Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
+ Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
+ X : Node_Access;
+ begin
+ while Node /= Done loop
+ X := Node;
+ Node := Tree_Operations.Next (Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end loop;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ begin
+ if Container.Tree.First = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Set) return Element_Type is
+ begin
+ return Container.Tree.First.Element.all;
+ end First_Element;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Floor (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ begin
+ if X /= null then
+ Free_Element (X.Element);
+ Deallocate (X);
+ end if;
+ end Free;
+
+ ------------------
+ -- Generic_Keys --
+ ------------------
+
+ package body Generic_Keys is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Key_Node);
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Key_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Key_Keys is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Key_Type,
+ Is_Less_Key_Node => Is_Less_Key_Node,
+ Is_Greater_Key_Node => Is_Greater_Key_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Element.all;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right > Left.Node.Element.all;
+ end "<";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left > Right.Node.Element.all;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right < Left.Node.Element.all;
+ end ">";
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access :=
+ Key_Keys.Ceiling (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ ----------------------------
+ -- Checked_Update_Element --
+ ----------------------------
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ declare
+ Old_Key : Key_Type renames Key (Position.Node.Element.all);
+
+ begin
+ Process (Position.Node.Element.all);
+
+ if Old_Key < Position.Node.Element.all
+ or else Old_Key > Position.Node.Element.all
+ then
+ null;
+ else
+ return;
+ end if;
+ end;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+
+ Do_Insert : declare
+ Result : Node_Access;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert is
+ new Key_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ return Position.Node;
+ end New_Node;
+
+ -- Start of processing for Do_Insert
+
+ begin
+ Insert
+ (Tree => Container.Tree,
+ Key => Key (Position.Node.Element.all),
+ Node => Result);
+
+ pragma Assert (Result = Position.Node);
+ end Do_Insert;
+ end Checked_Update_Element;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Key : Key_Type) is
+ Tree : Tree_Type renames Container.Tree;
+ Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
+ Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
+ X : Node_Access;
+
+ begin
+ if Node = Done then
+ raise Constraint_Error;
+ end if;
+
+ loop
+ X := Node;
+ Node := Tree_Operations.Next (Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+
+ exit when Node = Done;
+ end loop;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type is
+ Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
+ begin
+ return Node.Element.all;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Key : Key_Type) is
+ Tree : Tree_Type renames Container.Tree;
+ Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
+ Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
+ X : Node_Access;
+
+ begin
+ while Node /= Done loop
+ X := Node;
+ Node := Tree_Operations.Next (Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end loop;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ -------------------------
+ -- Is_Greater_Key_Node --
+ -------------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ return Left > Right.Element.all;
+ end Is_Greater_Key_Node;
+
+ ----------------------
+ -- Is_Less_Key_Node --
+ ----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ return Left < Right.Element.all;
+ end Is_Less_Key_Node;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Key : Key_Type;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Key_Keys.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree, Key);
+ end Iterate;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Key (Position.Node.Element.all);
+ end Key;
+
+ -------------
+ -- Replace --
+ -------------
+
+ -- In post-madision api: ???
+
+-- procedure Replace
+-- (Container : in out Set;
+-- Key : Key_Type;
+-- New_Item : Element_Type)
+-- is
+-- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+-- begin
+-- if Node = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- Replace_Node (Container, Node, New_Item);
+-- end Replace;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Key : Key_Type;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Local_Reverse_Iterate is
+ new Key_Keys.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree, Key);
+ end Reverse_Iterate;
+
+ end Generic_Keys;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert (Container : in out Set; New_Item : Element_Type) is
+ Position : Cursor;
+ begin
+ Insert (Container, New_Item, Position);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Unconditional_Insert_Sans_Hint is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ X : Element_Access := new Element_Type'(New_Item);
+
+ begin
+ return new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Red,
+ Element => X);
+
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Unconditional_Insert_Sans_Hint
+ (Container.Tree,
+ New_Item,
+ Position.Node);
+
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ ----------------------
+ -- Insert_With_Hint --
+ ----------------------
+
+ procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ procedure Local_Insert_With_Hint is
+ new Element_Keys.Generic_Unconditional_Insert_With_Hint
+ (Insert_Post,
+ Insert_Sans_Hint);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ X : Element_Access := new Element_Type'(Src_Node.Element.all);
+
+ begin
+ return new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Red,
+ Element => X);
+
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end New_Node;
+
+ -- Start of processing for Insert_With_Hint
+
+ begin
+ Local_Insert_With_Hint
+ (Dst_Tree,
+ Dst_Hint,
+ Src_Node.Element.all,
+ Dst_Node);
+ end Insert_With_Hint;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Intersection (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Set_Ops.Intersection (Target.Tree, Source.Tree);
+ end Intersection;
+
+ function Intersection (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Intersection (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Intersection;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.Tree.Length = 0;
+ end Is_Empty;
+
+ ------------------------
+ -- Is_Equal_Node_Node --
+ ------------------------
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element.all = R.Element.all;
+ end Is_Equal_Node_Node;
+
+ -----------------------------
+ -- Is_Greater_Element_Node --
+ -----------------------------
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ -- e > node same as node < e
+
+ return Right.Element.all < Left;
+ end Is_Greater_Element_Node;
+
+ --------------------------
+ -- Is_Less_Element_Node --
+ --------------------------
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ return Left < Right.Element.all;
+ end Is_Less_Element_Node;
+
+ -----------------------
+ -- Is_Less_Node_Node --
+ -----------------------
+
+ function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element.all < R.Element.all;
+ end Is_Less_Node_Node;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
+ begin
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
+ end Is_Subset;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Item : Element_Type;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Element_Keys.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree, Item);
+ end Iterate;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree);
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Set) return Cursor is
+ begin
+ if Container.Tree.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Set) return Element_Type is
+ begin
+ return Container.Tree.Last.Element.all;
+ end Last_Element;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Left;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.Tree.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Move (Target => Target.Tree, Source => Source.Tree);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Next (Position.Node);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Set) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return Left.Tree.Length /= 0;
+ end if;
+
+ return Set_Ops.Overlap (Left.Tree, Right.Tree);
+ end Overlap;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Parent;
+ end Parent;
+
+ --------------
+ -- Previous --
+ --------------
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Previous (Position.Node);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Previous;
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ Position := Previous (Position);
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ Process (Position.Node.Element.all);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ N : Count_Type'Base;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ begin
+ Node.Element := new Element_Type'(Element_Type'Input (Stream));
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end;
+
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Read
+
+ begin
+ Clear (Container);
+
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+
+ Local_Read (Container.Tree, N);
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ -- NOTE: from post-madison api???
+
+-- procedure Replace
+-- (Container : in out Set;
+-- Position : Cursor;
+-- By : Element_Type)
+-- is
+-- begin
+-- if Position.Container = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+-- raise Program_Error;
+-- end if;
+
+-- Replace_Node (Container, Position.Node, By);
+-- end Replace;
+
+ ------------------
+ -- Replace_Node --
+ ------------------
+
+ -- NOTE: from post-madison api???
+
+-- procedure Replace_Node
+-- (Container : in out Set;
+-- Position : Node_Access;
+-- By : Element_Type);
+-- is
+-- Tree : Tree_Type renames Container.Tree;
+-- Node : Node_Access := Position;
+
+-- begin
+-- if By < Node.Element
+-- or else Node.Element < By
+-- then
+-- null;
+
+-- else
+-- begin
+-- Node.Element := By;
+
+-- exception
+-- when others =>
+-- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
+-- Free (Node);
+-- raise;
+-- end;
+
+-- return;
+-- end if;
+
+-- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
+
+-- begin
+-- Node.Element := By;
+
+-- exception
+-- when others =>
+-- Free (Node);
+-- raise;
+-- end;
+
+-- declare
+-- Result : Node_Access;
+-- Success : Boolean;
+
+-- function New_Node return Node_Access;
+-- pragma Inline (New_Node);
+
+-- procedure Insert_Post is
+-- new Element_Keys.Generic_Insert_Post (New_Node);
+
+-- procedure Insert is
+-- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+-- --------------
+-- -- New_Node --
+-- --------------
+--
+-- function New_Node return Node_Access is
+-- begin
+-- return Node;
+-- end New_Node;
+
+-- -- Start of processing for Replace_Node
+
+-- begin
+-- Insert
+-- (Tree => Tree,
+-- Key => Node.Element,
+-- Node => Result,
+-- Success => Success);
+
+-- if not Success then
+-- Free (Node);
+-- raise Program_Error;
+-- end if;
+
+-- pragma Assert (Result = Node);
+-- end;
+-- end Replace_Node;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Item : Element_Type;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Element_Keys.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree, Item);
+ end Reverse_Iterate;
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree);
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Right;
+ end Right;
+
+ ---------------
+ -- Set_Color --
+ ---------------
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type) is
+ begin
+ Node.Color := Color;
+ end Set_Color;
+
+ --------------
+ -- Set_Left --
+ --------------
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access) is
+ begin
+ Node.Left := Left;
+ end Set_Left;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
+ begin
+ Node.Parent := Parent;
+ end Set_Parent;
+
+ ---------------
+ -- Set_Right --
+ ---------------
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access) is
+ begin
+ Node.Right := Right;
+ end Set_Right;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
+ end Symmetric_Difference;
+
+ function Symmetric_Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Symmetric_Difference;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Set_Ops.Union (Target.Tree, Source.Tree);
+ end Union;
+
+ function Union (Left, Right : Set) return Set is begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ declare
+ Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Union;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Set)
+ is
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Element_Type'Output (Stream, Node.Element.all);
+ end Process;
+
+ -- Start of processing for Write
+
+ begin
+ Count_Type'Base'Write (Stream, Container.Tree.Length);
+ Iterate (Container.Tree);
+ end Write;
+
+end Ada.Containers.Indefinite_Ordered_Multisets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees;
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+ type Element_Type (<>) is private;
+
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Ordered_Multisets is
+pragma Preelaborate (Indefinite_Ordered_Multisets);
+
+ type Set is tagged private;
+
+ type Cursor is private;
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Move (Target : in out Set; Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor);
+
+ procedure Insert (Container : in out Set; New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Item : Element_Type);
+
+ procedure Exclude (Container : in out Set; Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Set);
+
+ procedure Delete_Last (Container : in out Set);
+
+
+ -- NOTE: The following operation is named Replace in the Madison API.
+ -- However, it should be named Replace_Element ???
+ --
+ -- procedure Replace
+ -- (Container : in out Set;
+ -- Position : Cursor;
+ -- By : Element_Type);
+
+ procedure Union (Target : in out Set;
+ Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set; Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Find (Container : Set; Item : Element_Type) return Cursor;
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor;
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor;
+
+ function First (Container : Set) return Cursor;
+
+ function First_Element (Container : Set) return Element_Type;
+
+ function Last (Container : Set) return Cursor;
+
+ function Last_Element (Container : Set) return Element_Type;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function "<" (Left, Right : Cursor) return Boolean;
+
+ function ">" (Left, Right : Cursor) return Boolean;
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Iterate
+ (Container : Set;
+ Item : Element_Type;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Item : Element_Type;
+ Process : not null access procedure (Position : Cursor));
+
+ generic
+
+ type Key_Type (<>) is limited private;
+
+ with function Key (Element : Element_Type) return Key_Type;
+
+ with function "<" (Left : Key_Type; Right : Element_Type)
+ return Boolean is <>;
+
+ with function ">" (Left : Key_Type; Right : Element_Type)
+ return Boolean is <>;
+
+ package Generic_Keys is
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor;
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+
+ -- NOTE: in post-madison api ???
+ -- procedure Replace
+ -- (Container : in out Set;
+ -- Key : Key_Type;
+ -- New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ procedure Iterate
+ (Container : Set;
+ Key : Key_Type;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Key : Key_Type;
+ Process : not null access procedure (Position : Cursor));
+
+ end Generic_Keys;
+
+private
+
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Set is new Controlled with record
+ Tree : Tree_Type := (Length => 0, others => null);
+ end record;
+
+ procedure Adjust (Container : in out Set);
+
+ procedure Finalize (Container : in out Set) renames Clear;
+
+ type Set_Access is access constant Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, null);
+
+ use Ada.Streams;
+
+ procedure Write (Stream : access Root_Stream_Type'Class; Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set :=
+ (Controlled with Tree => (Length => 0, others => null));
+
+end Ada.Containers.Indefinite_Ordered_Multisets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
+
+with Ada.Containers.Red_Black_Trees.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
+
+with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
+
+with Ada.Unchecked_Deallocation;
+
+with System; use type System.Address;
+
+package body Ada.Containers.Indefinite_Ordered_Sets is
+
+ type Element_Access is access Element_Type;
+
+ use Red_Black_Trees;
+
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red;
+ Element : Element_Access;
+ end record;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Color (Node : Node_Access) return Color_Type;
+ pragma Inline (Color);
+
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access;
+
+ procedure Delete_Tree (X : in out Node_Access);
+
+ procedure Free (X : in out Node_Access);
+
+ procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access);
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Element_Node);
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Element_Node);
+
+ function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Node_Node);
+
+ function Left (Node : Node_Access) return Node_Access;
+ pragma Inline (Left);
+
+ function Parent (Node : Node_Access) return Node_Access;
+ pragma Inline (Parent);
+
+ function Right (Node : Node_Access) return Node_Access;
+ pragma Inline (Right);
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type);
+ pragma Inline (Set_Color);
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access);
+ pragma Inline (Set_Left);
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
+ pragma Inline (Set_Parent);
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access);
+ pragma Inline (Set_Right);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ procedure Free_Element is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ package Tree_Operations is
+ new Red_Black_Trees.Generic_Operations
+ (Tree_Types => Tree_Types,
+ Null_Node => Node_Access'(null));
+
+ use Tree_Operations;
+
+ package Element_Keys is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Element_Type,
+ Is_Less_Key_Node => Is_Less_Element_Node,
+ Is_Greater_Key_Node => Is_Greater_Element_Node);
+
+ package Set_Ops is
+ new Generic_Set_Operations
+ (Tree_Operations => Tree_Operations,
+ Insert_With_Hint => Insert_With_Hint,
+ Copy_Tree => Copy_Tree,
+ Delete_Tree => Delete_Tree,
+ Is_Less => Is_Less_Node_Node,
+ Free => Free);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Cursor) return Boolean is
+ begin
+ return Left.Node.Element.all < Right.Node.Element.all;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean is
+ begin
+ return Left.Node.Element.all < Right;
+ end "<";
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Element.all;
+ end "<";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Set) return Boolean is
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equal_Node_Node);
+
+ function Is_Equal is
+ new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
+
+ ------------------------
+ -- Is_Equal_Node_Node --
+ ------------------------
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element.all = R.Element.all;
+ end Is_Equal_Node_Node;
+
+ -- Start of processing for "="
+
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ return Is_Equal (Left.Tree, Right.Tree);
+ end "=";
+
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Cursor) return Boolean is
+ begin
+ -- L > R same as R < L
+
+ return Right.Node.Element.all < Left.Node.Element.all;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean is
+ begin
+ return Right < Left.Node.Element.all;
+ end ">";
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean is
+ begin
+ return Right.Node.Element.all < Left;
+ end ">";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+
+ begin
+ if Tree.Length = 0 then
+ pragma Assert (Tree.Root = null);
+ return;
+ end if;
+
+ begin
+ Tree.Root := Copy_Tree (Tree.Root);
+ exception
+ when others =>
+ Tree := (Length => 0, others => null);
+ raise;
+ end;
+
+ Tree.First := Min (Tree.Root);
+ Tree.Last := Max (Tree.Root);
+ end Adjust;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Ceiling (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+ Root : Node_Access := Tree.Root;
+ begin
+ Tree := (Length => 0, others => null);
+ Delete_Tree (Root);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Access) return Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access is
+ Element : Element_Access := new Element_Type'(Source.Element.all);
+ begin
+ return new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Source.Color,
+ Element => Element);
+ exception
+ when others =>
+ Free_Element (Element);
+ raise;
+ end Copy_Node;
+
+ ---------------
+ -- Copy_Tree --
+ ---------------
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access is
+ Target_Root : Node_Access := Copy_Node (Source_Root);
+ P, X : Node_Access;
+
+ begin
+ if Source_Root.Right /= null then
+ Target_Root.Right := Copy_Tree (Source_Root.Right);
+ Target_Root.Right.Parent := Target_Root;
+ end if;
+
+ P := Target_Root;
+ X := Source_Root.Left;
+
+ while X /= null loop
+ declare
+ Y : Node_Access := Copy_Node (X);
+
+ begin
+ P.Left := Y;
+ Y.Parent := P;
+
+ if X.Right /= null then
+ Y.Right := Copy_Tree (X.Right);
+ Y.Right.Parent := Y;
+ end if;
+
+ P := Y;
+ X := X.Left;
+ end;
+ end loop;
+
+ return Target_Root;
+
+ exception
+ when others =>
+ Delete_Tree (Target_Root);
+ raise;
+ end Copy_Tree;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Position : in out Cursor) is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+ end Delete;
+
+ procedure Delete (Container : in out Set; Item : Element_Type) is
+ X : Node_Access :=
+ Element_Keys.Find (Container.Tree, Item);
+
+ begin
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Set) is
+ C : Cursor := First (Container);
+ begin
+ Delete (Container, C);
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Set) is
+ C : Cursor := Last (Container);
+ begin
+ Delete (Container, C);
+ end Delete_Last;
+
+ -----------------
+ -- Delete_Tree --
+ -----------------
+
+ procedure Delete_Tree (X : in out Node_Access) is
+ Y : Node_Access;
+ begin
+ while X /= null loop
+ Y := X.Right;
+ Delete_Tree (Y);
+ Y := X.Left;
+ Free (X);
+ X := Y;
+ end loop;
+ end Delete_Tree;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ Set_Ops.Difference (Target.Tree, Source.Tree);
+ end Difference;
+
+ function Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Difference (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Difference;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element.all;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Item : Element_Type) is
+ X : Node_Access :=
+ Element_Keys.Find (Container.Tree, Item);
+ begin
+ if X /= null then
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ begin
+ if Container.Tree.First = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Set) return Element_Type is
+ begin
+ return Container.Tree.First.Element.all;
+ end First_Element;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Floor (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ begin
+ if X /= null then
+ Free_Element (X.Element);
+ Deallocate (X);
+ end if;
+ end Free;
+
+ ------------------
+ -- Generic_Keys --
+ ------------------
+
+ package body Generic_Keys is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Key_Node);
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Key_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Key_Keys is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Key_Type,
+ Is_Less_Key_Node => Is_Less_Key_Node,
+ Is_Greater_Key_Node => Is_Greater_Key_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Element.all;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right > Left.Node.Element.all;
+ end "<";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left > Right.Node.Element.all;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right < Left.Node.Element.all;
+ end ">";
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access :=
+ Key_Keys.Ceiling (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ ----------------------------
+ -- Checked_Update_Element --
+ ----------------------------
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type))
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ declare
+ Old_Key : Key_Type renames Key (Position.Node.Element.all);
+
+ begin
+ Process (Position.Node.Element.all);
+
+ if Old_Key < Position.Node.Element.all
+ or else Old_Key > Position.Node.Element.all
+ then
+ null;
+ else
+ return;
+ end if;
+ end;
+
+ declare
+ Result : Node_Access;
+ Success : Boolean;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert is
+ new Key_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ return Position.Node;
+ end New_Node;
+
+ -- Start of processing for Checked_Update_Element
+
+ begin
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+
+ Insert
+ (Tree => Container.Tree,
+ Key => Key (Position.Node.Element.all),
+ Node => Result,
+ Success => Success);
+
+ if not Success then
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ Free (X);
+ end;
+
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Result = Position.Node);
+ end;
+ end Checked_Update_Element;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Key : Key_Type) is
+ X : Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type is
+ C : constant Cursor := Find (Container, Key);
+ begin
+ return C.Node.Element.all;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Key : Key_Type) is
+ X : Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if X /= null then
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access :=
+ Key_Keys.Floor (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ -------------------------
+ -- Is_Greater_Key_Node --
+ -------------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ return Left > Right.Element.all;
+ end Is_Greater_Key_Node;
+
+ ----------------------
+ -- Is_Less_Key_Node --
+ ----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ return Left < Right.Element.all;
+ end Is_Less_Key_Node;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Key (Position.Node.Element.all);
+ end Key;
+
+ end Generic_Keys;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include (Container : in out Set; New_Item : Element_Type) is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ X : Element_Access;
+
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ X := Position.Node.Element;
+ Position.Node.Element := new Element_Type'(New_Item);
+ Free_Element (X);
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Element : Element_Access := new Element_Type'(New_Item);
+ begin
+ return new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Red,
+ Element => Element);
+ exception
+ when others =>
+ Free_Element (Element);
+ raise;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container.Tree,
+ New_Item,
+ Position.Node,
+ Inserted);
+
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ procedure Insert (Container : in out Set; New_Item : Element_Type) is
+ Position : Cursor;
+ Inserted : Boolean;
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+ end Insert;
+
+ ----------------------
+ -- Insert_With_Hint --
+ ----------------------
+
+ procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access)
+ is
+ Success : Boolean;
+
+ function New_Node return Node_Access;
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ procedure Insert_With_Hint is
+ new Element_Keys.Generic_Conditional_Insert_With_Hint
+ (Insert_Post,
+ Insert_Sans_Hint);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Element : Element_Access :=
+ new Element_Type'(Src_Node.Element.all);
+ Node : Node_Access;
+
+ begin
+ begin
+ Node := new Node_Type;
+ exception
+ when others =>
+ Free_Element (Element);
+ raise;
+ end;
+
+ Node.Element := Element;
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Insert_With_Hint
+
+ begin
+ Insert_With_Hint
+ (Dst_Tree,
+ Dst_Hint,
+ Src_Node.Element.all,
+ Dst_Node,
+ Success);
+ end Insert_With_Hint;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Intersection (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Set_Ops.Intersection (Target.Tree, Source.Tree);
+ end Intersection;
+
+ function Intersection (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Intersection (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Intersection;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Length (Container) = 0;
+ end Is_Empty;
+
+ -----------------------------
+ -- Is_Greater_Element_Node --
+ -----------------------------
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ -- e > node same as node < e
+
+ return Right.Element.all < Left;
+ end Is_Greater_Element_Node;
+
+
+ --------------------------
+ -- Is_Less_Element_Node --
+ --------------------------
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ return Left < Right.Element.all;
+ end Is_Less_Element_Node;
+
+ -----------------------
+ -- Is_Less_Node_Node --
+ -----------------------
+
+ function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element.all < R.Element.all;
+ end Is_Less_Node_Node;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
+ begin
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
+ end Is_Subset;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree);
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Set) return Cursor is
+ begin
+ if Container.Tree.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Set) return Element_Type is
+ begin
+ return Container.Tree.Last.Element.all;
+ end Last_Element;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Left;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.Tree.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Move (Target => Target.Tree, Source => Source.Tree);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Next (Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Set) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return Left.Tree.Length /= 0;
+ end if;
+
+ return Set_Ops.Overlap (Left.Tree, Right.Tree);
+ end Overlap;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Parent;
+ end Parent;
+
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ Position := Previous (Position);
+ end Previous;
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Previous (Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ Process (Position.Node.Element.all);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Ada.Streams.Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ N : Count_Type'Base;
+
+ function New_Node return Node_Access;
+
+ procedure Read is
+ new Tree_Operations.Generic_Read (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ Node.Element := new Element_Type'(Element_Type'Input (Stream));
+ return Node;
+
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end New_Node;
+
+ -- Start of processing for Read
+
+ begin
+ Clear (Container);
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+ Read (Container.Tree, N);
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace (Container : in out Set; New_Item : Element_Type) is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.Tree, New_Item);
+
+ X : Element_Access;
+
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
+ X := Node.Element;
+ Node.Element := new Element_Type'(New_Item);
+ Free_Element (X);
+ end Replace;
+
+-- TODO ???
+-- procedure Replace
+-- (Container : in out Set;
+-- Key : Key_Type;
+-- New_Item : Element_Type)
+-- is
+-- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+-- begin
+-- if Node = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- Replace_Element (Container, Node, New_Item);
+-- end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+-- TODO: ???
+-- procedure Replace_Element
+-- (Container : in out Set;
+-- Position : Node_Access;
+-- By : Element_Type)
+-- is
+
+-- Node : Node_Access := Position;
+
+-- begin
+-- if By < Node.Element.all
+-- or else Node.Element.all < By
+-- then
+-- null;
+
+-- else
+-- declare
+-- X : Element_Access := Node.Element;
+
+-- begin
+-- Node.Element := new Element_Type'(By);
+
+-- -- NOTE: If there's an exception here, then just
+-- -- let it propagate. We haven't modified the
+-- -- state of the container, so there's nothing else
+-- -- we need to do.
+
+-- Free_Element (X);
+-- end;
+
+-- return;
+-- end if;
+
+-- Delete_Node_Sans_Free (Container.Tree, Node);
+
+-- begin
+-- Free_Element (Node.Element);
+-- exception
+-- when others =>
+-- Node.Element := null; -- don't attempt to dealloc X.E again
+-- Free (Node);
+-- raise;
+-- end;
+
+-- begin
+-- Node.Element := new Element_Type'(By);
+-- exception
+-- when others =>
+-- Free (Node);
+-- raise;
+-- end;
+
+-- declare
+-- function New_Node return Node_Access;
+-- pragma Inline (New_Node);
+
+-- function New_Node return Node_Access is
+-- begin
+-- return Node;
+-- end New_Node;
+
+-- procedure Insert_Post is
+-- new Element_Keys.Generic_Insert_Post (New_Node);
+
+-- procedure Insert is
+-- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+-- Result : Node_Access;
+-- Success : Boolean;
+
+-- begin
+-- Insert
+-- (Tree => Container.Tree,
+-- Key => Node.Element.all,
+-- Node => Result,
+-- Success => Success);
+
+-- if not Success then
+-- Free (Node);
+-- raise Program_Error;
+-- end if;
+
+-- pragma Assert (Result = Node);
+-- end;
+-- end Replace_Element;
+
+
+-- procedure Replace_Element
+-- (Container : in out Set;
+-- Position : Cursor;
+-- By : Element_Type)
+-- is
+-- begin
+-- if Position.Container = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+-- raise Program_Error;
+-- end if;
+
+-- Replace_Element (Container, Position.Node, By);
+-- end Replace_Element;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree);
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Right;
+ end Right;
+
+ ---------------
+ -- Set_Color --
+ ---------------
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type) is
+ begin
+ Node.Color := Color;
+ end Set_Color;
+
+ --------------
+ -- Set_Left --
+ --------------
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access) is
+ begin
+ Node.Left := Left;
+ end Set_Left;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
+ begin
+ Node.Parent := Parent;
+ end Set_Parent;
+
+ ---------------
+ -- Set_Right --
+ ---------------
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access) is
+ begin
+ Node.Right := Right;
+ end Set_Right;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
+ end Symmetric_Difference;
+
+ function Symmetric_Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Symmetric_Difference;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Set_Ops.Union (Target.Tree, Source.Tree);
+ end Union;
+
+ function Union (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Union (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Union;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Ada.Streams.Root_Stream_Type'Class;
+ Container : Set)
+ is
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is
+ new Tree_Operations.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Element_Type'Output (Stream, Node.Element.all);
+ end Process;
+
+ -- Start of processing for Write
+
+ begin
+ Count_Type'Base'Write (Stream, Container.Tree.Length);
+ Iterate (Container.Tree);
+ end Write;
+
+end Ada.Containers.Indefinite_Ordered_Sets;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees;
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+ type Element_Type (<>) is private;
+
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Ordered_Sets is
+pragma Preelaborate (Indefinite_Ordered_Sets);
+
+ type Set is tagged private;
+
+ type Cursor is private;
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ -- TODO: resolve in Atlanta???
+ -- procedure Replace_Element
+ -- (Container : in out Set;
+ -- Position : Cursor;
+ -- By : Element_Type);
+
+ procedure Move (Target : in out Set; Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Set);
+
+ procedure Delete_Last (Container : in out Set);
+
+ procedure Union (Target : in out Set; Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set;
+ Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Find (Container : Set; Item : Element_Type) return Cursor;
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor;
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor;
+
+ function First (Container : Set) return Cursor;
+
+ function First_Element (Container : Set) return Element_Type;
+
+ function Last (Container : Set) return Cursor;
+
+ function Last_Element (Container : Set) return Element_Type;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function "<" (Left, Right : Cursor) return Boolean;
+
+ function ">" (Left, Right : Cursor) return Boolean;
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ generic
+ type Key_Type (<>) is limited private;
+
+ with function Key (Element : Element_Type) return Key_Type;
+
+ with function "<" (Left : Key_Type; Right : Element_Type)
+ return Boolean is <>;
+
+ with function ">" (Left : Key_Type; Right : Element_Type)
+ return Boolean is <>;
+
+ package Generic_Keys is
+
+ function Contains
+ (Container : Set;
+ Key : Key_Type) return Boolean;
+
+ function Find
+ (Container : Set;
+ Key : Key_Type) return Cursor;
+
+ function Floor
+ (Container : Set;
+ Key : Key_Type) return Cursor;
+
+ function Ceiling
+ (Container : Set;
+ Key : Key_Type) return Cursor;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element
+ (Container : Set;
+ Key : Key_Type) return Element_Type;
+
+ -- TODO: resolve in Atlanta???
+ -- procedure Replace
+ -- (Container : in out Set;
+ -- Key : Key_Type;
+ -- New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ -- TODO: resolve name in Atlanta???
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ end Generic_Keys;
+
+private
+
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Set is new Controlled with record
+ Tree : Tree_Type := (Length => 0, others => null);
+ end record;
+
+ procedure Adjust (Container : in out Set);
+
+ procedure Finalize (Container : in out Set) renames Clear;
+
+ type Set_Access is access constant Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, null);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set :=
+ (Controlled with Tree => (Length => 0, others => null));
+
+end Ada.Containers.Indefinite_Ordered_Sets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASHED_MAPS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Ada.Containers.Hash_Tables.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
+
+with Ada.Containers.Hash_Tables.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
+
+package body Ada.Containers.Hashed_Maps is
+
+ type Node_Type is limited record
+ Key : Key_Type;
+ Element : Element_Type;
+ Next : Node_Access;
+ end record;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Copy_Node
+ (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ function Find_Equal_Key
+ (R_Map : Map;
+ L_Node : Node_Access) return Boolean;
+
+ function Hash_Node (Node : Node_Access) return Hash_Type;
+ pragma Inline (Hash_Node);
+
+ function Next (Node : Node_Access) return Node_Access;
+ pragma Inline (Next);
+
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+ pragma Inline (Read_Node);
+
+ procedure Set_Next (Node : Node_Access; Next : Node_Access);
+ pragma Inline (Set_Next);
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ package HT_Ops is
+ new Hash_Tables.Generic_Operations
+ (HT_Types => HT_Types,
+ Hash_Table_Type => Map,
+ Null_Node => null,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next,
+ Copy_Node => Copy_Node,
+ Free => Free);
+
+ package Key_Ops is
+ new Hash_Tables.Generic_Keys
+ (HT_Types => HT_Types,
+ HT_Type => Map,
+ Null_Node => null,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Key_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Keys);
+
+ function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
+
+ procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
+ procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Map) return Boolean renames Is_Equal;
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Map) renames HT_Ops.Adjust;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Map) return Count_Type
+ renames HT_Ops.Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Map) renames HT_Ops.Clear;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ function Copy_Node
+ (Source : Node_Access) return Node_Access
+ is
+ Target : constant Node_Access :=
+ new Node_Type'(Key => Source.Key,
+ Element => Source.Element,
+ Next => null);
+ begin
+ return Target;
+ end Copy_Node;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Map; Key : Key_Type) is
+ X : Node_Access;
+
+ begin
+ Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Free (X);
+ end Delete;
+
+ procedure Delete (Container : in out Map; Position : in out Cursor) is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Map_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type is
+ C : constant Cursor := Find (Container, Key);
+ begin
+ return C.Node.Element;
+ end Element;
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element;
+ end Element;
+
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean is
+ begin
+ return Equivalent_Keys (Key, Node.Key);
+ end Equivalent_Keys;
+
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+
+ function Equivalent_Keys (Left, Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Equivalent_Keys (Left.Node.Key, Right);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Equivalent_Keys (Left, Right.Node.Key);
+ end Equivalent_Keys;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Map; Key : Key_Type) is
+ X : Node_Access;
+ begin
+ Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Free (X);
+ end Exclude;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Container : in out Map) renames HT_Ops.Finalize;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ --------------------
+ -- Find_Equal_Key --
+ --------------------
+
+ function Find_Equal_Key
+ (R_Map : Map;
+ L_Node : Node_Access) return Boolean
+ is
+ R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key);
+ R_Node : Node_Access := R_Map.Buckets (R_Index);
+
+ begin
+ while R_Node /= null loop
+ if Equivalent_Keys (L_Node.Key, R_Node.Key) then
+ return L_Node.Element = R_Node.Element;
+ end if;
+
+ R_Node := R_Node.Next;
+ end loop;
+
+ return False;
+ end Find_Equal_Key;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Map) return Cursor is
+ Node : constant Node_Access := HT_Ops.First (Container);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end First;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ ---------------
+ -- Hash_Node --
+ ---------------
+
+ function Hash_Node (Node : Node_Access) return Hash_Type is
+ begin
+ return Hash (Node.Key);
+ end Hash_Node;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ Position.Node.Key := Key;
+ Position.Node.Element := New_Item;
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert is
+ new Key_Ops.Generic_Conditional_Insert (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ Node : Node_Access := new Node_Type; -- Ada 2005 aggregate possible?
+
+ begin
+ Node.Key := Key;
+ Node.Next := Next;
+
+ return Node;
+
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
+ Local_Insert (Container, Key, Position.Node, Inserted);
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert is
+ new Key_Ops.Generic_Conditional_Insert (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ Node : constant Node_Access := new Node_Type'(Key, New_Item, Next);
+ begin
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
+ Local_Insert (Container, Key, Position.Node, Inserted);
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+ end Insert;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Map) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container);
+ end Iterate;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Position.Node.Key;
+ end Key;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Map) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Target : in out Map;
+ Source : in out Map) renames HT_Ops.Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Next;
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ M : Map renames Position.Container.all;
+ Node : constant Node_Access := HT_Ops.Next (M, Position.Node);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ Process (Position.Node.Key, Position.Node.Element);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Map) renames Read_Nodes;
+
+ ---------------
+ -- Read_Node --
+ ---------------
+
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ Key_Type'Read (Stream, Node.Key);
+ Element_Type'Read (Stream, Node.Element);
+ return Node;
+
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end Read_Node;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
+ Node.Key := Key;
+ Node.Element := New_Item;
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ begin
+ Position.Node.Element := By;
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Map;
+ Capacity : Count_Type) renames HT_Ops.Ensure_Capacity;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (Node : Node_Access; Next : Node_Access) is
+ begin
+ Node.Next := Next;
+ end Set_Next;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ Process (Position.Node.Key, Position.Node.Element);
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Map) renames Write_Nodes;
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
+ begin
+ Key_Type'Write (Stream, Node.Key);
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
+
+end Ada.Containers.Hashed_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASHED_MAPS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Hash_Tables;
+with Ada.Streams;
+
+generic
+ type Key_Type is private;
+
+ type Element_Type is private;
+
+ with function Hash (Key : Key_Type) return Hash_Type;
+
+ with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Hashed_Maps is
+pragma Preelaborate (Hashed_Maps);
+
+ type Map is tagged private;
+
+ type Cursor is private;
+
+ Empty_Map : constant Map;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Map) return Boolean;
+
+ function Length (Container : Map) return Count_Type;
+
+ function Is_Empty (Container : Map) return Boolean;
+
+ procedure Clear (Container : in out Map);
+
+ function Element (Position : Cursor)
+ return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type));
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : in out Element_Type));
+
+ procedure Replace_Element (Position : Cursor; By : Element_Type);
+
+ procedure Move (Target : in out Map; Source : in out Map);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Delete (Container : in out Map; Key : Key_Type);
+
+ procedure Exclude (Container : in out Map; Key : Key_Type);
+
+ procedure Delete (Container : in out Map; Position : in out Cursor);
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean;
+
+ function Find (Container : Map; Key : Key_Type) return Cursor;
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type;
+
+ function Capacity (Container : Map) return Count_Type;
+
+ procedure Reserve_Capacity (Container : in out Map;
+ Capacity : Count_Type);
+
+ function First (Container : Map) return Cursor;
+
+ function Next (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Equivalent_Keys (Left, Right : Cursor) return Boolean;
+
+ function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+
+private
+
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package HT_Types is new Hash_Tables.Generic_Hash_Table_Types (Node_Access);
+
+ use HT_Types;
+
+ type Map is new Hash_Table_Type with null record;
+
+ procedure Adjust (Container : in out Map);
+
+ procedure Finalize (Container : in out Map);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Map);
+
+ for Map'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Map);
+
+ for Map'Read use Read;
+
+ Empty_Map : constant Map := (Hash_Table_Type with null record);
+
+ type Map_Access is access constant Map;
+ for Map_Access'Storage_Size use 0;
+
+ type Cursor is
+ record
+ Container : Map_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := (Container => null, Node => null);
+
+end Ada.Containers.Hashed_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASHED_SETS --
+-- --
+-- 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.Unchecked_Deallocation;
+
+with Ada.Containers.Hash_Tables.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
+
+with Ada.Containers.Hash_Tables.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
+
+with System; use type System.Address;
+
+with Ada.Containers.Prime_Numbers;
+
+with Ada.Finalization; use Ada.Finalization;
+
+package body Ada.Containers.Hashed_Sets is
+
+ type Node_Type is
+ limited record
+ Element : Element_Type;
+ Next : Node_Access;
+ end record;
+
+ function Hash_Node
+ (Node : Node_Access) return Hash_Type;
+ pragma Inline (Hash_Node);
+
+ function Hash_Node
+ (Node : Node_Access) return Hash_Type is
+ begin
+ return Hash (Node.Element);
+ end Hash_Node;
+
+ function Next
+ (Node : Node_Access) return Node_Access;
+ pragma Inline (Next);
+
+ function Next
+ (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Next;
+ end Next;
+
+ procedure Set_Next
+ (Node : Node_Access;
+ Next : Node_Access);
+ pragma Inline (Set_Next);
+
+ procedure Set_Next
+ (Node : Node_Access;
+ Next : Node_Access) is
+ begin
+ Node.Next := Next;
+ end Set_Next;
+
+ function Equivalent_Keys
+ (Key : Element_Type;
+ Node : Node_Access) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ function Equivalent_Keys
+ (Key : Element_Type;
+ Node : Node_Access) return Boolean is
+ begin
+ return Equivalent_Keys (Key, Node.Element);
+ end Equivalent_Keys;
+
+ function Copy_Node
+ (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Copy_Node
+ (Source : Node_Access) return Node_Access is
+
+ Target : constant Node_Access :=
+ new Node_Type'(Element => Source.Element,
+ Next => null);
+ begin
+ return Target;
+ end Copy_Node;
+
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ package HT_Ops is
+ new Hash_Tables.Generic_Operations
+ (HT_Types => HT_Types,
+ Hash_Table_Type => Set,
+ Null_Node => null,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next,
+ Copy_Node => Copy_Node,
+ Free => Free);
+
+ package Element_Keys is
+ new Hash_Tables.Generic_Keys
+ (HT_Types => HT_Types,
+ HT_Type => Set,
+ Null_Node => null,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Element_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Keys);
+
+
+ procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;
+
+ procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;
+
+
+ function Find_Equal_Key
+ (R_Set : Set;
+ L_Node : Node_Access) return Boolean;
+
+ function Find_Equal_Key
+ (R_Set : Set;
+ L_Node : Node_Access) return Boolean is
+
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_Set, L_Node.Element);
+
+ R_Node : Node_Access := R_Set.Buckets (R_Index);
+
+ begin
+
+ loop
+
+ if R_Node = null then
+ return False;
+ end if;
+
+ if L_Node.Element = R_Node.Element then
+ -- pragma Assert (Is_Equal_Key (L_Node.Element, R_Node.Element));
+ return True;
+ end if;
+
+ R_Node := Next (R_Node);
+
+ end loop;
+
+ end Find_Equal_Key;
+
+ function Is_Equal is
+ new HT_Ops.Generic_Equal (Find_Equal_Key);
+
+ function "=" (Left, Right : Set) return Boolean renames Is_Equal;
+
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+
+ procedure Clear (Container : in out Set) renames HT_Ops.Clear;
+
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element;
+ end Element;
+
+
+ procedure Query_Element
+ (Position : in Cursor;
+ Process : not null access procedure (Element : in Element_Type)) is
+ begin
+ Process (Position.Node.Element);
+ end Query_Element;
+
+
+-- TODO:
+-- procedure Replace_Element (Container : in out Set;
+-- Position : in Node_Access;
+-- By : in Element_Type) is
+
+-- Node : Node_Access := Position;
+
+-- begin
+
+-- if Equivalent_Keys (Node.Element, By) then
+
+-- begin
+-- Node.Element := By;
+-- exception
+-- when others =>
+-- HT_Ops.Delete_Node_Sans_Free (Container, Node);
+-- Free (Node);
+-- raise;
+-- end;
+
+-- return;
+
+-- end if;
+
+-- HT_Ops.Delete_Node_Sans_Free (Container, Node);
+
+-- begin
+-- Node.Element := By;
+-- exception
+-- when others =>
+-- Free (Node);
+-- raise;
+-- end;
+
+-- declare
+-- function New_Node (Next : Node_Access) return Node_Access;
+-- pragma Inline (New_Node);
+
+-- function New_Node (Next : Node_Access) return Node_Access is
+-- begin
+-- Node.Next := Next;
+-- return Node;
+-- end New_Node;
+
+-- procedure Insert is
+-- new Element_Keys.Generic_Conditional_Insert (New_Node);
+
+-- Result : Node_Access;
+-- Success : Boolean;
+-- begin
+-- Insert
+-- (HT => Container,
+-- Key => Node.Element,
+-- Node => Result,
+-- Success => Success);
+
+-- if not Success then
+-- Free (Node);
+-- raise Program_Error;
+-- end if;
+
+-- pragma Assert (Result = Node);
+-- end;
+
+-- end Replace_Element;
+
+
+-- procedure Replace_Element (Container : in out Set;
+-- Position : in Cursor;
+-- By : in Element_Type) is
+-- begin
+
+-- if Position.Container = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+-- raise Program_Error;
+-- end if;
+
+-- Replace_Element (Container, Position.Node, By);
+
+-- end Replace_Element;
+
+
+ procedure Move (Target : in out Set;
+ Source : in out Set) renames HT_Ops.Move;
+
+
+ procedure Insert (Container : in out Set;
+ New_Item : in Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean) is
+
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ Node : constant Node_Access := new Node_Type'(New_Item, Next);
+ begin
+ return Node;
+ end New_Node;
+
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
+
+ begin
+
+ HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
+ Insert (Container, New_Item, Position.Node, Inserted);
+ Position.Container := Container'Unchecked_Access;
+
+ end Insert;
+
+
+ procedure Insert (Container : in out Set;
+ New_Item : in Element_Type) is
+
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+
+ end Insert;
+
+
+ procedure Replace (Container : in out Set;
+ New_Item : in Element_Type) is
+
+ X : Node_Access := Element_Keys.Find (Container, New_Item);
+
+ begin
+
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ X.Element := New_Item;
+
+ end Replace;
+
+
+ procedure Include (Container : in out Set;
+ New_Item : in Element_Type) is
+
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ Position.Node.Element := New_Item;
+ end if;
+
+ end Include;
+
+
+ procedure Delete (Container : in out Set;
+ Item : in Element_Type) is
+
+ X : Node_Access;
+
+ begin
+
+ Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Free (X);
+
+ end Delete;
+
+
+ procedure Exclude (Container : in out Set;
+ Item : in Element_Type) is
+
+ X : Node_Access;
+
+ begin
+
+ Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+ Free (X);
+
+ end Exclude;
+
+
+ procedure Delete (Container : in out Set;
+ Position : in out Cursor) is
+ begin
+
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+
+ end Delete;
+
+
+
+ procedure Union (Target : in out Set;
+ Source : in Set) is
+
+ procedure Process (Src_Node : in Node_Access);
+
+ procedure Process (Src_Node : in Node_Access) is
+
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ Node : constant Node_Access :=
+ new Node_Type'(Src_Node.Element, Next);
+ begin
+ return Node;
+ end New_Node;
+
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
+
+ Tgt_Node : Node_Access;
+ Success : Boolean;
+
+ begin
+
+ Insert (Target, Src_Node.Element, Tgt_Node, Success);
+
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ begin
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
+
+ Iterate (Source);
+
+ end Union;
+
+
+
+ function Union (Left, Right : Set) return Set is
+
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+
+ begin
+
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ if Left.Length = 0 then
+ return Right;
+ end if;
+
+ declare
+ Size : constant Hash_Type :=
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+
+ declare
+ procedure Process (L_Node : Node_Access);
+
+ procedure Process (L_Node : Node_Access) is
+ I : constant Hash_Type :=
+ Hash (L_Node.Element) mod Buckets'Length;
+ begin
+ Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Left);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ Length := Left.Length;
+
+ declare
+ procedure Process (Src_Node : Node_Access);
+
+ procedure Process (Src_Node : Node_Access) is
+
+ I : constant Hash_Type :=
+ Hash (Src_Node.Element) mod Buckets'Length;
+
+ Tgt_Node : Node_Access := Buckets (I);
+
+ begin
+
+ while Tgt_Node /= null loop
+
+ if Equivalent_Keys (Src_Node.Element, Tgt_Node.Element) then
+ return;
+ end if;
+
+ Tgt_Node := Next (Tgt_Node);
+
+ end loop;
+
+ Buckets (I) := new Node_Type'(Src_Node.Element, Buckets (I));
+ Length := Length + 1;
+
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Right);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ return (Controlled with Buckets, Length);
+
+ end Union;
+
+
+ function Is_In
+ (HT : Set;
+ Key : Node_Access) return Boolean;
+ pragma Inline (Is_In);
+
+ function Is_In
+ (HT : Set;
+ Key : Node_Access) return Boolean is
+ begin
+ return Element_Keys.Find (HT, Key.Element) /= null;
+ end Is_In;
+
+
+ procedure Intersection (Target : in out Set;
+ Source : in Set) is
+
+ Tgt_Node : Node_Access;
+
+ begin
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ Clear (Target);
+ return;
+ end if;
+
+ -- TODO: optimize this to use an explicit
+ -- loop instead of an active iterator
+ -- (similar to how a passive iterator is
+ -- implemented).
+ --
+ -- Another possibility is to test which
+ -- set is smaller, and iterate over the
+ -- smaller set.
+
+ Tgt_Node := HT_Ops.First (Target);
+
+ while Tgt_Node /= null loop
+
+ if Is_In (Source, Tgt_Node) then
+
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+
+ else
+
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, X);
+ Free (X);
+ end;
+
+ end if;
+
+ end loop;
+
+ end Intersection;
+
+
+ function Intersection (Left, Right : Set) return Set is
+
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+
+ begin
+
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ Length := Count_Type'Min (Left.Length, Right.Length);
+
+ if Length = 0 then
+ return Empty_Set;
+ end if;
+
+ declare
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+
+ Length := 0;
+
+ declare
+ procedure Process (L_Node : Node_Access);
+
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if Is_In (Right, L_Node) then
+
+ declare
+ I : constant Hash_Type :=
+ Hash (L_Node.Element) mod Buckets'Length;
+ begin
+ Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
+ end;
+
+ Length := Length + 1;
+
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Left);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ return (Controlled with Buckets, Length);
+
+ end Intersection;
+
+
+ procedure Difference (Target : in out Set;
+ Source : in Set) is
+
+
+ Tgt_Node : Node_Access;
+
+ begin
+
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ return;
+ end if;
+
+ -- TODO: As I noted above, this can be
+ -- written in terms of a loop instead as
+ -- active-iterator style, sort of like a
+ -- passive iterator.
+
+ Tgt_Node := HT_Ops.First (Target);
+
+ while Tgt_Node /= null loop
+
+ if Is_In (Source, Tgt_Node) then
+
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, X);
+ Free (X);
+ end;
+
+ else
+
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+
+ end if;
+
+ end loop;
+
+ end Difference;
+
+
+
+ function Difference (Left, Right : Set) return Set is
+
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+
+ begin
+
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ if Left.Length = 0 then
+ return Empty_Set;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ declare
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+
+ Length := 0;
+
+ declare
+ procedure Process (L_Node : Node_Access);
+
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if not Is_In (Right, L_Node) then
+
+ declare
+ I : constant Hash_Type :=
+ Hash (L_Node.Element) mod Buckets'Length;
+ begin
+ Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
+ end;
+
+ Length := Length + 1;
+
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Left);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ return (Controlled with Buckets, Length);
+
+ end Difference;
+
+
+
+ procedure Symmetric_Difference (Target : in out Set;
+ Source : in Set) is
+ begin
+
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
+
+ if Target.Length = 0 then
+
+ declare
+ procedure Process (Src_Node : Node_Access);
+
+ procedure Process (Src_Node : Node_Access) is
+ E : Element_Type renames Src_Node.Element;
+ B : Buckets_Type renames Target.Buckets.all;
+ I : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.Length;
+ begin
+ B (I) := new Node_Type'(E, B (I));
+ N := N + 1;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Source);
+ end;
+
+ else
+
+ declare
+ procedure Process (Src_Node : Node_Access);
+
+ procedure Process (Src_Node : Node_Access) is
+ E : Element_Type renames Src_Node.Element;
+ B : Buckets_Type renames Target.Buckets.all;
+ I : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.Length;
+ begin
+ if B (I) = null then
+
+ B (I) := new Node_Type'(E, null);
+ N := N + 1;
+
+ elsif Equivalent_Keys (E, B (I).Element) then
+
+ declare
+ X : Node_Access := B (I);
+ begin
+ B (I) := B (I).Next;
+ N := N - 1;
+ Free (X);
+ end;
+
+ else
+
+ declare
+ Prev : Node_Access := B (I);
+ Curr : Node_Access := Prev.Next;
+ begin
+ while Curr /= null loop
+ if Equivalent_Keys (E, Curr.Element) then
+ Prev.Next := Curr.Next;
+ N := N - 1;
+ Free (Curr);
+ return;
+ end if;
+
+ Prev := Curr;
+ Curr := Prev.Next;
+ end loop;
+
+ B (I) := new Node_Type'(E, B (I));
+ N := N + 1;
+ end;
+
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Source);
+ end;
+
+ end if;
+
+ end Symmetric_Difference;
+
+
+ function Symmetric_Difference (Left, Right : Set) return Set is
+
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+
+ begin
+
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ if Left.Length = 0 then
+ return Right;
+ end if;
+
+ declare
+ Size : constant Hash_Type :=
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+
+ Length := 0;
+
+ declare
+ procedure Process (L_Node : Node_Access);
+
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if not Is_In (Right, L_Node) then
+ declare
+ E : Element_Type renames L_Node.Element;
+ I : constant Hash_Type := Hash (E) mod Buckets'Length;
+ begin
+ Buckets (I) := new Node_Type'(E, Buckets (I));
+ Length := Length + 1;
+ end;
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Left);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ declare
+ procedure Process (R_Node : Node_Access);
+
+ procedure Process (R_Node : Node_Access) is
+ begin
+ if not Is_In (Left, R_Node) then
+ declare
+ E : Element_Type renames R_Node.Element;
+ I : constant Hash_Type := Hash (E) mod Buckets'Length;
+ begin
+ Buckets (I) := new Node_Type'(E, Buckets (I));
+ Length := Length + 1;
+ end;
+ end if;
+ end Process;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ begin
+ Iterate (Right);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end;
+
+ return (Controlled with Buckets, Length);
+
+ end Symmetric_Difference;
+
+
+ function Is_Subset (Subset : Set;
+ Of_Set : Set) return Boolean is
+
+ Subset_Node : Node_Access;
+
+ begin
+
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ if Subset.Length > Of_Set.Length then
+ return False;
+ end if;
+
+ -- TODO: rewrite this to loop in the
+ -- style of a passive iterator.
+
+ Subset_Node := HT_Ops.First (Subset);
+
+ while Subset_Node /= null loop
+ if not Is_In (Of_Set, Subset_Node) then
+ return False;
+ end if;
+
+ Subset_Node := HT_Ops.Next (Subset, Subset_Node);
+ end loop;
+
+ return True;
+
+ end Is_Subset;
+
+
+ function Overlap (Left, Right : Set) return Boolean is
+
+ Left_Node : Node_Access;
+
+ begin
+
+ if Right.Length = 0 then
+ return False;
+ end if;
+
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ Left_Node := HT_Ops.First (Left);
+
+ while Left_Node /= null loop
+ if Is_In (Right, Left_Node) then
+ return True;
+ end if;
+
+ Left_Node := HT_Ops.Next (Left, Left_Node);
+ end loop;
+
+ return False;
+
+ end Overlap;
+
+
+ function Find (Container : Set;
+ Item : Element_Type) return Cursor is
+
+ Node : constant Node_Access := Element_Keys.Find (Container, Item);
+
+ begin
+
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+
+ end Find;
+
+
+ function Contains (Container : Set;
+ Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+
+
+ function First (Container : Set) return Cursor is
+ Node : constant Node_Access := HT_Ops.First (Container);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end First;
+
+
+-- function First_Element (Container : Set) return Element_Type is
+-- Node : constant Node_Access := HT_Ops.First (Container);
+-- begin
+-- return Node.Element;
+-- end First_Element;
+
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Container = null
+ or else Position.Node = null
+ then
+ return No_Element;
+ end if;
+
+ declare
+ S : Set renames Position.Container.all;
+ Node : constant Node_Access := HT_Ops.Next (S, Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ if Position.Container = null then
+ return False;
+ end if;
+
+ if Position.Node = null then
+ return False;
+ end if;
+
+ return True;
+ end Has_Element;
+
+
+ function Equivalent_Keys (Left, Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left.Node.Element, Right.Node.Element);
+ end Equivalent_Keys;
+
+
+ function Equivalent_Keys (Left : Cursor;
+ Right : Element_Type)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left.Node.Element, Right);
+ end Equivalent_Keys;
+
+
+ function Equivalent_Keys (Left : Element_Type;
+ Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left, Right.Node.Element);
+ end Equivalent_Keys;
+
+
+ procedure Iterate
+ (Container : in Set;
+ Process : not null access procedure (Position : in Cursor)) is
+
+ procedure Process_Node (Node : in Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Process_Node (Node : in Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process_Node);
+ begin
+ Iterate (Container);
+ end Iterate;
+
+
+ function Capacity (Container : Set) return Count_Type
+ renames HT_Ops.Capacity;
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : in Count_Type)
+ renames HT_Ops.Ensure_Capacity;
+
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : in Node_Access);
+ pragma Inline (Write_Node);
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : in Node_Access) is
+ begin
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
+
+ procedure Write_Nodes is
+ new HT_Ops.Generic_Write (Write_Node);
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : in Set) renames Write_Nodes;
+
+
+ function Read_Node (Stream : access Root_Stream_Type'Class)
+ return Node_Access;
+ pragma Inline (Read_Node);
+
+ function Read_Node (Stream : access Root_Stream_Type'Class)
+ return Node_Access is
+
+ Node : Node_Access := new Node_Type;
+ begin
+ Element_Type'Read (Stream, Node.Element);
+ return Node;
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end Read_Node;
+
+ procedure Read_Nodes is
+ new HT_Ops.Generic_Read (Read_Node);
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set) renames Read_Nodes;
+
+
+ package body Generic_Keys is
+
+ function Equivalent_Keys (Left : Cursor;
+ Right : Key_Type)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Right, Left.Node.Element);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys (Left : Key_Type;
+ Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Keys (Left, Right.Node.Element);
+ end Equivalent_Keys;
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean is
+ begin
+ return Equivalent_Keys (Key, Node.Element);
+ end Equivalent_Keys;
+
+ package Key_Keys is
+ new Hash_Tables.Generic_Keys
+ (HT_Types => HT_Types,
+ HT_Type => Set,
+ Null_Node => null,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Key_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Keys);
+
+
+ function Find (Container : Set;
+ Key : Key_Type)
+ return Cursor is
+
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container, Key);
+
+ begin
+
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+
+ end Find;
+
+
+ function Contains (Container : Set;
+ Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+
+ function Element (Container : Set;
+ Key : Key_Type)
+ return Element_Type is
+
+ Node : constant Node_Access := Key_Keys.Find (Container, Key);
+ begin
+ return Node.Element;
+ end Element;
+
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Key (Position.Node.Element);
+ end Key;
+
+
+-- TODO:
+-- procedure Replace (Container : in out Set;
+-- Key : in Key_Type;
+-- New_Item : in Element_Type) is
+
+-- Node : constant Node_Access :=
+-- Key_Keys.Find (Container, Key);
+
+-- begin
+
+-- if Node = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- Replace_Element (Container, Node, New_Item);
+
+-- end Replace;
+
+
+ procedure Delete (Container : in out Set;
+ Key : in Key_Type) is
+
+ X : Node_Access;
+
+ begin
+
+ Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Free (X);
+
+ end Delete;
+
+
+ procedure Exclude (Container : in out Set;
+ Key : in Key_Type) is
+
+ X : Node_Access;
+
+ begin
+
+ Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+ Free (X);
+
+ end Exclude;
+
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : in Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type)) is
+
+ begin
+
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ declare
+ Old_Key : Key_Type renames Key (Position.Node.Element);
+ begin
+ Process (Position.Node.Element);
+
+ if Equivalent_Keys (Old_Key, Position.Node.Element) then
+ return;
+ end if;
+ end;
+
+ declare
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+
+ function New_Node (Next : Node_Access) return Node_Access is
+ begin
+ Position.Node.Next := Next;
+ return Position.Node;
+ end New_Node;
+
+ procedure Insert is
+ new Key_Keys.Generic_Conditional_Insert (New_Node);
+
+ Result : Node_Access;
+ Success : Boolean;
+ begin
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+
+ Insert
+ (HT => Container,
+ Key => Key (Position.Node.Element),
+ Node => Result,
+ Success => Success);
+
+ if not Success then
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ Free (X);
+ end;
+
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Result = Position.Node);
+ end;
+
+ end Checked_Update_Element;
+
+ end Generic_Keys;
+
+end Ada.Containers.Hashed_Sets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASHED_SETS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Hash_Tables;
+with Ada.Streams;
+
+generic
+ type Element_Type is private;
+
+ with function Hash (Element : Element_Type) return Hash_Type;
+
+ -- TODO: get a ruling from ARG in Atlanta re the name and
+ -- order of these declarations. ???
+ --
+ with function Equivalent_Keys (Left, Right : Element_Type) return Boolean;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Hashed_Sets is
+pragma Preelaborate (Hashed_Sets);
+
+ type Set is tagged private;
+
+ type Cursor is private;
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ -- TODO: resolve in atlanta
+ -- procedure Replace_Element
+ -- (Container : in out Set;
+ -- Position : Cursor;
+ -- By : Element_Type);
+
+ procedure Move (Target : in out Set; Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert (Container : in out Set; New_Item : Element_Type);
+
+ procedure Include (Container : in out Set; New_Item : Element_Type);
+
+ procedure Replace (Container : in out Set; New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Item : Element_Type);
+
+ procedure Exclude (Container : in out Set; Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Position : in out Cursor);
+
+ procedure Union (Target : in out Set; Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set; Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set
+ renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor;
+
+ function Capacity (Container : Set) return Count_Type;
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : Count_Type);
+
+ function First (Container : Set) return Cursor;
+
+ function Next (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function Equivalent_Keys (Left, Right : Cursor) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Cursor;
+ Right : Element_Type) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Element_Type;
+ Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ generic
+ type Key_Type (<>) is limited private;
+
+ with function Key (Element : Element_Type) return Key_Type;
+
+ with function Hash (Key : Key_Type) return Hash_Type;
+
+ with function Equivalent_Keys
+ (Key : Key_Type;
+ Element : Element_Type) return Boolean;
+
+ package Generic_Keys is
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+
+ -- TODO: resolve in atlanta
+ -- procedure Replace
+ -- (Container : in out Set;
+ -- Key : Key_Type;
+ -- New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ -- TODO: resolve name in atlanta: ???
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ function Equivalent_Keys
+ (Left : Cursor;
+ Right : Key_Type) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Cursor) return Boolean;
+
+ end Generic_Keys;
+
+private
+
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package HT_Types is
+ new Hash_Tables.Generic_Hash_Table_Types (Node_Access);
+
+ use HT_Types;
+
+ type Set is new Hash_Table_Type with null record;
+
+ procedure Adjust (Container : in out Set);
+
+ procedure Finalize (Container : in out Set);
+
+ type Set_Access is access constant Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := (Container => null, Node => null);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set := (Hash_Table_Type with null record);
+
+end Ada.Containers.Hashed_Sets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+
+package Ada.Containers.Hash_Tables is
+pragma Preelaborate;
+
+ generic
+ type Node_Access is private;
+
+ package Generic_Hash_Table_Types is
+ type Buckets_Type is array (Hash_Type range <>) of Node_Access;
+
+ type Buckets_Access is access Buckets_Type;
+
+ type Hash_Table_Type is new Ada.Finalization.Controlled with record
+ Buckets : Buckets_Access;
+ Length : Count_Type := 0;
+ end record;
+ end Generic_Hash_Table_Types;
+
+end Ada.Containers.Hash_Tables;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_VECTORS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+ type Index_Type is range <>;
+
+ type Element_Type (<>) is private;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Vectors is
+pragma Preelaborate (Indefinite_Vectors);
+
+ subtype Extended_Index is Index_Type'Base
+ range Index_Type'First - 1 ..
+ Index_Type'Last +
+ Boolean'Pos (Index_Type'Base'Last > Index_Type'Last);
+
+ No_Index : constant Extended_Index := Extended_Index'First;
+
+ subtype Index_Subtype is Index_Type;
+
+ type Vector is tagged private;
+
+ type Cursor is private;
+
+ Empty_Vector : constant Vector;
+
+ No_Element : constant Cursor;
+
+ function To_Vector (Length : Count_Type) return Vector;
+
+ function To_Vector
+ (New_Item : Element_Type;
+ Length : Count_Type) return Vector;
+
+ function "&" (Left, Right : Vector) return Vector;
+
+ function "&" (Left : Vector; Right : Element_Type) return Vector;
+
+ function "&" (Left : Element_Type; Right : Vector) return Vector;
+
+ function "&" (Left, Right : Element_Type) return Vector;
+
+ function "=" (Left, Right : Vector) return Boolean;
+
+ function Capacity (Container : Vector) return Count_Type;
+
+ procedure Reserve_Capacity
+ (Container : in out Vector;
+ Capacity : Count_Type);
+
+ function Length (Container : Vector) return Count_Type;
+
+ function Is_Empty (Container : Vector) return Boolean;
+
+ procedure Clear (Container : in out Vector);
+
+ function To_Cursor
+ (Container : Vector;
+ Index : Extended_Index) return Cursor;
+
+ function To_Index (Position : Cursor) return Extended_Index;
+
+ function Element
+ (Container : Vector;
+ Index : Index_Type) return Element_Type;
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Replace_Element
+ (Container : Vector;
+ Index : Index_Type;
+ By : Element_Type);
+
+ procedure Replace_Element
+ (Position : Cursor;
+ By : Element_Type);
+
+ procedure Assign (Target : in out Vector; Source : Vector);
+
+ procedure Move (Target : in out Vector; Source : in out Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector;
+ Position : out Cursor);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Prepend
+ (Container : in out Vector;
+ New_Item : Vector);
+
+ procedure Prepend
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Vector);
+
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1);
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Set_Length
+ (Container : in out Vector;
+ Length : Count_Type);
+
+ procedure Delete
+ (Container : in out Vector;
+ Index : Extended_Index; -- TODO: verify
+ Count : Count_Type := 1);
+
+ procedure Delete
+ (Container : in out Vector;
+ Position : in out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete_First
+ (Container : in out Vector;
+ Count : Count_Type := 1);
+
+ procedure Delete_Last
+ (Container : in out Vector;
+ Count : Count_Type := 1);
+
+ function First_Index (Container : Vector) return Index_Type;
+
+ function First (Container : Vector) return Cursor;
+
+ function First_Element (Container : Vector) return Element_Type;
+
+ function Last_Index (Container : Vector) return Extended_Index;
+
+ function Last (Container : Vector) return Cursor;
+
+ function Last_Element (Container : Vector) return Element_Type;
+
+ procedure Swap (Container : Vector; I, J : Index_Type);
+
+ procedure Swap (I, J : Cursor);
+
+ generic
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ procedure Generic_Sort (Container : Vector);
+
+ function Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'First) return Extended_Index;
+
+ function Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Reverse_Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'Last) return Extended_Index;
+
+ function Reverse_Find (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element)
+ return Cursor;
+
+ function Contains
+ (Container : Vector;
+ Item : Element_Type) return Boolean;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Vector;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Vector;
+ Process : not null access procedure (Position : Cursor));
+
+private
+
+ pragma Inline (First_Index);
+ pragma Inline (Last_Index);
+ pragma Inline (Element);
+ pragma Inline (First_Element);
+ pragma Inline (Last_Element);
+ pragma Inline (Query_Element);
+ pragma Inline (Update_Element);
+ pragma Inline (Replace_Element);
+ pragma Inline (Contains);
+
+ type Element_Access is access Element_Type;
+
+ type Elements_Type is array (Index_Type range <>) of Element_Access;
+
+ function "=" (L, R : Elements_Type) return Boolean is abstract;
+
+ type Elements_Access is access Elements_Type;
+
+ use Ada.Finalization;
+
+ type Vector is new Controlled with record
+ Elements : Elements_Access;
+ Last : Extended_Index := No_Index;
+ end record;
+
+ procedure Adjust (Container : in out Vector);
+
+ procedure Finalize (Container : in out Vector);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Vector);
+
+ for Vector'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Vector);
+
+ for Vector'Read use Read;
+
+ Empty_Vector : constant Vector := Vector'(Controlled with null, No_Index);
+
+ type Vector_Access is access constant Vector;
+ for Vector_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Vector_Access;
+ Index : Index_Type := Index_Type'First;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, Index_Type'First);
+
+end Ada.Containers.Indefinite_Vectors;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Containers is
+pragma Pure (Containers);
+
+ type Hash_Type is mod 2**32;
+ type Count_Type is range 0 .. 2**31 - 1;
+
+end Ada.Containers;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.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 was originally 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.Vectors is
+
+ type Int is range System.Min_Int .. System.Max_Int;
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
+
+ ---------
+ -- "&" --
+ ---------
+
+ 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 : constant Elements_Access :=
+ new Elements_Type'(RE);
+
+ begin
+ 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 : constant Elements_Access :=
+ new Elements_Type'(LE);
+
+ begin
+ 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 : constant Elements_Access :=
+ new Elements_Type'(LE & RE);
+
+ begin
+ 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
+ subtype Elements_Subtype is
+ Elements_Type (Index_Type'First .. Index_Type'First);
+
+ Elements : constant Elements_Access :=
+ new Elements_Subtype'(others => Right);
+
+ begin
+ 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);
+
+ subtype ET is Elements_Type (Index_Type'First .. Last);
+
+ Elements : constant Elements_Access := new ET'(LE & Right);
+
+ begin
+ 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
+ subtype Elements_Subtype is
+ Elements_Type (Index_Type'First .. Index_Type'First);
+
+ Elements : constant Elements_Access :=
+ new Elements_Subtype'(others => Left);
+
+ begin
+ 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);
+
+ subtype ET is Elements_Type (Index_Type'First .. Last);
+
+ Elements : constant Elements_Access := new ET'(Left & RE);
+
+ begin
+ 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);
+
+ subtype ET is Elements_Type (IT);
+
+ Elements : constant Elements_Access := new ET'(Left, Right);
+
+ begin
+ return Vector'(Controlled with Elements, Elements'Last);
+ end "&";
+
+ ---------
+ -- "=" --
+ ---------
+
+ 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 J in Index_Type range Index_Type'First .. Left.Last loop
+ if Left.Elements (J) /= Right.Elements (J) then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end "=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ 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
+ X : constant Elements_Access := Container.Elements;
+ L : constant Index_Type'Base := Container.Last;
+ E : Elements_Type renames X (Index_Type'First .. L);
+ begin
+ Container.Elements := null;
+ Container.Last := Index_Type'Pred (Index_Type'First);
+ Container.Elements := new Elements_Type'(E);
+ Container.Last := L;
+ end;
+ end Adjust;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append (Container : in out Vector; New_Item : Vector) is
+ begin
+ if Is_Empty (New_Item) then
+ return;
+ end if;
+
+ 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;
+
+ Insert
+ (Container,
+ Index_Type'Succ (Container.Last),
+ New_Item,
+ Count);
+ end Append;
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign
+ (Target : in out Vector;
+ Source : 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;
+
+ Target.Elements (Index_Type'First .. Source.Last) :=
+ Source.Elements (Index_Type'First .. Source.Last);
+
+ Target.Last := Source.Last;
+ end Assign;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Vector) return Count_Type is
+ begin
+ if Container.Elements = null then
+ return 0;
+ end if;
+
+ return Container.Elements'Length;
+ end Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Vector) is
+ begin
+ Container.Last := Index_Type'Pred (Index_Type'First);
+ 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 Delete
+ (Container : in out Vector;
+ Index : Extended_Index;
+ Count : 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;
+ -- TODO: not sure whether to relax this check ???
+
+ I_As_Int : constant Int := Int (I);
+
+ Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
+
+ Count1 : constant Int'Base := Count_Type'Pos (Count);
+ Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
+
+ 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
+ E (I .. 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
+ 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;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First
+ (Container : in out Vector;
+ Count : 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;
+
+ -----------------
+ -- 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;
+
+ Index := Int'Base (Container.Last) - Int'Base (Count) + 1;
+
+ Delete (Container, Index_Type'Base (Index), Count);
+ end Delete_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));
+ end Element;
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Element (Position.Container.all, Position.Index);
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Container : in out Vector) is
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := null;
+ Container.Last := Index_Type'Pred (Index_Type'First);
+ Free (X);
+ 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)
+ then
+ raise Program_Error;
+ end if;
+
+ for J in Position.Index .. Container.Last loop
+ if Container.Elements (J) = Item then
+ return (Container'Unchecked_Access, J);
+ end if;
+ end loop;
+
+ return No_Element;
+ end Find;
+
+ ----------------
+ -- Find_Index --
+ ----------------
+
+ function Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'First) return Extended_Index is
+ begin
+ for Indx in Index .. Container.Last loop
+ if Container.Elements (Indx) = Item then
+ return Indx;
+ end if;
+ end loop;
+
+ return No_Index;
+ end Find_Index;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Vector) return Cursor is
+ begin
+ if Is_Empty (Container) then
+ return No_Element;
+ end if;
+
+ return (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_Sort --
+ ------------------
+
+ procedure Generic_Sort (Container : Vector)
+ is
+ procedure Sort is
+ new Generic_Array_Sort
+ (Index_Type => Index_Type,
+ Element_Type => Element_Type,
+ Array_Type => Elements_Type,
+ "<" => "<");
+
+ begin
+ if Container.Elements = null then
+ return;
+ end if;
+
+ Sort (Container.Elements (Index_Type'First .. Container.Last));
+ end Generic_Sort;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ 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;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ Old_Last : constant Extended_Index := Container.Last;
+
+ Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
+
+ N : constant Int := Count_Type'Pos (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 := Index_Type'Pos (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'(others => New_Item);
+ end;
+
+ Container.Last := New_Last;
+ 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 => New_Item);
+ end;
+
+ Container.Last := New_Last;
+ 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 (Before .. Index_Type'Pred (Index)) :=
+ (others => New_Item);
+
+ Dst (Index .. New_Last) :=
+ Src (Before .. Container.Last);
+
+ exception
+ when others =>
+ Free (Dst);
+ raise;
+ end;
+
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := Dst;
+ Container.Last := New_Last;
+ Free (X);
+ end;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector)
+ is
+ N : constant Count_Type := Length (New_Item);
+
+ begin
+ if N = 0 then
+ return;
+ end if;
+
+ Insert_Space (Container, Before, Count => N);
+
+ 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);
+
+ begin
+ if Container'Address = New_Item'Address 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);
+
+ Index_As_Int : constant Int'Base :=
+ Int (Before) + Src'Length - 1;
+
+ Index : constant Index_Type'Base :=
+ Index_Type'Base (Index_As_Int);
+
+ Dst : Elements_Type renames
+ Container.Elements (Before .. Index);
+
+ begin
+ Dst := Src;
+ 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);
+
+ Index_As_Int : constant Int'Base :=
+ Dst_Last_As_Int - Src'Length + 1;
+
+ Index : constant Index_Type'Base :=
+ Index_Type'Base (Index_As_Int);
+
+ Dst : Elements_Type renames
+ Container.Elements (Index .. Dst_Last);
+
+ begin
+ Dst := Src;
+ end;
+
+ else
+ Container.Elements (Before .. Dst_Last) :=
+ New_Item.Elements (Index_Type'First .. New_Item.Last);
+ end if;
+ end;
+ end Insert;
+
+ 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 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 : Cursor;
+ New_Item : 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 := 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;
+
+ 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 : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : 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 := Cursor'(Container'Unchecked_Access, Index);
+ end Insert;
+
+ ------------------
+ -- Insert_Space --
+ ------------------
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ Old_Last : constant Extended_Index := Container.Last;
+
+ Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
+
+ N : constant Int := Count_Type'Pos (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 := Index_Type'Pos (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
+ Container.Elements :=
+ new Elements_Type (Index_Type'First .. New_Last);
+
+ Container.Last := New_Last;
+ 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);
+ end;
+
+ Container.Last := New_Last;
+ 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);
+
+ exception
+ when others =>
+ Free (Dst);
+ raise;
+ end;
+
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := Dst;
+ Container.Last := New_Last;
+
+ Free (X);
+ end;
+ end Insert_Space;
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ Index : Index_Type'Base;
+
+ begin
+ if 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 := Cursor'(Container'Unchecked_Access, Index);
+ end Insert_Space;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Vector) return Boolean is
+ begin
+ return Container.Last < Index_Type'First;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Vector;
+ Process : not null access procedure (Position : Cursor))
+ is
+ begin
+ for Indx in Index_Type'First .. Container.Last loop
+ Process (Cursor'(Container'Unchecked_Access, Indx));
+ end loop;
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ 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;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Vector) return Element_Type is
+ begin
+ return Element (Container, Container.Last);
+ end Last_Element;
+
+ ----------------
+ -- Last_Index --
+ ----------------
+
+ function Last_Index (Container : Vector) return Extended_Index is
+ begin
+ return Container.Last;
+ end Last_Index;
+
+ ------------
+ -- Length --
+ ------------
+
+ 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;
+
+ ----------
+ -- Move --
+ ----------
+
+ 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);
+
+ Target.Elements := Source.Elements;
+ Target.Last := Source.Last;
+
+ Source.Elements := null;
+ Source.Last := Index_Type'Pred (Index_Type'First);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ 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;
+
+ ----------
+ -- Next --
+ ----------
+
+ 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;
+
+ -------------
+ -- Prepend --
+ -------------
+
+ procedure Prepend (Container : in out Vector; New_Item : Vector) is
+ begin
+ Insert (Container, Index_Type'First, New_Item);
+ end Prepend;
+
+ procedure Prepend
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ begin
+ Insert (Container,
+ Index_Type'First,
+ New_Item,
+ Count);
+ end Prepend;
+
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (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 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;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
+ begin
+ Process (Container.Elements (T'(Index)));
+ end Query_Element;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ Container : Vector renames Position.Container.all;
+
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
+
+ begin
+ Process (Container.Elements (T'(Position.Index)));
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ 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);
+
+ begin
+ Clear (Container);
+
+ Count_Type'Base'Read (Stream, Length);
+
+ if Length > Capacity (Container) then
+ Reserve_Capacity (Container, Capacity => Length);
+ end if;
+
+ for J in Count_Type range 1 .. Length loop
+ Last := Index_Type'Succ (Last);
+ Element_Type'Read (Stream, Container.Elements (Last));
+ Container.Last := Last;
+ end loop;
+ end Read;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ 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
+ Container.Elements (T'(Index)) := By;
+ end Replace_Element;
+
+ procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Position.Container.Last;
+ begin
+ Position.Container.Elements (T'(Position.Index)) := By;
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ 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
+ 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);
+
+ E : Elements_Access := new Array_Subtype;
+
+ begin
+ declare
+ Src : Elements_Type renames
+ Container.Elements (Index_Type'First .. Container.Last);
+
+ Tgt : Elements_Type renames
+ E (Index_Type'First .. Container.Last);
+
+ begin
+ Tgt := Src;
+
+ exception
+ when others =>
+ Free (E);
+ raise;
+ end;
+
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := E;
+ Free (X);
+ end;
+ end;
+ end Reserve_Capacity;
+
+ ------------------
+ -- Reverse_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 Indx in reverse Index_Type'First .. Last loop
+ if Container.Elements (Indx) = Item then
+ return (Container'Unchecked_Access, Indx);
+ end if;
+ end loop;
+
+ return No_Element;
+ end Reverse_Find;
+
+ ------------------------
+ -- Reverse_Find_Index --
+ ------------------------
+
+ function Reverse_Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'Last) return Extended_Index
+ is
+ Last : Index_Type'Base;
+
+ begin
+ if Index > Container.Last then
+ Last := Container.Last;
+ else
+ Last := Index;
+ end if;
+
+ for Indx in reverse Index_Type'First .. Last loop
+ if Container.Elements (Indx) = Item then
+ return Indx;
+ end if;
+ end loop;
+
+ return No_Index;
+ end Reverse_Find_Index;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Vector;
+ Process : not null access procedure (Position : Cursor))
+ is
+ begin
+ for Indx in reverse Index_Type'First .. Container.Last loop
+ Process (Cursor'(Container'Unchecked_Access, Indx));
+ end loop;
+ end Reverse_Iterate;
+
+ ----------------
+ -- Set_Length --
+ ----------------
+
+ procedure Set_Length (Container : in out Vector; Length : Count_Type) is
+ begin
+ 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 > Capacity (Container) then
+ Reserve_Capacity (Container, Capacity => Length);
+ end if;
+
+ Container.Last := Last;
+ end;
+ end Set_Length;
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap
+ (Container : Vector;
+ I, J : Index_Type)
+ is
+
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
+
+ EI : constant Element_Type := Container.Elements (T'(I));
+
+ begin
+
+ Container.Elements (T'(I)) := Container.Elements (T'(J));
+ Container.Elements (T'(J)) := EI;
+
+ end Swap;
+
+ procedure Swap (I, J : Cursor) is
+
+ -- NOTE: The behavior has been liberalized here to
+ -- allow I and J to designate different containers.
+ -- TODO: Probably this is supposed to raise P_E ???
+
+ subtype TI is Index_Type'Base range
+ Index_Type'First .. I.Container.Last;
+
+ EI : Element_Type renames I.Container.Elements (TI'(I.Index));
+
+ EI_Copy : constant Element_Type := EI;
+
+ subtype TJ is Index_Type'Base range
+ Index_Type'First .. J.Container.Last;
+
+ EJ : Element_Type renames J.Container.Elements (TJ'(J.Index));
+
+ begin
+ EI := EJ;
+ EJ := EI_Copy;
+ end Swap;
+
+ ---------------
+ -- To_Cursor --
+ ---------------
+
+ 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;
+
+ --------------
+ -- To_Index --
+ --------------
+
+ 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;
+
+ ---------------
+ -- To_Vector --
+ ---------------
+
+ 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 : constant Elements_Access :=
+ new Elements_Type'
+ (Index_Type'First .. Last => New_Item);
+ begin
+ return (Controlled with Elements, Last);
+ end;
+ end To_Vector;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ 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;
+ begin
+ Process (Container.Elements (T'(Index)));
+ end Update_Element;
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Position.Container.Last;
+ begin
+ Process (Position.Container.Elements (T'(Position.Index)));
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Vector)
+ is
+ begin
+ Count_Type'Base'Write (Stream, Length (Container));
+
+ for J in Index_Type'First .. Container.Last loop
+ Element_Type'Write (Stream, Container.Elements (J));
+ end loop;
+ end Write;
+
+end Ada.Containers.Vectors;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.VECTORS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+ type Index_Type is range <>;
+ type Element_Type is private;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Vectors is
+pragma Preelaborate (Vectors);
+
+ subtype Extended_Index is Index_Type'Base
+ range Index_Type'First - 1 ..
+ Index_Type'Last +
+ Boolean'Pos (Index_Type'Base'Last > Index_Type'Last);
+
+ No_Index : constant Extended_Index := Extended_Index'First;
+
+ subtype Index_Subtype is Index_Type;
+
+ type Vector is tagged private;
+
+ type Cursor is private;
+
+ Empty_Vector : constant Vector;
+
+ No_Element : constant Cursor;
+
+ function To_Vector (Length : Count_Type) return Vector;
+
+ function To_Vector
+ (New_Item : Element_Type;
+ Length : Count_Type) return Vector;
+
+ function "&" (Left, Right : Vector) return Vector;
+
+ function "&" (Left : Vector; Right : Element_Type) return Vector;
+
+ function "&" (Left : Element_Type; Right : Vector) return Vector;
+
+ function "&" (Left, Right : Element_Type) return Vector;
+
+ function "=" (Left, Right : Vector) return Boolean;
+
+ function Capacity (Container : Vector) return Count_Type;
+
+ procedure Reserve_Capacity
+ (Container : in out Vector;
+ Capacity : Count_Type);
+
+ function Length (Container : Vector) return Count_Type;
+
+ function Is_Empty (Container : Vector) return Boolean;
+
+ procedure Clear (Container : in out Vector);
+
+ function To_Cursor
+ (Container : Vector;
+ Index : Extended_Index) return Cursor;
+
+ function To_Index (Position : Cursor) return Extended_Index;
+
+ function Element
+ (Container : Vector;
+ Index : Index_Type) return Element_Type;
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Replace_Element
+ (Container : Vector;
+ Index : Index_Type;
+ By : Element_Type);
+
+ procedure Replace_Element (Position : Cursor; By : Element_Type);
+
+ procedure Assign (Target : in out Vector; Source : Vector);
+
+ procedure Move (Target : in out Vector; Source : in out Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector;
+ Position : out Cursor);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Prepend
+ (Container : in out Vector;
+ New_Item : Vector);
+
+ procedure Prepend
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Vector);
+
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1);
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Set_Length
+ (Container : in out Vector;
+ Length : Count_Type);
+
+ procedure Delete
+ (Container : in out Vector;
+ Index : Extended_Index; -- TODO: verify
+ Count : Count_Type := 1);
+
+ procedure Delete
+ (Container : in out Vector;
+ Position : in out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete_First
+ (Container : in out Vector;
+ Count : Count_Type := 1);
+
+ procedure Delete_Last
+ (Container : in out Vector;
+ Count : Count_Type := 1);
+
+ function First_Index (Container : Vector) return Index_Type;
+
+ function First (Container : Vector) return Cursor;
+
+ function First_Element (Container : Vector) return Element_Type;
+
+ function Last_Index (Container : Vector) return Extended_Index;
+
+ function Last (Container : Vector) return Cursor;
+
+ function Last_Element (Container : Vector) return Element_Type;
+
+ procedure Swap (Container : Vector; I, J : Index_Type);
+
+ procedure Swap (I, J : Cursor);
+
+ generic
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ procedure Generic_Sort (Container : Vector);
+
+ function Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'First) return Extended_Index;
+
+ function Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Reverse_Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'Last) return Extended_Index;
+
+ function Reverse_Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Contains
+ (Container : Vector;
+ Item : Element_Type) return Boolean;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Vector;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Vector;
+ Process : not null access procedure (Position : Cursor));
+
+private
+
+ pragma Inline (First_Index);
+ pragma Inline (Last_Index);
+ pragma Inline (Element);
+ pragma Inline (First_Element);
+ pragma Inline (Last_Element);
+ pragma Inline (Query_Element);
+ pragma Inline (Update_Element);
+ pragma Inline (Replace_Element);
+ pragma Inline (Contains);
+
+ type Elements_Type is array (Index_Type range <>) of Element_Type;
+
+ function "=" (L, R : Elements_Type) return Boolean is abstract;
+
+ type Elements_Access is access Elements_Type;
+
+ use Ada.Finalization;
+
+ type Vector is new Controlled with record
+ Elements : Elements_Access;
+ Last : Extended_Index := No_Index;
+ end record;
+
+ procedure Adjust (Container : in out Vector);
+
+ procedure Finalize (Container : in out Vector);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Vector);
+
+ for Vector'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Vector);
+
+ for Vector'Read use Read;
+
+ Empty_Vector : constant Vector := (Controlled with null, No_Index);
+
+ type Vector_Access is access constant Vector;
+ for Vector_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Vector_Access;
+ Index : Index_Type := Index_Type'First;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, Index_Type'First);
+
+end Ada.Containers.Vectors;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.ORDERED_MAPS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Ada.Containers.Red_Black_Trees.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
+
+with Ada.Containers.Red_Black_Trees.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
+
+with System; use type System.Address;
+
+package body Ada.Containers.Ordered_Maps is
+
+ use Red_Black_Trees;
+
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red;
+ Key : Key_Type;
+ Element : Element_Type;
+ end record;
+
+ -----------------------------
+ -- Node Access Subprograms --
+ -----------------------------
+
+ -- These subprograms provide a functional interface to access fields
+ -- of a node, and a procedural interface for modifying these values.
+
+ function Color (Node : Node_Access) return Color_Type;
+ pragma Inline (Color);
+
+ function Left (Node : Node_Access) return Node_Access;
+ pragma Inline (Left);
+
+ function Parent (Node : Node_Access) return Node_Access;
+ pragma Inline (Parent);
+
+ function Right (Node : Node_Access) return Node_Access;
+ pragma Inline (Right);
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
+ pragma Inline (Set_Parent);
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access);
+ pragma Inline (Set_Left);
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access);
+ pragma Inline (Set_Right);
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type);
+ pragma Inline (Set_Color);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access;
+
+ procedure Delete_Tree (X : in out Node_Access);
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equal_Node_Node);
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Key_Node);
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Key_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ package Tree_Operations is
+ new Red_Black_Trees.Generic_Operations
+ (Tree_Types => Tree_Types,
+ Null_Node => Node_Access'(null));
+
+ use Tree_Operations;
+
+ package Key_Ops is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Key_Type,
+ Is_Less_Key_Node => Is_Less_Key_Node,
+ Is_Greater_Key_Node => Is_Greater_Key_Node);
+
+ function Is_Equal is
+ new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Cursor) return Boolean is
+ begin
+ return Left.Node.Key < Right.Node.Key;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Left.Node.Key < Right;
+ end "<";
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Key;
+ end "<";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Map) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ return Is_Equal (Left.Tree, Right.Tree);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Cursor) return Boolean is
+ begin
+ return Right.Node.Key < Left.Node.Key;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right < Left.Node.Key;
+ end ">";
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Right.Node.Key < Left;
+ end ">";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Map) is
+ Tree : Tree_Type renames Container.Tree;
+
+ N : constant Count_Type := Tree.Length;
+ X : constant Node_Access := Tree.Root;
+
+ begin
+ if N = 0 then
+ pragma Assert (X = null);
+ return;
+ end if;
+
+ Tree := (Length => 0, others => null);
+
+ Tree.Root := Copy_Tree (X);
+ Tree.First := Min (Tree.Root);
+ Tree.Last := Max (Tree.Root);
+ Tree.Length := N;
+ end Adjust;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Map) is
+ Tree : Tree_Type renames Container.Tree;
+ Root : Node_Access := Tree.Root;
+ begin
+ Tree := (Length => 0, others => null);
+ Delete_Tree (Root);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Access) return Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access is
+ Target : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Source.Color,
+ Key => Source.Key,
+ Element => Source.Element);
+ begin
+ return Target;
+ end Copy_Node;
+
+ ---------------
+ -- Copy_Tree --
+ ---------------
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access is
+ Target_Root : Node_Access := Copy_Node (Source_Root);
+ P, X : Node_Access;
+
+ begin
+ if Source_Root.Right /= null then
+ Target_Root.Right := Copy_Tree (Source_Root.Right);
+ Target_Root.Right.Parent := Target_Root;
+ end if;
+
+ P := Target_Root;
+ X := Source_Root.Left;
+
+ while X /= null loop
+ declare
+ Y : Node_Access := Copy_Node (X);
+
+ begin
+ P.Left := Y;
+ Y.Parent := P;
+
+ if X.Right /= null then
+ Y.Right := Copy_Tree (X.Right);
+ Y.Right.Parent := Y;
+ end if;
+
+ P := Y;
+ X := X.Left;
+ end;
+ end loop;
+
+ return Target_Root;
+
+ exception
+ when others =>
+ Delete_Tree (Target_Root);
+ raise;
+ end Copy_Tree;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Map; Position : in out Cursor) is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Map_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+ end Delete;
+
+ procedure Delete (Container : in out Map; Key : Key_Type) is
+ X : Node_Access := Key_Ops.Find (Container.Tree, Key);
+
+ begin
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Map) is
+ Position : Cursor := First (Container);
+ begin
+ Delete (Container, Position);
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Map) is
+ Position : Cursor := Last (Container);
+ begin
+ Delete (Container, Position);
+ end Delete_Last;
+
+
+ -----------------
+ -- Delete_Tree --
+ -----------------
+
+ procedure Delete_Tree (X : in out Node_Access) is
+ Y : Node_Access;
+ begin
+ while X /= null loop
+ Y := X.Right;
+ Delete_Tree (Y);
+ Y := X.Left;
+ Free (X);
+ X := Y;
+ end loop;
+ end Delete_Tree;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element;
+ end Element;
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type is
+ Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
+ begin
+ return Node.Element;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Map; Key : Key_Type) is
+ X : Node_Access := Key_Ops.Find (Container.Tree, Key);
+
+ begin
+ if X /= null then
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Map) return Cursor is
+ begin
+ if Container.Tree.First = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Map) return Element_Type is
+ begin
+ return Container.Tree.First.Element;
+ end First_Element;
+
+ ---------------
+ -- First_Key --
+ ---------------
+
+ function First_Key (Container : Map) return Key_Type is
+ begin
+ return Container.Tree.First.Key;
+ end First_Key;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ Position.Node.Key := Key;
+ Position.Node.Element := New_Item;
+ end if;
+ end Include;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Ops.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Key_Ops.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Red,
+ Key => Key,
+ Element => New_Item);
+ begin
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container.Tree,
+ Key,
+ Position.Node,
+ Inserted);
+
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+ end Insert;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Ops.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Key_Ops.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ begin
+ Node.Key := Key;
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end;
+
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container.Tree,
+ Key,
+ Position.Node,
+ Inserted);
+
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Map) return Boolean is
+ begin
+ return Container.Tree.Length = 0;
+ end Is_Empty;
+
+ ------------------------
+ -- Is_Equal_Node_Node --
+ ------------------------
+
+ function Is_Equal_Node_Node
+ (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element = R.Element;
+ end Is_Equal_Node_Node;
+
+ -------------------------
+ -- Is_Greater_Key_Node --
+ -------------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ -- k > node same as node < k
+
+ return Right.Key < Left;
+ end Is_Greater_Key_Node;
+
+ ----------------------
+ -- Is_Less_Key_Node --
+ ----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ return Left < Right.Key;
+ end Is_Less_Key_Node;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree);
+ end Iterate;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Position.Node.Key;
+ end Key;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Map) return Cursor is
+ begin
+ if Container.Tree.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Map) return Element_Type is
+ begin
+ return Container.Tree.Last.Element;
+ end Last_Element;
+
+ --------------
+ -- Last_Key --
+ --------------
+
+ function Last_Key (Container : Map) return Key_Type is
+ begin
+ return Container.Tree.Last.Key;
+ end Last_Key;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Left;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Map) return Count_Type is
+ begin
+ return Container.Tree.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Map; Source : in out Map) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Move (Target => Target.Tree, Source => Source.Tree);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Next (Position.Node);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Parent;
+ end Parent;
+
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ Position := Previous (Position);
+ end Previous;
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Previous (Position.Node);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ Process (Position.Node.Key, Position.Node.Element);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Map)
+ is
+ N : Count_Type'Base;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ begin
+ Key_Type'Read (Stream, Node.Key);
+ Element_Type'Read (Stream, Node.Element);
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end;
+
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Read
+
+ begin
+ Clear (Container);
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+
+ Local_Read (Container.Tree, N);
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
+ Node.Key := Key;
+ Node.Element := New_Item;
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ begin
+ Position.Node.Element := By;
+ end Replace_Element;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree);
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Right;
+ end Right;
+
+ ---------------
+ -- Set_Color --
+ ---------------
+
+ procedure Set_Color
+ (Node : Node_Access;
+ Color : Color_Type)
+ is
+ begin
+ Node.Color := Color;
+ end Set_Color;
+
+ --------------
+ -- Set_Left --
+ --------------
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access) is
+ begin
+ Node.Left := Left;
+ end Set_Left;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
+ begin
+ Node.Parent := Parent;
+ end Set_Parent;
+
+
+ ---------------
+ -- Set_Right --
+ ---------------
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access) is
+ begin
+ Node.Right := Right;
+ end Set_Right;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ Process (Position.Node.Key, Position.Node.Element);
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Map)
+ is
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Key_Type'Write (Stream, Node.Key);
+ Element_Type'Write (Stream, Node.Element);
+ end Process;
+
+ -- Start of processing for Write
+
+ begin
+ Count_Type'Base'Write (Stream, Container.Tree.Length);
+ Iterate (Container.Tree);
+ end Write;
+
+end Ada.Containers.Ordered_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.ORDERED_MAPS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees;
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+
+ type Key_Type is private;
+
+ type Element_Type is private;
+
+ with function "<" (Left, Right : Key_Type) return Boolean is <>;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Ordered_Maps is
+pragma Preelaborate (Ordered_Maps);
+
+ type Map is tagged private;
+
+ type Cursor is private;
+
+ Empty_Map : constant Map;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Map) return Boolean;
+
+ function Length (Container : Map) return Count_Type;
+
+ function Is_Empty (Container : Map) return Boolean;
+
+ procedure Clear (Container : in out Map);
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type));
+
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : in out Element_Type));
+
+ procedure Replace_Element (Position : Cursor; By : in Element_Type);
+
+ procedure Move (Target : in out Map; Source : in out Map);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Delete (Container : in out Map; Key : Key_Type);
+
+ procedure Exclude (Container : in out Map; Key : Key_Type);
+
+ procedure Delete (Container : in out Map; Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Map);
+
+ procedure Delete_Last (Container : in out Map);
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean;
+
+ function Find (Container : Map; Key : Key_Type) return Cursor;
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type;
+
+ function Floor (Container : Map; Key : Key_Type) return Cursor;
+
+ function Ceiling (Container : Map; Key : Key_Type) return Cursor;
+
+ function First (Container : Map) return Cursor;
+
+ function First_Key (Container : Map) return Key_Type;
+
+ function First_Element (Container : Map) return Element_Type;
+
+ function Last (Container : Map) return Cursor;
+
+ function Last_Key (Container : Map) return Key_Type;
+
+ function Last_Element (Container : Map) return Element_Type;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function "<" (Left, Right : Cursor) return Boolean;
+
+ function ">" (Left, Right : Cursor) return Boolean;
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+
+private
+
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Map is new Controlled with record
+ Tree : Tree_Type := (Length => 0, others => null);
+ end record;
+
+ procedure Adjust (Container : in out Map);
+
+ procedure Finalize (Container : in out Map) renames Clear;
+
+ type Map_Access is access constant Map;
+ for Map_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Map_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, null);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Map);
+
+ for Map'Write use Write;
+
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Map);
+
+ for Map'Read use Read;
+
+ Empty_Map : constant Map :=
+ (Controlled with Tree => (Length => 0, others => null));
+
+end Ada.Containers.Ordered_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.ORDERED_MULTISETS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Ada.Containers.Red_Black_Trees.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
+
+with Ada.Containers.Red_Black_Trees.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
+
+with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
+
+with System; use type System.Address;
+
+package body Ada.Containers.Ordered_Multisets is
+
+ use Red_Black_Trees;
+
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red;
+ Element : Element_Type;
+ end record;
+
+ -----------------------------
+ -- Node Access Subprograms --
+ -----------------------------
+
+ -- These subprograms provide a functional interface to access fields
+ -- of a node, and a procedural interface for modifying these values.
+
+ function Color (Node : Node_Access) return Color_Type;
+ pragma Inline (Color);
+
+ function Left (Node : Node_Access) return Node_Access;
+ pragma Inline (Left);
+
+ function Parent (Node : Node_Access) return Node_Access;
+ pragma Inline (Parent);
+
+ function Right (Node : Node_Access) return Node_Access;
+ pragma Inline (Right);
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
+ pragma Inline (Set_Parent);
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access);
+ pragma Inline (Set_Left);
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access);
+ pragma Inline (Set_Right);
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type);
+ pragma Inline (Set_Color);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access;
+
+ procedure Delete_Tree (X : in out Node_Access);
+
+ procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access);
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equal_Node_Node);
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Element_Node);
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Element_Node);
+
+ function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Node_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Tree_Operations is
+ new Red_Black_Trees.Generic_Operations
+ (Tree_Types => Tree_Types,
+ Null_Node => Node_Access'(null));
+
+ use Tree_Operations;
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ function Is_Equal is
+ new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
+
+ package Element_Keys is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Element_Type,
+ Is_Less_Key_Node => Is_Less_Element_Node,
+ Is_Greater_Key_Node => Is_Greater_Element_Node);
+
+ package Set_Ops is
+ new Generic_Set_Operations
+ (Tree_Operations => Tree_Operations,
+ Insert_With_Hint => Insert_With_Hint,
+ Copy_Tree => Copy_Tree,
+ Delete_Tree => Delete_Tree,
+ Is_Less => Is_Less_Node_Node,
+ Free => Free);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Cursor) return Boolean is
+ begin
+ return Left.Node.Element < Right.Node.Element;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Element_Type)
+ return Boolean is
+ begin
+ return Left.Node.Element < Right;
+ end "<";
+
+ function "<" (Left : Element_Type; Right : Cursor)
+ return Boolean is
+ begin
+ return Left < Right.Node.Element;
+ end "<";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Set) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ return Is_Equal (Left.Tree, Right.Tree);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Cursor) return Boolean is
+ begin
+ -- L > R same as R < L
+
+ return Right.Node.Element < Left.Node.Element;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Element_Type)
+ return Boolean is
+ begin
+ return Right < Left.Node.Element;
+ end ">";
+
+ function ">" (Left : Element_Type; Right : Cursor)
+ return Boolean is
+ begin
+ return Right.Node.Element < Left;
+ end ">";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+
+ N : constant Count_Type := Tree.Length;
+ X : constant Node_Access := Tree.Root;
+
+ begin
+ if N = 0 then
+ pragma Assert (X = null);
+ return;
+ end if;
+
+ Tree := (Length => 0, others => null);
+
+ Tree.Root := Copy_Tree (X);
+ Tree.First := Min (Tree.Root);
+ Tree.Last := Max (Tree.Root);
+ Tree.Length := N;
+ end Adjust;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Ceiling (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+ Root : Node_Access := Tree.Root;
+ begin
+ Tree := (Length => 0, others => null);
+ Delete_Tree (Root);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Access) return Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access is
+ Target : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Source.Color,
+ Element => Source.Element);
+ begin
+ return Target;
+ end Copy_Node;
+
+ ---------------
+ -- Copy_Tree --
+ ---------------
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access is
+ Target_Root : Node_Access := Copy_Node (Source_Root);
+
+ P, X : Node_Access;
+
+ begin
+ if Source_Root.Right /= null then
+ Target_Root.Right := Copy_Tree (Source_Root.Right);
+ Target_Root.Right.Parent := Target_Root;
+ end if;
+
+ P := Target_Root;
+ X := Source_Root.Left;
+ while X /= null loop
+ declare
+ Y : Node_Access := Copy_Node (X);
+
+ begin
+ P.Left := Y;
+ Y.Parent := P;
+
+ if X.Right /= null then
+ Y.Right := Copy_Tree (X.Right);
+ Y.Right.Parent := Y;
+ end if;
+
+ P := Y;
+ X := X.Left;
+ end;
+ end loop;
+
+ return Target_Root;
+
+ exception
+ when others =>
+ Delete_Tree (Target_Root);
+ raise;
+ end Copy_Tree;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Item : Element_Type) is
+ Tree : Tree_Type renames Container.Tree;
+ Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
+ Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
+ X : Node_Access;
+
+ begin
+ if Node = Done then
+ raise Constraint_Error;
+ end if;
+
+ loop
+ X := Node;
+ Node := Tree_Operations.Next (Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+
+ exit when Node = Done;
+ end loop;
+ end Delete;
+
+ procedure Delete (Container : in out Set; Position : in out Cursor) is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Free (Position.Node);
+
+ Position.Container := null;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+ X : Node_Access := Tree.First;
+
+ begin
+ if X = null then
+ return;
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+ X : Node_Access := Tree.Last;
+
+ begin
+ if X = null then
+ return;
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end Delete_Last;
+
+ -----------------
+ -- Delete_Tree --
+ -----------------
+
+ procedure Delete_Tree (X : in out Node_Access) is
+ Y : Node_Access;
+ begin
+ while X /= null loop
+ Y := X.Right;
+ Delete_Tree (Y);
+ Y := X.Left;
+ Free (X);
+ X := Y;
+ end loop;
+ end Delete_Tree;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ Set_Ops.Difference (Target.Tree, Source.Tree);
+ end Difference;
+
+ function Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Difference (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Difference;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Item : Element_Type) is
+ Tree : Tree_Type renames Container.Tree;
+ Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
+ Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
+ X : Node_Access;
+ begin
+ while Node /= Done loop
+ X := Node;
+ Node := Tree_Operations.Next (Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end loop;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ begin
+ if Container.Tree.First = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Set) return Element_Type is
+ begin
+ return Container.Tree.First.Element;
+ end First_Element;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Floor (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ ------------------
+ -- Generic_Keys --
+ ------------------
+
+ package body Generic_Keys is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Key_Node);
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Key_Node);
+
+ --------------------------
+ -- Local_Instantiations --
+ --------------------------
+
+ package Key_Keys is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Key_Type,
+ Is_Less_Key_Node => Is_Less_Key_Node,
+ Is_Greater_Key_Node => Is_Greater_Key_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Element;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right > Left.Node.Element;
+ end "<";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right < Left.Node.Element;
+ end ">";
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left > Right.Node.Element;
+ end ">";
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access :=
+ Key_Keys.Ceiling (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ ----------------------------
+ -- Checked_Update_Element --
+ ----------------------------
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ declare
+ Old_Key : Key_Type renames Key (Position.Node.Element);
+
+ begin
+ Process (Position.Node.Element);
+
+ if Old_Key < Position.Node.Element
+ or else Old_Key > Position.Node.Element
+ then
+ null;
+ else
+ return;
+ end if;
+ end;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+
+ Do_Insert : declare
+ Result : Node_Access;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert is
+ new Key_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ return Position.Node;
+ end New_Node;
+
+ -- Start of processing for Do_Insert
+
+ begin
+ Insert
+ (Tree => Container.Tree,
+ Key => Key (Position.Node.Element),
+ Node => Result);
+
+ pragma Assert (Result = Position.Node);
+ end Do_Insert;
+ end Checked_Update_Element;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Key : Key_Type) is
+ Tree : Tree_Type renames Container.Tree;
+ Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
+ Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
+ X : Node_Access;
+
+ begin
+ if Node = Done then
+ raise Constraint_Error;
+ end if;
+
+ loop
+ X := Node;
+ Node := Tree_Operations.Next (Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+
+ exit when Node = Done;
+ end loop;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.Tree, Key);
+ begin
+ return Node.Element;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Key : Key_Type) is
+ Tree : Tree_Type renames Container.Tree;
+ Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
+ Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
+ X : Node_Access;
+ begin
+ while Node /= Done loop
+ X := Node;
+ Node := Tree_Operations.Next (Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end loop;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access :=
+ Key_Keys.Floor (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ -------------------------
+ -- Is_Greater_Key_Node --
+ -------------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ return Left > Right.Element;
+ end Is_Greater_Key_Node;
+
+ ----------------------
+ -- Is_Less_Key_Node --
+ ----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean is
+ begin
+ return Left < Right.Element;
+ end Is_Less_Key_Node;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Key : Key_Type;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Key_Keys.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree, Key);
+ end Iterate;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Key (Position.Node.Element);
+ end Key;
+
+ -------------
+ -- Replace --
+ -------------
+
+ -- In post-madision api:???
+
+-- procedure Replace
+-- (Container : in out Set;
+-- Key : Key_Type;
+-- New_Item : Element_Type)
+-- is
+-- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+-- begin
+-- if Node = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- Replace_Node (Container, Node, New_Item);
+-- end Replace;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Key : Key_Type;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Key_Keys.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree, Key);
+ end Reverse_Iterate;
+
+ end Generic_Keys;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert (Container : in out Set; New_Item : Element_Type) is
+ Position : Cursor;
+ begin
+ Insert (Container, New_Item, Position);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Unconditional_Insert_Sans_Hint is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Red,
+ Element => New_Item);
+ begin
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Unconditional_Insert_Sans_Hint
+ (Container.Tree,
+ New_Item,
+ Position.Node);
+
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ ----------------------
+ -- Insert_With_Hint --
+ ----------------------
+
+ procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ procedure Local_Insert_With_Hint is
+ new Element_Keys.Generic_Unconditional_Insert_With_Hint
+ (Insert_Post,
+ Insert_Sans_Hint);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Red,
+ Element => Src_Node.Element);
+ begin
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Insert_With_Hint
+
+ begin
+ Local_Insert_With_Hint
+ (Dst_Tree,
+ Dst_Hint,
+ Src_Node.Element,
+ Dst_Node);
+ end Insert_With_Hint;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Intersection (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Set_Ops.Intersection (Target.Tree, Source.Tree);
+ end Intersection;
+
+ function Intersection (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Intersection (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Intersection;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.Tree.Length = 0;
+ end Is_Empty;
+
+ ------------------------
+ -- Is_Equal_Node_Node --
+ ------------------------
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element = R.Element;
+ end Is_Equal_Node_Node;
+
+ -----------------------------
+ -- Is_Greater_Element_Node --
+ -----------------------------
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ -- e > node same as node < e
+
+ return Right.Element < Left;
+ end Is_Greater_Element_Node;
+
+ --------------------------
+ -- Is_Less_Element_Node --
+ --------------------------
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ return Left < Right.Element;
+ end Is_Less_Element_Node;
+
+ -----------------------
+ -- Is_Less_Node_Node --
+ -----------------------
+
+ function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element < R.Element;
+ end Is_Less_Node_Node;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
+ begin
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
+ end Is_Subset;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree);
+ end Iterate;
+
+ procedure Iterate
+ (Container : Set;
+ Item : Element_Type;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Element_Keys.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree, Item);
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Set) return Cursor is
+ begin
+ if Container.Tree.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Set) return Element_Type is
+ begin
+ return Container.Tree.Last.Element;
+ end Last_Element;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Left;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.Tree.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Move (Target => Target.Tree, Source => Source.Tree);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Position : in out Cursor)
+ is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Next (Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Set) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return Left.Tree.Length /= 0;
+ end if;
+
+ return Set_Ops.Overlap (Left.Tree, Right.Tree);
+ end Overlap;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Parent;
+ end Parent;
+
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (Position : in out Cursor)
+ is
+ begin
+ Position := Previous (Position);
+ end Previous;
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Previous (Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ Process (Position.Node.Element);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ N : Count_Type'Base;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ begin
+ Element_Type'Read (Stream, Node.Element);
+
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end;
+
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Read
+
+ begin
+ Clear (Container);
+
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+
+ Local_Read (Container.Tree, N);
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ -- NOTE: from post-madison api ???
+
+-- procedure Replace
+-- (Container : in out Set;
+-- Position : Cursor;
+-- By : Element_Type)
+-- is
+-- begin
+-- if Position.Container = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+-- raise Program_Error;
+-- end if;
+
+-- Replace_Node (Container, Position.Node, By);
+-- end Replace;
+
+ ------------------
+ -- Replace_Node --
+ ------------------
+
+ -- NOTE: from post-madison api ???
+
+-- procedure Replace_Node
+-- (Container : in out Set;
+-- Position : Node_Access;
+-- By : Element_Type)
+-- is
+-- Tree : Tree_Type renames Container.Tree;
+-- Node : Node_Access := Position;
+
+-- begin
+-- if By < Node.Element
+-- or else Node.Element < By
+-- then
+-- null;
+
+-- else
+-- begin
+-- Node.Element := By;
+
+-- exception
+-- when others =>
+-- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
+-- Free (Node);
+-- raise;
+-- end;
+
+-- return;
+-- end if;
+
+-- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
+
+-- begin
+-- Node.Element := By;
+
+-- exception
+-- when others =>
+-- Free (Node);
+-- raise;
+-- end;
+--
+-- Do_Insert : declare
+-- Result : Node_Access;
+-- Success : Boolean;
+
+-- function New_Node return Node_Access;
+-- pragma Inline (New_Node);
+
+-- procedure Insert_Post is
+-- new Element_Keys.Generic_Insert_Post (New_Node);
+--
+-- procedure Insert is
+-- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+-- --------------
+-- -- New_Node --
+-- --------------
+
+-- function New_Node return Node_Access is
+-- begin
+-- return Node;
+-- end New_Node;
+
+-- -- Start of processing for Do_Insert
+
+-- begin
+-- Insert
+-- (Tree => Tree,
+-- Key => Node.Element,
+-- Node => Result,
+-- Success => Success);
+--
+-- if not Success then
+-- Free (Node);
+-- raise Program_Error;
+-- end if;
+--
+-- pragma Assert (Result = Node);
+-- end Do_Insert;
+-- end Replace_Node;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree);
+ end Reverse_Iterate;
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Item : Element_Type;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Element_Keys.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree, Item);
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Right;
+ end Right;
+
+ ---------------
+ -- Set_Color --
+ ---------------
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type) is
+ begin
+ Node.Color := Color;
+ end Set_Color;
+
+ --------------
+ -- Set_Left --
+ --------------
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access) is
+ begin
+ Node.Left := Left;
+ end Set_Left;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
+ begin
+ Node.Parent := Parent;
+ end Set_Parent;
+
+ ---------------
+ -- Set_Right --
+ ---------------
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access) is
+ begin
+ Node.Right := Right;
+ end Set_Right;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
+ end Symmetric_Difference;
+
+ function Symmetric_Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Symmetric_Difference;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Set_Ops.Union (Target.Tree, Source.Tree);
+ end Union;
+
+ function Union (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Union (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Union;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Set)
+ is
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is
+ new Tree_Operations.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Element_Type'Write (Stream, Node.Element);
+ end Process;
+
+ -- Start of processing for Write
+
+ begin
+ Count_Type'Base'Write (Stream, Container.Tree.Length);
+ Iterate (Container.Tree);
+ end Write;
+
+end Ada.Containers.Ordered_Multisets;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.ORDERED_MULTISETS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees;
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+ type Element_Type is private;
+
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Ordered_Multisets is
+pragma Preelaborate (Ordered_Multisets);
+
+ type Set is tagged private;
+
+ type Cursor is private;
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Move
+ (Target : in out Set;
+ Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Set);
+
+ procedure Delete_Last (Container : in out Set);
+
+ -- NOTE: The following operation is named Replace in the Madison API.
+ -- However, it should be named Replace_Element. ???
+ --
+ -- procedure Replace
+ -- (Container : in out Set;
+ -- Position : Cursor;
+ -- By : Element_Type);
+
+ procedure Union (Target : in out Set; Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set; Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Find (Container : Set; Item : Element_Type) return Cursor;
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor;
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor;
+
+ function First (Container : Set) return Cursor;
+
+ function First_Element (Container : Set) return Element_Type;
+
+ function Last (Container : Set) return Cursor;
+
+ function Last_Element (Container : Set) return Element_Type;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function "<" (Left, Right : Cursor) return Boolean;
+
+ function ">" (Left, Right : Cursor) return Boolean;
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Iterate
+ (Container : Set;
+ Item : Element_Type;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Item : Element_Type;
+ Process : not null access procedure (Position : Cursor));
+
+ generic
+ type Key_Type (<>) is limited private;
+
+ with function Key (Element : Element_Type) return Key_Type;
+
+ with function "<" (Left : Key_Type; Right : Element_Type)
+ return Boolean is <>;
+
+ with function ">" (Left : Key_Type; Right : Element_Type)
+ return Boolean is <>;
+
+ package Generic_Keys is
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor;
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+
+ -- NOTE: in post-madison api ???
+ -- procedure Replace
+ -- (Container : in out Set;
+ -- Key : Key_Type;
+ -- New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ -- Should name of following be "Update_Element" ???
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ procedure Iterate
+ (Container : Set;
+ Key : Key_Type;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Key : Key_Type;
+ Process : not null access procedure (Position : Cursor));
+
+ end Generic_Keys;
+
+private
+
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Set is new Controlled with record
+ Tree : Tree_Type := (Length => 0, others => null);
+ end record;
+
+ procedure Adjust (Container : in out Set);
+
+ procedure Finalize (Container : in out Set) renames Clear;
+
+ type Set_Access is access constant Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, null);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set :=
+ (Controlled with Tree => (Length => 0, others => null));
+
+end Ada.Containers.Ordered_Multisets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.ORDERED_SETS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Ada.Containers.Red_Black_Trees.Generic_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
+
+with Ada.Containers.Red_Black_Trees.Generic_Keys;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
+
+with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
+
+with System; use type System.Address;
+
+package body Ada.Containers.Ordered_Sets is
+
+ use Red_Black_Trees;
+
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red;
+ Element : Element_Type;
+ end record;
+
+ ------------------------------
+ -- Access to Fields of Node --
+ ------------------------------
+
+ -- These subprograms provide functional notation for access to fields
+ -- of a node, and procedural notation for modifiying these fields.
+
+ function Color (Node : Node_Access) return Color_Type;
+ pragma Inline (Color);
+
+ function Left (Node : Node_Access) return Node_Access;
+ pragma Inline (Left);
+
+ function Parent (Node : Node_Access) return Node_Access;
+ pragma Inline (Parent);
+
+ function Right (Node : Node_Access) return Node_Access;
+ pragma Inline (Right);
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type);
+ pragma Inline (Set_Color);
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access);
+ pragma Inline (Set_Left);
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access);
+ pragma Inline (Set_Right);
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
+ pragma Inline (Set_Parent);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access;
+
+ procedure Delete_Tree (X : in out Node_Access);
+
+ procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access);
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equal_Node_Node);
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Element_Node);
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Element_Node);
+
+ function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Node_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Tree_Operations is
+ new Red_Black_Trees.Generic_Operations
+ (Tree_Types => Tree_Types,
+ Null_Node => Node_Access'(null));
+
+ use Tree_Operations;
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ function Is_Equal is
+ new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
+
+ package Element_Keys is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Element_Type,
+ Is_Less_Key_Node => Is_Less_Element_Node,
+ Is_Greater_Key_Node => Is_Greater_Element_Node);
+
+ package Set_Ops is
+ new Generic_Set_Operations
+ (Tree_Operations => Tree_Operations,
+ Insert_With_Hint => Insert_With_Hint,
+ Copy_Tree => Copy_Tree,
+ Delete_Tree => Delete_Tree,
+ Is_Less => Is_Less_Node_Node,
+ Free => Free);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Cursor) return Boolean is
+ begin
+ return Left.Node.Element < Right.Node.Element;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean is
+ begin
+ return Left.Node.Element < Right;
+ end "<";
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Element;
+ end "<";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Set) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ return Is_Equal (Left.Tree, Right.Tree);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Cursor) return Boolean is
+ begin
+ -- L > R same as R < L
+
+ return Right.Node.Element < Left.Node.Element;
+ end ">";
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean is
+ begin
+ return Right.Node.Element < Left;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean is
+ begin
+ return Right < Left.Node.Element;
+ end ">";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+
+ N : constant Count_Type := Tree.Length;
+ X : constant Node_Access := Tree.Root;
+
+ begin
+ if N = 0 then
+ pragma Assert (X = null);
+ return;
+ end if;
+
+ Tree := (Length => 0, others => null);
+
+ Tree.Root := Copy_Tree (X);
+ Tree.First := Min (Tree.Root);
+ Tree.Last := Max (Tree.Root);
+ Tree.Length := N;
+ end Adjust;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Ceiling (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Set) is
+ Tree : Tree_Type renames Container.Tree;
+ Root : Node_Access := Tree.Root;
+ begin
+ Tree := (Length => 0, others => null);
+ Delete_Tree (Root);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Access) return Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (Container : Set;
+ Item : Element_Type) return Boolean
+ is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ function Copy_Node (Source : Node_Access) return Node_Access is
+ Target : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Source.Color,
+ Element => Source.Element);
+ begin
+ return Target;
+ end Copy_Node;
+
+ ---------------
+ -- Copy_Tree --
+ ---------------
+
+ function Copy_Tree (Source_Root : Node_Access) return Node_Access is
+ Target_Root : Node_Access := Copy_Node (Source_Root);
+
+ P, X : Node_Access;
+
+ begin
+ if Source_Root.Right /= null then
+ Target_Root.Right := Copy_Tree (Source_Root.Right);
+ Target_Root.Right.Parent := Target_Root;
+ end if;
+
+ P := Target_Root;
+ X := Source_Root.Left;
+ while X /= null loop
+ declare
+ Y : Node_Access := Copy_Node (X);
+
+ begin
+ P.Left := Y;
+ Y.Parent := P;
+
+ if X.Right /= null then
+ Y.Right := Copy_Tree (X.Right);
+ Y.Right.Parent := Y;
+ end if;
+
+ P := Y;
+ X := X.Left;
+ end;
+ end loop;
+
+ return Target_Root;
+
+ exception
+ when others =>
+
+ Delete_Tree (Target_Root);
+ raise;
+ end Copy_Tree;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Position : in out Cursor) is
+ begin
+ if Position = No_Element then
+ return;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Free (Position.Node);
+ Position.Container := null;
+ end Delete;
+
+ procedure Delete (Container : in out Set; Item : Element_Type) is
+ X : Node_Access := Element_Keys.Find (Container.Tree, Item);
+
+ begin
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Set) is
+ C : Cursor := First (Container);
+ begin
+ Delete (Container, C);
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Set) is
+ C : Cursor := Last (Container);
+ begin
+ Delete (Container, C);
+ end Delete_Last;
+
+ -----------------
+ -- Delete_Tree --
+ -----------------
+
+ procedure Delete_Tree (X : in out Node_Access) is
+ Y : Node_Access;
+ begin
+ while X /= null loop
+ Y := X.Right;
+ Delete_Tree (Y);
+ Y := X.Left;
+ Free (X);
+ X := Y;
+ end loop;
+ end Delete_Tree;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ Set_Ops.Difference (Target.Tree, Source.Tree);
+ end Difference;
+
+ function Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Difference (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Difference;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Item : Element_Type) is
+ X : Node_Access := Element_Keys.Find (Container.Tree, Item);
+
+ begin
+ if X /= null then
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ begin
+ if Container.Tree.First = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Set) return Element_Type is
+ begin
+ return Container.Tree.First.Element;
+ end First_Element;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Node_Access :=
+ Element_Keys.Floor (Container.Tree, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ ------------------
+ -- Generic_Keys --
+ ------------------
+
+ package body Generic_Keys is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Greater_Key_Node);
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean;
+ pragma Inline (Is_Less_Key_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Key_Keys is
+ new Red_Black_Trees.Generic_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Key_Type,
+ Is_Less_Key_Node => Is_Less_Key_Node,
+ Is_Greater_Key_Node => Is_Greater_Key_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left < Right.Node.Element;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right > Left.Node.Element;
+ end "<";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ return Left > Right.Node.Element;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ return Right < Left.Node.Element;
+ end ">";
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access :=
+ Key_Keys.Ceiling (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Ceiling;
+
+ ----------------------------
+ -- Checked_Update_Element --
+ ----------------------------
+
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ declare
+ Old_Key : Key_Type renames Key (Position.Node.Element);
+
+ begin
+ Process (Position.Node.Element);
+
+ if Old_Key < Position.Node.Element
+ or else Old_Key > Position.Node.Element
+ then
+ null;
+ else
+ return;
+ end if;
+ end;
+
+ Delete_Node_Sans_Free (Container.Tree, Position.Node);
+
+ declare
+ Result : Node_Access;
+ Success : Boolean;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert_Post is
+ new Key_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Local_Conditional_Insert is
+ new Key_Keys.Generic_Conditional_Insert (Local_Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ return Position.Node;
+ end New_Node;
+
+
+ begin
+ Local_Conditional_Insert
+ (Tree => Container.Tree,
+ Key => Key (Position.Node.Element),
+ Node => Result,
+ Success => Success);
+
+ if not Success then
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ Free (X);
+ end;
+
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Result = Position.Node);
+ end;
+ end Checked_Update_Element;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Key : Key_Type) is
+ X : Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if X = null then
+ raise Constraint_Error;
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Container : Set;
+ Key : Key_Type) return Element_Type
+ is
+ Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
+ begin
+ return Node.Element;
+ end Element;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Key : Key_Type) is
+ X : Node_Access := Key_Keys.Find (Container.Tree, Key);
+ begin
+ if X /= null then
+ Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Find;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Node);
+ end Floor;
+
+ -------------------------
+ -- Is_Greater_Key_Node --
+ -------------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ return Left > Right.Element;
+ end Is_Greater_Key_Node;
+
+ ----------------------
+ -- Is_Less_Key_Node --
+ ----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ return Left < Right.Element;
+ end Is_Less_Key_Node;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Key (Position.Node.Element);
+ end Key;
+
+ -------------
+ -- Replace --
+ -------------
+
+-- TODO???
+
+-- procedure Replace
+-- (Container : in out Set;
+-- Key : Key_Type;
+-- New_Item : Element_Type)
+-- is
+-- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+-- begin
+-- if Node = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- Replace_Element (Container, Node, New_Item);
+-- end Replace;
+
+ end Generic_Keys;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include (Container : in out Set; New_Item : Element_Type) is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ Position.Node.Element := New_Item;
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Red,
+ Element => New_Item);
+ begin
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container.Tree,
+ New_Item,
+ Position.Node,
+ Inserted);
+
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+ end Insert;
+
+ ----------------------
+ -- Insert_With_Hint --
+ ----------------------
+
+ procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access)
+ is
+ Success : Boolean;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ procedure Local_Insert_With_Hint is
+ new Element_Keys.Generic_Conditional_Insert_With_Hint
+ (Insert_Post,
+ Insert_Sans_Hint);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : constant Node_Access :=
+ new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Red,
+ Element => Src_Node.Element);
+ begin
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Insert_With_Hint
+
+ begin
+ Local_Insert_With_Hint
+ (Dst_Tree,
+ Dst_Hint,
+ Src_Node.Element,
+ Dst_Node,
+ Success);
+ end Insert_With_Hint;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Intersection (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Set_Ops.Intersection (Target.Tree, Source.Tree);
+ end Intersection;
+
+ function Intersection (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Intersection (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Intersection;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Length (Container) = 0;
+ end Is_Empty;
+
+ ------------------------
+ -- Is_Equal_Node_Node --
+ ------------------------
+
+ function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element = R.Element;
+ end Is_Equal_Node_Node;
+
+ -----------------------------
+ -- Is_Greater_Element_Node --
+ -----------------------------
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ -- Compute e > node same as node < e
+
+ return Right.Element < Left;
+ end Is_Greater_Element_Node;
+
+ --------------------------
+ -- Is_Less_Element_Node --
+ --------------------------
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Access) return Boolean
+ is
+ begin
+ return Left < Right.Element;
+ end Is_Less_Element_Node;
+
+ -----------------------
+ -- Is_Less_Node_Node --
+ -----------------------
+
+ function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ return L.Element < R.Element;
+ end Is_Less_Node_Node;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
+ begin
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
+ end Is_Subset;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of prccessing for Iterate
+
+ begin
+ Local_Iterate (Container.Tree);
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Set) return Cursor is
+ begin
+ if Container.Tree.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Set) return Element_Type is
+ begin
+ return Container.Tree.Last.Element;
+ end Last_Element;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Left;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.Tree.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Move (Target => Target.Tree, Source => Source.Tree);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Next (Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Set) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return Left.Tree.Length /= 0;
+ end if;
+
+ return Set_Ops.Overlap (Left.Tree, Right.Tree);
+ end Overlap;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Parent;
+ end Parent;
+
+ --------------
+ -- Previous --
+ --------------
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ declare
+ Node : constant Node_Access :=
+ Tree_Operations.Previous (Position.Node);
+
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Previous;
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ Position := Previous (Position);
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ Process (Position.Node.Element);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ N : Count_Type'Base;
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ Node : Node_Access := new Node_Type;
+
+ begin
+ begin
+ Element_Type'Read (Stream, Node.Element);
+
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end;
+
+ return Node;
+ end New_Node;
+
+ -- Start of processing for Read
+
+ begin
+ Clear (Container);
+
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+
+ Local_Read (Container.Tree, N);
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace (Container : in out Set; New_Item : Element_Type) is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.Tree, New_Item);
+
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
+ Node.Element := New_Item;
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+-- TODO: ???
+-- procedure Replace_Element
+-- (Container : in out Set;
+-- Position : Node_Access;
+-- By : Element_Type)
+-- is
+-- Node : Node_Access := Position;
+
+-- begin
+-- if By < Node.Element
+-- or else Node.Element < By
+-- then
+-- null;
+
+-- else
+-- begin
+-- Node.Element := By;
+
+-- exception
+-- when others =>
+-- Delete_Node_Sans_Free (Container.Tree, Node);
+-- Free (Node);
+-- raise;
+-- end;
+
+-- return;
+-- end if;
+
+-- Delete_Node_Sans_Free (Container.Tree, Node);
+
+-- begin
+-- Node.Element := By;
+-- exception
+-- when others =>
+-- Free (Node);
+-- raise;
+-- end;
+
+-- declare
+-- function New_Node return Node_Access;
+-- pragma Inline (New_Node);
+
+-- function New_Node return Node_Access is
+-- begin
+-- return Node;
+-- end New_Node;
+
+-- procedure Insert_Post is
+-- new Element_Keys.Generic_Insert_Post (New_Node);
+
+-- procedure Insert is
+-- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+-- Result : Node_Access;
+-- Success : Boolean;
+
+-- begin
+-- Insert
+-- (Tree => Container.Tree,
+-- Key => Node.Element,
+-- Node => Result,
+-- Success => Success);
+
+-- if not Success then
+-- Free (Node);
+-- raise Program_Error;
+-- end if;
+
+-- pragma Assert (Result = Node);
+-- end;
+-- end Replace_Element;
+
+
+-- procedure Replace_Element
+-- (Container : in out Set;
+-- Position : Cursor;
+-- By : Element_Type)
+-- is
+-- begin
+-- if Position.Container = null then
+-- raise Constraint_Error;
+-- end if;
+
+-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+-- raise Program_Error;
+-- end if;
+
+-- Replace_Element (Container, Position.Node, By);
+-- end Replace_Element;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ end Process_Node;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ Local_Reverse_Iterate (Container.Tree);
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Right;
+ end Right;
+
+ ---------------
+ -- Set_Color --
+ ---------------
+
+ procedure Set_Color (Node : Node_Access; Color : Color_Type) is
+ begin
+ Node.Color := Color;
+ end Set_Color;
+
+ --------------
+ -- Set_Left --
+ --------------
+
+ procedure Set_Left (Node : Node_Access; Left : Node_Access) is
+ begin
+ Node.Left := Left;
+ end Set_Left;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
+ begin
+ Node.Parent := Parent;
+ end Set_Parent;
+
+ ---------------
+ -- Set_Right --
+ ---------------
+
+ procedure Set_Right (Node : Node_Access; Right : Node_Access) is
+ begin
+ Node.Right := Right;
+ end Set_Right;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
+ end Symmetric_Difference;
+
+ function Symmetric_Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ declare
+ Tree : constant Tree_Type :=
+ Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Symmetric_Difference;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union (Target : in out Set; Source : Set) is
+ begin
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Set_Ops.Union (Target.Tree, Source.Tree);
+ end Union;
+
+ function Union (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ declare
+ Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
+ begin
+ return (Controlled with Tree);
+ end;
+ end Union;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Set)
+ is
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is
+ new Tree_Operations.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Element_Type'Write (Stream, Node.Element);
+ end Process;
+
+ -- Start of processing for Write
+
+ begin
+ Count_Type'Base'Write (Stream, Container.Tree.Length);
+ Iterate (Container.Tree);
+ end Write;
+
+
+
+
+end Ada.Containers.Ordered_Sets;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.ORDERED_SETS --
+-- --
+-- S p e c --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees;
+with Ada.Finalization;
+with Ada.Streams;
+
+generic
+
+ type Element_Type is private;
+
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Ordered_Sets is
+pragma Preelaborate (Ordered_Sets);
+
+ type Set is tagged private;
+
+ type Cursor is private;
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+-- TODO: resolve in Atlanta. ???
+-- procedure Replace_Element
+-- (Container : in out Set;
+-- Position : Cursor;
+-- By : Element_Type);
+
+ procedure Move
+ (Target : in out Set;
+ Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Set);
+
+ procedure Delete_Last (Container : in out Set);
+
+ procedure Union (Target : in out Set; Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set;
+ Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Find (Container : Set; Item : Element_Type) return Cursor;
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor;
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor;
+
+ function First (Container : Set) return Cursor;
+
+ function First_Element (Container : Set) return Element_Type;
+
+ function Last (Container : Set) return Cursor;
+
+ function Last_Element (Container : Set) return Element_Type;
+
+ function Next (Position : Cursor) return Cursor;
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ procedure Previous (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function "<" (Left, Right : Cursor) return Boolean;
+
+ function ">" (Left, Right : Cursor) return Boolean;
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ generic
+ type Key_Type (<>) is limited private;
+
+ with function Key (Element : Element_Type) return Key_Type;
+
+ with function "<"
+ (Left : Key_Type;
+ Right : Element_Type) return Boolean is <>;
+
+ with function ">"
+ (Left : Key_Type;
+ Right : Element_Type) return Boolean is <>;
+
+ package Generic_Keys is
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor;
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+
+-- TODO: resolve in Atlanta ???
+-- procedure Replace
+-- (Container : in out Set;
+-- Key : Key_Type;
+-- New_Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean;
+
+-- TODO: resolve name in Atlanta. Should name be just "Update_Element" ???
+ procedure Checked_Update_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ end Generic_Keys;
+
+private
+
+ type Node_Type;
+ type Node_Access is access Node_Type;
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Set is new Controlled with record
+ Tree : Tree_Type := (Length => 0, others => null);
+ end record;
+
+ procedure Adjust (Container : in out Set);
+
+ procedure Finalize (Container : in out Set) renames Clear;
+
+ type Set_Access is access constant Set;
+
+ type Cursor is record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
+
+ No_Element : constant Cursor := Cursor'(null, null);
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set :=
+ (Controlled with Tree => (Length => 0, others => null));
+
+end Ada.Containers.Ordered_Sets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.PRIME_NUMBERS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+package body Ada.Containers.Prime_Numbers is
+
+ --------------
+ -- To_Prime --
+ --------------
+
+ function To_Prime (Length : Count_Type) return Hash_Type is
+ I, J, K : Integer'Base;
+ Index : Integer'Base;
+
+ begin
+ I := Primes'Last - Primes'First;
+ Index := Primes'First;
+ while I > 0 loop
+ J := I / 2;
+ K := Index + J;
+
+ if Primes (K) < Hash_Type (Length) then
+ Index := K + 1;
+ I := I - J - 1;
+ else
+ I := J;
+ end if;
+ end loop;
+
+ return Primes (Index);
+ end To_Prime;
+
+end Ada.Containers.Prime_Numbers;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.PRIME_NUMBERS --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Containers.Prime_Numbers is
+pragma Pure (Prime_Numbers);
+
+ type Primes_Type is array (Positive range <>) of Hash_Type;
+
+ Primes : constant Primes_Type :=
+ (53, 97, 193, 389, 769,
+ 1543, 3079, 6151, 12289, 24593,
+ 49157, 98317, 196613, 393241, 786433,
+ 1572869, 3145739, 6291469, 12582917, 25165843,
+ 50331653, 100663319, 201326611, 402653189, 805306457,
+ 1610612741, 3221225473, 4294967291);
+
+ function To_Prime (Length : Count_Type) return Hash_Type;
+
+end Ada.Containers.Prime_Numbers;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Containers.Red_Black_Trees is
+pragma Pure (Red_Black_Trees);
+
+ type Color_Type is (Red, Black);
+
+ generic
+ type Node_Access is private;
+ package Generic_Tree_Types is
+ type Tree_Type is record
+ First : Node_Access;
+ Last : Node_Access;
+ Root : Node_Access;
+ Length : Count_Type;
+ end record;
+ end Generic_Tree_Types;
+end Ada.Containers.Red_Black_Trees;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+package body Ada.Containers.Red_Black_Trees.Generic_Keys is
+
+ package Ops renames Tree_Operations;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ -- AKA Lower_Bound
+
+ function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
+ Y : Node_Access;
+ X : Node_Access := Tree.Root;
+
+ begin
+ while X /= Ops.Null_Node loop
+ if Is_Greater_Key_Node (Key, X) then
+ X := Ops.Right (X);
+ else
+ Y := X;
+ X := Ops.Left (X);
+ end if;
+ end loop;
+
+ return Y;
+ end Ceiling;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is
+ Y : Node_Access;
+ X : Node_Access := Tree.Root;
+
+ begin
+ while X /= Ops.Null_Node loop
+ if Is_Greater_Key_Node (Key, X) then
+ X := Ops.Right (X);
+ else
+ Y := X;
+ X := Ops.Left (X);
+ end if;
+ end loop;
+
+ if Y = Ops.Null_Node then
+ return Ops.Null_Node;
+ end if;
+
+ if Is_Less_Key_Node (Key, Y) then
+ return Ops.Null_Node;
+ end if;
+
+ return Y;
+ end Find;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is
+ Y : Node_Access;
+ X : Node_Access := Tree.Root;
+
+ begin
+ while X /= Ops.Null_Node loop
+ if Is_Less_Key_Node (Key, X) then
+ X := Ops.Left (X);
+ else
+ Y := X;
+ X := Ops.Right (X);
+ end if;
+ end loop;
+
+ return Y;
+ end Floor;
+
+ --------------------------------
+ -- Generic_Conditional_Insert --
+ --------------------------------
+
+ procedure Generic_Conditional_Insert
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Success : out Boolean)
+ is
+ Y : Node_Access := Ops.Null_Node;
+ X : Node_Access := Tree.Root;
+
+ begin
+ Success := True;
+ while X /= Ops.Null_Node loop
+ Y := X;
+ Success := Is_Less_Key_Node (Key, X);
+
+ if Success then
+ X := Ops.Left (X);
+ else
+ X := Ops.Right (X);
+ end if;
+ end loop;
+
+ Node := Y;
+
+ if Success then
+ if Node = Tree.First then
+ Insert_Post (Tree, X, Y, Key, Node);
+ return;
+ end if;
+
+ Node := Ops.Previous (Node);
+ end if;
+
+ if Is_Greater_Key_Node (Key, Node) then
+ Insert_Post (Tree, X, Y, Key, Node);
+ Success := True;
+ return;
+ end if;
+
+ Success := False;
+ end Generic_Conditional_Insert;
+
+ ------------------------------------------
+ -- Generic_Conditional_Insert_With_Hint --
+ ------------------------------------------
+
+ procedure Generic_Conditional_Insert_With_Hint
+ (Tree : in out Tree_Type;
+ Position : Node_Access;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Success : out Boolean)
+ is
+ begin
+ if Position = Ops.Null_Node then -- largest
+ if Tree.Length > 0
+ and then Is_Greater_Key_Node (Key, Tree.Last)
+ then
+ Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
+ Success := True;
+ else
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
+ end if;
+
+ return;
+ end if;
+
+ pragma Assert (Tree.Length > 0);
+
+ if Is_Less_Key_Node (Key, Position) then
+ if Position = Tree.First then
+ Insert_Post (Tree, Position, Position, Key, Node);
+ Success := True;
+ return;
+ end if;
+
+ declare
+ Before : constant Node_Access := Ops.Previous (Position);
+
+ begin
+ if Is_Greater_Key_Node (Key, Before) then
+ if Ops.Right (Before) = Ops.Null_Node then
+ Insert_Post (Tree, Ops.Null_Node, Before, Key, Node);
+ else
+ Insert_Post (Tree, Position, Position, Key, Node);
+ end if;
+
+ Success := True;
+
+ else
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
+ end if;
+ end;
+
+ return;
+ end if;
+
+ if Is_Greater_Key_Node (Key, Position) then
+ if Position = Tree.Last then
+ Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
+ Success := True;
+ return;
+ end if;
+
+ declare
+ After : constant Node_Access := Ops.Next (Position);
+
+ begin
+ if Is_Less_Key_Node (Key, After) then
+ if Ops.Right (Position) = Ops.Null_Node then
+ Insert_Post (Tree, Ops.Null_Node, Position, Key, Node);
+ else
+ Insert_Post (Tree, After, After, Key, Node);
+ end if;
+
+ Success := True;
+
+ else
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
+ end if;
+ end;
+
+ return;
+ end if;
+
+ Node := Position;
+ Success := False;
+ end Generic_Conditional_Insert_With_Hint;
+
+ -------------------------
+ -- Generic_Insert_Post --
+ -------------------------
+
+ procedure Generic_Insert_Post
+ (Tree : in out Tree_Type;
+ X, Y : Node_Access;
+ Key : Key_Type;
+ Z : out Node_Access)
+ is
+ subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
+
+ New_Length : constant Count_Type := Length_Subtype'(Tree.Length) + 1;
+
+ begin
+ if Y = Ops.Null_Node
+ or else X /= Ops.Null_Node
+ or else Is_Less_Key_Node (Key, Y)
+ then
+ pragma Assert (Y = Ops.Null_Node
+ or else Ops.Left (Y) = Ops.Null_Node);
+
+ -- Delay allocation as long as we can, in order to defend
+ -- against exceptions propagated by relational operators.
+
+ Z := New_Node;
+
+ pragma Assert (Z /= Ops.Null_Node);
+ pragma Assert (Ops.Color (Z) = Red);
+
+ if Y = Ops.Null_Node then
+ pragma Assert (Tree.Length = 0);
+ pragma Assert (Tree.Root = Ops.Null_Node);
+ pragma Assert (Tree.First = Ops.Null_Node);
+ pragma Assert (Tree.Last = Ops.Null_Node);
+
+ Tree.Root := Z;
+ Tree.First := Z;
+ Tree.Last := Z;
+
+ else
+ Ops.Set_Left (Y, Z);
+
+ if Y = Tree.First then
+ Tree.First := Z;
+ end if;
+ end if;
+
+ else
+ pragma Assert (Ops.Right (Y) = Ops.Null_Node);
+
+ -- Delay allocation as long as we can, in order to defend
+ -- against exceptions propagated by relational operators.
+
+ Z := New_Node;
+
+ pragma Assert (Z /= Ops.Null_Node);
+ pragma Assert (Ops.Color (Z) = Red);
+
+ Ops.Set_Right (Y, Z);
+
+ if Y = Tree.Last then
+ Tree.Last := Z;
+ end if;
+ end if;
+
+ Ops.Set_Parent (Z, Y);
+ Ops.Rebalance_For_Insert (Tree, Z);
+ Tree.Length := New_Length;
+ end Generic_Insert_Post;
+
+ -----------------------
+ -- Generic_Iteration --
+ -----------------------
+
+ procedure Generic_Iteration
+ (Tree : Tree_Type;
+ Key : Key_Type)
+ is
+ procedure Iterate (Node : Node_Access);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (Node : Node_Access) is
+ N : Node_Access := Node;
+ begin
+ while N /= Ops.Null_Node loop
+ if Is_Less_Key_Node (Key, N) then
+ N := Ops.Left (N);
+ elsif Is_Greater_Key_Node (Key, N) then
+ N := Ops.Right (N);
+ else
+ Iterate (Ops.Left (N));
+ Process (N);
+ N := Ops.Right (N);
+ end if;
+ end loop;
+ end Iterate;
+
+ -- Start of processing for Generic_Iteration
+
+ begin
+ Iterate (Tree.Root);
+ end Generic_Iteration;
+
+ -------------------------------
+ -- Generic_Reverse_Iteration --
+ -------------------------------
+
+ procedure Generic_Reverse_Iteration
+ (Tree : Tree_Type;
+ Key : Key_Type)
+ is
+ procedure Iterate (Node : Node_Access);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (Node : Node_Access) is
+ N : Node_Access := Node;
+ begin
+ while N /= Ops.Null_Node loop
+ if Is_Less_Key_Node (Key, N) then
+ N := Ops.Left (N);
+ elsif Is_Greater_Key_Node (Key, N) then
+ N := Ops.Right (N);
+ else
+ Iterate (Ops.Right (N));
+ Process (N);
+ N := Ops.Left (N);
+ end if;
+ end loop;
+ end Iterate;
+
+ -- Start of processing for Generic_Reverse_Iteration
+
+ begin
+ Iterate (Tree.Root);
+ end Generic_Reverse_Iteration;
+
+ ----------------------------------
+ -- Generic_Unconditional_Insert --
+ ----------------------------------
+
+ procedure Generic_Unconditional_Insert
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access)
+ is
+ Y : Node_Access := Ops.Null_Node;
+ X : Node_Access := Tree.Root;
+
+ begin
+ while X /= Ops.Null_Node loop
+ Y := X;
+
+ if Is_Less_Key_Node (Key, X) then
+ X := Ops.Left (X);
+ else
+ X := Ops.Right (X);
+ end if;
+ end loop;
+
+ Insert_Post (Tree, X, Y, Key, Node);
+ end Generic_Unconditional_Insert;
+
+ --------------------------------------------
+ -- Generic_Unconditional_Insert_With_Hint --
+ --------------------------------------------
+
+ procedure Generic_Unconditional_Insert_With_Hint
+ (Tree : in out Tree_Type;
+ Hint : Node_Access;
+ Key : Key_Type;
+ Node : out Node_Access)
+ is
+ -- TODO: verify this algorithm. It was (quickly) adapted it from the
+ -- same algorithm for conditional_with_hint. It may be that the test
+ -- Key > Hint should be something like a Key >= Hint, to handle the
+ -- case when Hint is The Last Item of A (Contiguous) sequence of
+ -- Equivalent Items. (The Key < Hint Test is probably OK. It is not
+ -- clear that you can use Key <= Hint, since new items are always
+ -- inserted last in the sequence of equivalent items.) ???
+
+ begin
+ if Hint = Ops.Null_Node then -- largest
+ if Tree.Length > 0
+ and then Is_Greater_Key_Node (Key, Tree.Last)
+ then
+ Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
+ else
+ Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ end if;
+
+ return;
+ end if;
+
+ pragma Assert (Tree.Length > 0);
+
+ if Is_Less_Key_Node (Key, Hint) then
+ if Hint = Tree.First then
+ Insert_Post (Tree, Hint, Hint, Key, Node);
+ return;
+ end if;
+
+ declare
+ Before : constant Node_Access := Ops.Previous (Hint);
+ begin
+ if Is_Greater_Key_Node (Key, Before) then
+ if Ops.Right (Before) = Ops.Null_Node then
+ Insert_Post (Tree, Ops.Null_Node, Before, Key, Node);
+ else
+ Insert_Post (Tree, Hint, Hint, Key, Node);
+ end if;
+ else
+ Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ end if;
+ end;
+
+ return;
+ end if;
+
+ if Is_Greater_Key_Node (Key, Hint) then
+ if Hint = Tree.Last then
+ Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
+ return;
+ end if;
+
+ declare
+ After : constant Node_Access := Ops.Next (Hint);
+ begin
+ if Is_Less_Key_Node (Key, After) then
+ if Ops.Right (Hint) = Ops.Null_Node then
+ Insert_Post (Tree, Ops.Null_Node, Hint, Key, Node);
+ else
+ Insert_Post (Tree, After, After, Key, Node);
+ end if;
+ else
+ Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ end if;
+ end;
+
+ return;
+ end if;
+
+ Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ end Generic_Unconditional_Insert_With_Hint;
+
+ -----------------
+ -- Upper_Bound --
+ -----------------
+
+ function Upper_Bound
+ (Tree : Tree_Type;
+ Key : Key_Type) return Node_Access
+ is
+ Y : Node_Access;
+ X : Node_Access := Tree.Root;
+
+ begin
+ while X /= Ops.Null_Node loop
+ if Is_Less_Key_Node (Key, X) then
+ Y := X;
+ X := Ops.Left (X);
+ else
+ X := Ops.Right (X);
+ end if;
+ end loop;
+
+ return Y;
+ end Upper_Bound;
+
+end Ada.Containers.Red_Black_Trees.Generic_Keys;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees.Generic_Operations;
+
+generic
+ with package Tree_Operations is new Generic_Operations (<>);
+
+ use Tree_Operations.Tree_Types;
+
+ type Key_Type (<>) is limited private;
+
+ with function Is_Less_Key_Node
+ (L : Key_Type;
+ R : Node_Access) return Boolean;
+
+ with function Is_Greater_Key_Node
+ (L : Key_Type;
+ R : Node_Access) return Boolean;
+
+package Ada.Containers.Red_Black_Trees.Generic_Keys is
+pragma Pure (Generic_Keys);
+
+ generic
+ with function New_Node return Node_Access;
+ procedure Generic_Insert_Post
+ (Tree : in out Tree_Type;
+ X, Y : Node_Access;
+ Key : Key_Type;
+ Z : out Node_Access);
+
+ generic
+ with procedure Insert_Post
+ (Tree : in out Tree_Type;
+ X, Y : Node_Access;
+ Key : Key_Type;
+ Z : out Node_Access);
+
+ procedure Generic_Conditional_Insert
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Success : out Boolean);
+
+ generic
+ with procedure Insert_Post
+ (Tree : in out Tree_Type;
+ X, Y : Node_Access;
+ Key : Key_Type;
+ Z : out Node_Access);
+
+ procedure Generic_Unconditional_Insert
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access);
+
+ generic
+ with procedure Insert_Post
+ (Tree : in out Tree_Type;
+ X, Y : Node_Access;
+ Key : Key_Type;
+ Z : out Node_Access);
+
+ with procedure Unconditional_Insert_Sans_Hint
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access);
+
+ procedure Generic_Unconditional_Insert_With_Hint
+ (Tree : in out Tree_Type;
+ Hint : Node_Access;
+ Key : Key_Type;
+ Node : out Node_Access);
+
+ generic
+ with procedure Insert_Post
+ (Tree : in out Tree_Type;
+ X, Y : Node_Access;
+ Key : Key_Type;
+ Z : out Node_Access);
+
+ with procedure Conditional_Insert_Sans_Hint
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Success : out Boolean);
+
+ procedure Generic_Conditional_Insert_With_Hint
+ (Tree : in out Tree_Type;
+ Position : Node_Access;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Success : out Boolean);
+
+ function Find
+ (Tree : Tree_Type;
+ Key : Key_Type) return Node_Access;
+
+ function Ceiling
+ (Tree : Tree_Type;
+ Key : Key_Type) return Node_Access;
+
+ function Floor
+ (Tree : Tree_Type;
+ Key : Key_Type) return Node_Access;
+
+ function Upper_Bound
+ (Tree : Tree_Type;
+ Key : Key_Type) return Node_Access;
+
+ generic
+ with procedure Process (Node : Node_Access);
+ procedure Generic_Iteration
+ (Tree : Tree_Type;
+ Key : Key_Type);
+
+ generic
+ with procedure Process (Node : Node_Access);
+ procedure Generic_Reverse_Iteration
+ (Tree : Tree_Type;
+ Key : Key_Type);
+
+end Ada.Containers.Red_Black_Trees.Generic_Keys;
+
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+package body Ada.Containers.Red_Black_Trees.Generic_Operations is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access);
+
+ procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access);
+
+ procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access);
+ procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access);
+
+ ---------------------
+ -- Check_Invariant --
+ ---------------------
+
+ procedure Check_Invariant (Tree : Tree_Type) is
+ Root : constant Node_Access := Tree.Root;
+
+ function Check (Node : Node_Access) return Natural;
+
+ -----------
+ -- Check --
+ -----------
+
+ function Check (Node : Node_Access) return Natural is
+ begin
+ if Node = Null_Node then
+ return 0;
+ end if;
+
+ if Color (Node) = Red then
+ declare
+ L : constant Node_Access := Left (Node);
+ begin
+ pragma Assert (L = Null_Node or else Color (L) = Black);
+ null;
+ end;
+
+ declare
+ R : constant Node_Access := Right (Node);
+ begin
+ pragma Assert (R = Null_Node or else Color (R) = Black);
+ null;
+ end;
+
+ declare
+ NL : constant Natural := Check (Left (Node));
+ NR : constant Natural := Check (Right (Node));
+ begin
+ pragma Assert (NL = NR);
+ return NL;
+ end;
+ end if;
+
+ declare
+ NL : constant Natural := Check (Left (Node));
+ NR : constant Natural := Check (Right (Node));
+ begin
+ pragma Assert (NL = NR);
+ return NL + 1;
+ end;
+ end Check;
+
+ -- Start of processing for Check_Invariant
+
+ begin
+ if Root = Null_Node then
+ pragma Assert (Tree.First = Null_Node);
+ pragma Assert (Tree.Last = Null_Node);
+ pragma Assert (Tree.Length = 0);
+ null;
+
+ else
+ pragma Assert (Color (Root) = Black);
+ pragma Assert (Tree.Length > 0);
+ pragma Assert (Tree.Root /= Null_Node);
+ pragma Assert (Tree.First /= Null_Node);
+ pragma Assert (Tree.Last /= Null_Node);
+ pragma Assert (Parent (Tree.Root) = Null_Node);
+ pragma Assert ((Tree.Length > 1)
+ or else (Tree.First = Tree.Last
+ and Tree.First = Tree.Root));
+ pragma Assert (Left (Tree.First) = Null_Node);
+ pragma Assert (Right (Tree.Last) = Null_Node);
+
+ declare
+ L : constant Node_Access := Left (Root);
+ R : constant Node_Access := Right (Root);
+ NL : constant Natural := Check (L);
+ NR : constant Natural := Check (R);
+ begin
+ pragma Assert (NL = NR);
+ null;
+ end;
+ end if;
+ end Check_Invariant;
+
+ ------------------
+ -- Delete_Fixup --
+ ------------------
+
+ procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
+
+ -- CLR p274 ???
+
+ X : Node_Access := Node;
+ W : Node_Access;
+
+ begin
+ while X /= Tree.Root
+ and then Color (X) = Black
+ loop
+ if X = Left (Parent (X)) then
+ W := Right (Parent (X));
+
+ if Color (W) = Red then
+ Set_Color (W, Black);
+ Set_Color (Parent (X), Red);
+ Left_Rotate (Tree, Parent (X));
+ W := Right (Parent (X));
+ end if;
+
+ if (Left (W) = Null_Node or else Color (Left (W)) = Black)
+ and then
+ (Right (W) = Null_Node or else Color (Right (W)) = Black)
+ then
+ Set_Color (W, Red);
+ X := Parent (X);
+
+ else
+ if Right (W) = Null_Node
+ or else Color (Right (W)) = Black
+ then
+ if Left (W) /= Null_Node then
+ Set_Color (Left (W), Black);
+ end if;
+
+ Set_Color (W, Red);
+ Right_Rotate (Tree, W);
+ W := Right (Parent (X));
+ end if;
+
+ Set_Color (W, Color (Parent (X)));
+ Set_Color (Parent (X), Black);
+ Set_Color (Right (W), Black);
+ Left_Rotate (Tree, Parent (X));
+ X := Tree.Root;
+ end if;
+
+ else
+ pragma Assert (X = Right (Parent (X)));
+
+ W := Left (Parent (X));
+
+ if Color (W) = Red then
+ Set_Color (W, Black);
+ Set_Color (Parent (X), Red);
+ Right_Rotate (Tree, Parent (X));
+ W := Left (Parent (X));
+ end if;
+
+ if (Left (W) = Null_Node or else Color (Left (W)) = Black)
+ and then
+ (Right (W) = Null_Node or else Color (Right (W)) = Black)
+ then
+ Set_Color (W, Red);
+ X := Parent (X);
+
+ else
+ if Left (W) = Null_Node or else Color (Left (W)) = Black then
+ if Right (W) /= Null_Node then
+ Set_Color (Right (W), Black);
+ end if;
+
+ Set_Color (W, Red);
+ Left_Rotate (Tree, W);
+ W := Left (Parent (X));
+ end if;
+
+ Set_Color (W, Color (Parent (X)));
+ Set_Color (Parent (X), Black);
+ Set_Color (Left (W), Black);
+ Right_Rotate (Tree, Parent (X));
+ X := Tree.Root;
+ end if;
+ end if;
+ end loop;
+
+ Set_Color (X, Black);
+ end Delete_Fixup;
+
+ ---------------------------
+ -- Delete_Node_Sans_Free --
+ ---------------------------
+
+ procedure Delete_Node_Sans_Free
+ (Tree : in out Tree_Type;
+ Node : Node_Access)
+ is
+ -- CLR p273 ???
+
+ X, Y : Node_Access;
+
+ Z : constant Node_Access := Node;
+ pragma Assert (Z /= Null_Node);
+
+ begin
+ pragma Assert (Tree.Length > 0);
+ pragma Assert (Tree.Root /= Null_Node);
+ pragma Assert (Tree.First /= Null_Node);
+ pragma Assert (Tree.Last /= Null_Node);
+ pragma Assert (Parent (Tree.Root) = Null_Node);
+ pragma Assert ((Tree.Length > 1)
+ or else (Tree.First = Tree.Last
+ and then Tree.First = Tree.Root));
+ pragma Assert ((Left (Node) = Null_Node)
+ or else (Parent (Left (Node)) = Node));
+ pragma Assert ((Right (Node) = Null_Node)
+ or else (Parent (Right (Node)) = Node));
+ pragma Assert (((Parent (Node) = Null_Node) and then (Tree.Root = Node))
+ or else ((Parent (Node) /= Null_Node) and then
+ ((Left (Parent (Node)) = Node)
+ or else (Right (Parent (Node)) = Node))));
+
+ if Left (Z) = Null_Node then
+ if Right (Z) = Null_Node then
+ if Z = Tree.First then
+ Tree.First := Parent (Z);
+ end if;
+
+ if Z = Tree.Last then
+ Tree.Last := Parent (Z);
+ end if;
+
+ if Color (Z) = Black then
+ Delete_Fixup (Tree, Z);
+ end if;
+
+ pragma Assert (Left (Z) = Null_Node);
+ pragma Assert (Right (Z) = Null_Node);
+
+ if Z = Tree.Root then
+ pragma Assert (Tree.Length = 1);
+ pragma Assert (Parent (Z) = Null_Node);
+ Tree.Root := Null_Node;
+ elsif Z = Left (Parent (Z)) then
+ Set_Left (Parent (Z), Null_Node);
+ else
+ pragma Assert (Z = Right (Parent (Z)));
+ Set_Right (Parent (Z), Null_Node);
+ end if;
+
+ else
+ pragma Assert (Z /= Tree.Last);
+
+ X := Right (Z);
+
+ if Z = Tree.First then
+ Tree.First := Min (X);
+ end if;
+
+ if Z = Tree.Root then
+ Tree.Root := X;
+ elsif Z = Left (Parent (Z)) then
+ Set_Left (Parent (Z), X);
+ else
+ pragma Assert (Z = Right (Parent (Z)));
+ Set_Right (Parent (Z), X);
+ end if;
+
+ Set_Parent (X, Parent (Z));
+
+ if Color (Z) = Black then
+ Delete_Fixup (Tree, X);
+ end if;
+ end if;
+
+ elsif Right (Z) = Null_Node then
+ pragma Assert (Z /= Tree.First);
+
+ X := Left (Z);
+
+ if Z = Tree.Last then
+ Tree.Last := Max (X);
+ end if;
+
+ if Z = Tree.Root then
+ Tree.Root := X;
+ elsif Z = Left (Parent (Z)) then
+ Set_Left (Parent (Z), X);
+ else
+ pragma Assert (Z = Right (Parent (Z)));
+ Set_Right (Parent (Z), X);
+ end if;
+
+ Set_Parent (X, Parent (Z));
+
+ if Color (Z) = Black then
+ Delete_Fixup (Tree, X);
+ end if;
+
+ else
+ pragma Assert (Z /= Tree.First);
+ pragma Assert (Z /= Tree.Last);
+
+ Y := Next (Z);
+ pragma Assert (Left (Y) = Null_Node);
+
+ X := Right (Y);
+
+ if X = Null_Node then
+ if Y = Left (Parent (Y)) then
+ pragma Assert (Parent (Y) /= Z);
+ Delete_Swap (Tree, Z, Y);
+ Set_Left (Parent (Z), Z);
+
+ else
+ pragma Assert (Y = Right (Parent (Y)));
+ pragma Assert (Parent (Y) = Z);
+ Set_Parent (Y, Parent (Z));
+
+ if Z = Tree.Root then
+ Tree.Root := Y;
+ elsif Z = Left (Parent (Z)) then
+ Set_Left (Parent (Z), Y);
+ else
+ pragma Assert (Z = Right (Parent (Z)));
+ Set_Right (Parent (Z), Y);
+ end if;
+
+ Set_Left (Y, Left (Z));
+ Set_Parent (Left (Y), Y);
+ Set_Right (Y, Z);
+ Set_Parent (Z, Y);
+ Set_Left (Z, Null_Node);
+ Set_Right (Z, Null_Node);
+
+ declare
+ Y_Color : constant Color_Type := Color (Y);
+ begin
+ Set_Color (Y, Color (Z));
+ Set_Color (Z, Y_Color);
+ end;
+ end if;
+
+ if Color (Z) = Black then
+ Delete_Fixup (Tree, Z);
+ end if;
+
+ pragma Assert (Left (Z) = Null_Node);
+ pragma Assert (Right (Z) = Null_Node);
+
+ if Z = Right (Parent (Z)) then
+ Set_Right (Parent (Z), Null_Node);
+ else
+ pragma Assert (Z = Left (Parent (Z)));
+ Set_Left (Parent (Z), Null_Node);
+ end if;
+
+ else
+ if Y = Left (Parent (Y)) then
+ pragma Assert (Parent (Y) /= Z);
+
+ Delete_Swap (Tree, Z, Y);
+
+ Set_Left (Parent (Z), X);
+ Set_Parent (X, Parent (Z));
+
+ else
+ pragma Assert (Y = Right (Parent (Y)));
+ pragma Assert (Parent (Y) = Z);
+
+ Set_Parent (Y, Parent (Z));
+
+ if Z = Tree.Root then
+ Tree.Root := Y;
+ elsif Z = Left (Parent (Z)) then
+ Set_Left (Parent (Z), Y);
+ else
+ pragma Assert (Z = Right (Parent (Z)));
+ Set_Right (Parent (Z), Y);
+ end if;
+
+ Set_Left (Y, Left (Z));
+ Set_Parent (Left (Y), Y);
+
+ declare
+ Y_Color : constant Color_Type := Color (Y);
+ begin
+ Set_Color (Y, Color (Z));
+ Set_Color (Z, Y_Color);
+ end;
+ end if;
+
+ if Color (Z) = Black then
+ Delete_Fixup (Tree, X);
+ end if;
+ end if;
+ end if;
+
+ Tree.Length := Tree.Length - 1;
+ end Delete_Node_Sans_Free;
+
+ -----------------
+ -- Delete_Swap --
+ -----------------
+
+ procedure Delete_Swap
+ (Tree : in out Tree_Type;
+ Z, Y : Node_Access)
+ is
+ pragma Assert (Z /= Y);
+ pragma Assert (Parent (Y) /= Z);
+
+ Y_Parent : constant Node_Access := Parent (Y);
+ Y_Color : constant Color_Type := Color (Y);
+
+ begin
+ Set_Parent (Y, Parent (Z));
+ Set_Left (Y, Left (Z));
+ Set_Right (Y, Right (Z));
+ Set_Color (Y, Color (Z));
+
+ if Tree.Root = Z then
+ Tree.Root := Y;
+ elsif Right (Parent (Y)) = Z then
+ Set_Right (Parent (Y), Y);
+ else
+ pragma Assert (Left (Parent (Y)) = Z);
+ Set_Left (Parent (Y), Y);
+ end if;
+
+ if Right (Y) /= Null_Node then
+ Set_Parent (Right (Y), Y);
+ end if;
+
+ if Left (Y) /= Null_Node then
+ Set_Parent (Left (Y), Y);
+ end if;
+
+ Set_Parent (Z, Y_Parent);
+ Set_Color (Z, Y_Color);
+ Set_Left (Z, Null_Node);
+ Set_Right (Z, Null_Node);
+ end Delete_Swap;
+
+ -------------------
+ -- Generic_Equal --
+ -------------------
+
+ function Generic_Equal (Left, Right : Tree_Type) return Boolean is
+ L_Node : Node_Access;
+ R_Node : Node_Access;
+
+ begin
+ if Left.Length /= Right.Length then
+ return False;
+ end if;
+
+ L_Node := Left.First;
+ R_Node := Right.First;
+ while L_Node /= Null_Node loop
+ if not Is_Equal (L_Node, R_Node) then
+ return False;
+ end if;
+
+ L_Node := Next (L_Node);
+ R_Node := Next (R_Node);
+ end loop;
+
+ return True;
+ end Generic_Equal;
+
+ -----------------------
+ -- Generic_Iteration --
+ -----------------------
+
+ procedure Generic_Iteration (Tree : Tree_Type) is
+ procedure Iterate (P : Node_Access);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (P : Node_Access) is
+ X : Node_Access := P;
+ begin
+ while X /= Null_Node loop
+ Iterate (Left (X));
+ Process (X);
+ X := Right (X);
+ end loop;
+ end Iterate;
+
+ -- Start of processing for Generic_Iteration
+
+ begin
+ Iterate (Tree.Root);
+ end Generic_Iteration;
+
+ ------------------
+ -- Generic_Read --
+ ------------------
+
+ procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type) is
+
+ pragma Assert (Tree.Length = 0);
+ -- Clear and back node reinit was done by caller
+
+ Node, Last_Node : Node_Access;
+
+ begin
+ if N = 0 then
+ return;
+ end if;
+
+ Node := New_Node;
+ pragma Assert (Node /= Null_Node);
+ pragma Assert (Color (Node) = Red);
+
+ Set_Color (Node, Black);
+
+ Tree.Root := Node;
+ Tree.First := Node;
+ Tree.Last := Node;
+
+ Tree.Length := 1;
+
+ for J in Count_Type range 2 .. N loop
+ Last_Node := Node;
+ pragma Assert (Last_Node = Tree.Last);
+
+ Node := New_Node;
+ pragma Assert (Node /= Null_Node);
+ pragma Assert (Color (Node) = Red);
+
+ Set_Right (Node => Last_Node, Right => Node);
+ Tree.Last := Node;
+ Set_Parent (Node => Node, Parent => Last_Node);
+ Rebalance_For_Insert (Tree, Node);
+ Tree.Length := Tree.Length + 1;
+ end loop;
+ end Generic_Read;
+
+ -------------------------------
+ -- Generic_Reverse_Iteration --
+ -------------------------------
+
+ procedure Generic_Reverse_Iteration (Tree : Tree_Type)
+ is
+ procedure Iterate (P : Node_Access);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (P : Node_Access) is
+ X : Node_Access := P;
+ begin
+ while X /= Null_Node loop
+ Iterate (Right (X));
+ Process (X);
+ X := Left (X);
+ end loop;
+ end Iterate;
+
+ -- Start of processing for Generic_Reverse_Iteration
+
+ begin
+ Iterate (Tree.Root);
+ end Generic_Reverse_Iteration;
+
+ -----------------
+ -- Left_Rotate --
+ -----------------
+
+ procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
+
+ -- CLR p266 ???
+
+ Y : constant Node_Access := Right (X);
+ pragma Assert (Y /= Null_Node);
+
+ begin
+ Set_Right (X, Left (Y));
+
+ if Left (Y) /= Null_Node then
+ Set_Parent (Left (Y), X);
+ end if;
+
+ Set_Parent (Y, Parent (X));
+
+ if X = Tree.Root then
+ Tree.Root := Y;
+ elsif X = Left (Parent (X)) then
+ Set_Left (Parent (X), Y);
+ else
+ pragma Assert (X = Right (Parent (X)));
+ Set_Right (Parent (X), Y);
+ end if;
+
+ Set_Left (Y, X);
+ Set_Parent (X, Y);
+ end Left_Rotate;
+
+ ---------
+ -- Max --
+ ---------
+
+ function Max (Node : Node_Access) return Node_Access is
+
+ -- CLR p248 ???
+
+ X : Node_Access := Node;
+ Y : Node_Access;
+
+ begin
+ loop
+ Y := Right (X);
+
+ if Y = Null_Node then
+ return X;
+ end if;
+
+ X := Y;
+ end loop;
+ end Max;
+
+ ---------
+ -- Min --
+ ---------
+
+ function Min (Node : Node_Access) return Node_Access is
+
+ -- CLR p248 ???
+
+ X : Node_Access := Node;
+ Y : Node_Access;
+
+ begin
+ loop
+ Y := Left (X);
+
+ if Y = Null_Node then
+ return X;
+ end if;
+
+ X := Y;
+ end loop;
+ end Min;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target, Source : in out Tree_Type) is
+ begin
+ if Target.Length > 0 then
+ raise Constraint_Error;
+ end if;
+
+ Target := Source;
+ Source := (First => Null_Node,
+ Last => Null_Node,
+ Root => Null_Node,
+ Length => 0);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Node : Node_Access) return Node_Access is
+ begin
+ -- CLR p249 ???
+
+ if Node = Null_Node then
+ return Null_Node;
+ end if;
+
+ if Right (Node) /= Null_Node then
+ return Min (Right (Node));
+ end if;
+
+ declare
+ X : Node_Access := Node;
+ Y : Node_Access := Parent (Node);
+
+ begin
+ while Y /= Null_Node
+ and then X = Right (Y)
+ loop
+ X := Y;
+ Y := Parent (Y);
+ end loop;
+
+ -- Why is this code commented out ???
+
+-- if Right (X) /= Y then
+-- return Y;
+-- else
+-- return X;
+-- end if;
+
+ return Y;
+ end;
+ end Next;
+
+ --------------
+ -- Previous --
+ --------------
+
+ function Previous (Node : Node_Access) return Node_Access is
+ begin
+ if Node = Null_Node then
+ return Null_Node;
+ end if;
+
+ if Left (Node) /= Null_Node then
+ return Max (Left (Node));
+ end if;
+
+ declare
+ X : Node_Access := Node;
+ Y : Node_Access := Parent (Node);
+
+ begin
+ while Y /= Null_Node
+ and then X = Left (Y)
+ loop
+ X := Y;
+ Y := Parent (Y);
+ end loop;
+
+ -- Why is this code commented out ???
+
+-- if Left (X) /= Y then
+-- return Y;
+-- else
+-- return X;
+-- end if;
+
+ return Y;
+ end;
+ end Previous;
+
+ --------------------------
+ -- Rebalance_For_Insert --
+ --------------------------
+
+ procedure Rebalance_For_Insert
+ (Tree : in out Tree_Type;
+ Node : Node_Access)
+ is
+ -- CLR p.268 ???
+
+ X : Node_Access := Node;
+ pragma Assert (X /= Null_Node);
+ pragma Assert (Color (X) = Red);
+
+ Y : Node_Access;
+
+ begin
+ while X /= Tree.Root and then Color (Parent (X)) = Red loop
+ if Parent (X) = Left (Parent (Parent (X))) then
+ Y := Right (Parent (Parent (X)));
+
+ if Y /= Null_Node and then Color (Y) = Red then
+ Set_Color (Parent (X), Black);
+ Set_Color (Y, Black);
+ Set_Color (Parent (Parent (X)), Red);
+ X := Parent (Parent (X));
+
+ else
+ if X = Right (Parent (X)) then
+ X := Parent (X);
+ Left_Rotate (Tree, X);
+ end if;
+
+ Set_Color (Parent (X), Black);
+ Set_Color (Parent (Parent (X)), Red);
+ Right_Rotate (Tree, Parent (Parent (X)));
+ end if;
+
+ else
+ pragma Assert (Parent (X) = Right (Parent (Parent (X))));
+
+ Y := Left (Parent (Parent (X)));
+
+ if Y /= Null_Node and then Color (Y) = Red then
+ Set_Color (Parent (X), Black);
+ Set_Color (Y, Black);
+ Set_Color (Parent (Parent (X)), Red);
+ X := Parent (Parent (X));
+
+ else
+ if X = Left (Parent (X)) then
+ X := Parent (X);
+ Right_Rotate (Tree, X);
+ end if;
+
+ Set_Color (Parent (X), Black);
+ Set_Color (Parent (Parent (X)), Red);
+ Left_Rotate (Tree, Parent (Parent (X)));
+ end if;
+ end if;
+ end loop;
+
+ Set_Color (Tree.Root, Black);
+ end Rebalance_For_Insert;
+
+ ------------------
+ -- Right_Rotate --
+ ------------------
+
+ procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
+ X : constant Node_Access := Left (Y);
+ pragma Assert (X /= Null_Node);
+
+ begin
+ Set_Left (Y, Right (X));
+
+ if Right (X) /= Null_Node then
+ Set_Parent (Right (X), Y);
+ end if;
+
+ Set_Parent (X, Parent (Y));
+
+ if Y = Tree.Root then
+ Tree.Root := X;
+ elsif Y = Left (Parent (Y)) then
+ Set_Left (Parent (Y), X);
+ else
+ pragma Assert (Y = Right (Parent (Y)));
+ Set_Right (Parent (Y), X);
+ end if;
+
+ Set_Right (X, Y);
+ Set_Parent (Y, X);
+ end Right_Rotate;
+
+end Ada.Containers.Red_Black_Trees.Generic_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+ with package Tree_Types is new Generic_Tree_Types (<>);
+ use Tree_Types;
+
+ Null_Node : Node_Access;
+
+ with function Parent (Node : Node_Access) return Node_Access is <>;
+ with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>;
+ with function Left (Node : Node_Access) return Node_Access is <>;
+ with procedure Set_Left (Node : Node_Access; Left : Node_Access) is <>;
+ with function Right (Node : Node_Access) return Node_Access is <>;
+ with procedure Set_Right (Node : Node_Access; Right : Node_Access) is <>;
+ with function Color (Node : Node_Access) return Color_Type is <>;
+ with procedure Set_Color (Node : Node_Access; Color : Color_Type) is <>;
+
+package Ada.Containers.Red_Black_Trees.Generic_Operations is
+pragma Pure;
+
+ function Min (Node : Node_Access) return Node_Access;
+
+ function Max (Node : Node_Access) return Node_Access;
+
+ procedure Check_Invariant (Tree : Tree_Type);
+
+ function Next (Node : Node_Access) return Node_Access;
+
+ function Previous (Node : Node_Access) return Node_Access;
+
+ procedure Move (Target, Source : in out Tree_Type);
+
+ generic
+ with function Is_Equal (L, R : Node_Access) return Boolean;
+ function Generic_Equal (Left, Right : Tree_Type) return Boolean;
+
+ procedure Delete_Node_Sans_Free
+ (Tree : in out Tree_Type;
+ Node : Node_Access);
+
+ generic
+ with procedure Process (Node : Node_Access) is <>;
+ procedure Generic_Iteration (Tree : Tree_Type);
+
+ generic
+ with procedure Process (Node : Node_Access) is <>;
+ procedure Generic_Reverse_Iteration (Tree : Tree_Type);
+
+ generic
+ with function New_Node return Node_Access is <>;
+ procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type);
+
+ procedure Rebalance_For_Insert
+ (Tree : in out Tree_Type;
+ Node : Node_Access);
+
+end Ada.Containers.Red_Black_Trees.Generic_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . L O N G _ F L O A T _ W I D E _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Long_Float_Wide_Wide_Text_IO is
+ new Ada.Wide_Wide_Text_IO.Float_IO (Long_Float);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . L O N G _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Long_Integer_Wide_Wide_Text_IO is
+ new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Integer);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+--A D A . L O N G _ L O N G _ F L O A T _ W I D E _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Long_Long_Float_Wide_Wide_Text_IO is
+ new Ada.Wide_Wide_Text_IO.Float_IO (Long_Long_Float);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Long_Long_Integer_Wide_Wide_Text_IO is
+ new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Long_Integer);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
+ Tgt : Node_Access := Target.First;
+ Src : Node_Access := Source.First;
+
+ begin
+
+ -- NOTE: must be done by client:
+ -- if Target'Address = Source'Address then
+ -- Clear (Target);
+ -- return;
+ -- end if;
+
+ loop
+ if Tgt = Tree_Operations.Null_Node then
+ return;
+ end if;
+
+ if Src = Tree_Operations.Null_Node then
+ return;
+ end if;
+
+ if Is_Less (Tgt, Src) then
+ Tgt := Tree_Operations.Next (Tgt);
+
+ elsif Is_Less (Src, Tgt) then
+ Src := Tree_Operations.Next (Src);
+
+ else
+ declare
+ X : Node_Access := Tgt;
+ begin
+ Tgt := Tree_Operations.Next (Tgt);
+ Tree_Operations.Delete_Node_Sans_Free (Target, X);
+ Free (X);
+ end;
+
+ Src := Tree_Operations.Next (Src);
+ end if;
+ end loop;
+ end Difference;
+
+ function Difference (Left, Right : Tree_Type) return Tree_Type is
+ Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);
+
+ L_Node : Node_Access := Left.First;
+ R_Node : Node_Access := Right.First;
+
+ Dst_Node : Node_Access;
+
+ begin
+ -- NOTE: must by done by client:
+ -- if Left'Address = Right'Address then
+ -- return Empty_Set;
+ -- end if;
+
+ loop
+ if L_Node = Tree_Operations.Null_Node then
+ return Tree;
+ end if;
+
+ if R_Node = Tree_Operations.Null_Node then
+ while L_Node /= Tree_Operations.Null_Node loop
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ Dst_Hint => Tree_Operations.Null_Node,
+ Src_Node => L_Node,
+ Dst_Node => Dst_Node);
+
+ L_Node := Tree_Operations.Next (L_Node);
+
+ end loop;
+
+ return Tree;
+ end if;
+
+ if Is_Less (L_Node, R_Node) then
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ Dst_Hint => Tree_Operations.Null_Node,
+ Src_Node => L_Node,
+ Dst_Node => Dst_Node);
+
+ L_Node := Tree_Operations.Next (L_Node);
+
+ elsif Is_Less (R_Node, L_Node) then
+ R_Node := Tree_Operations.Next (R_Node);
+
+ else
+ L_Node := Tree_Operations.Next (L_Node);
+ R_Node := Tree_Operations.Next (R_Node);
+ end if;
+ end loop;
+
+ exception
+ when others =>
+ Delete_Tree (Tree.Root);
+ raise;
+ end Difference;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Intersection
+ (Target : in out Tree_Type;
+ Source : Tree_Type)
+ is
+ Tgt : Node_Access := Target.First;
+ Src : Node_Access := Source.First;
+
+ begin
+ -- NOTE: must be done by caller: ???
+ -- if Target'Address = Source'Address then
+ -- return;
+ -- end if;
+
+ while Tgt /= Tree_Operations.Null_Node
+ and then Src /= Tree_Operations.Null_Node
+ loop
+ if Is_Less (Tgt, Src) then
+ declare
+ X : Node_Access := Tgt;
+ begin
+ Tgt := Tree_Operations.Next (Tgt);
+ Tree_Operations.Delete_Node_Sans_Free (Target, X);
+ Free (X);
+ end;
+
+ elsif Is_Less (Src, Tgt) then
+ Src := Tree_Operations.Next (Src);
+
+ else
+ Tgt := Tree_Operations.Next (Tgt);
+ Src := Tree_Operations.Next (Src);
+ end if;
+ end loop;
+ end Intersection;
+
+ function Intersection (Left, Right : Tree_Type) return Tree_Type is
+ Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);
+
+ L_Node : Node_Access := Left.First;
+ R_Node : Node_Access := Right.First;
+
+ Dst_Node : Node_Access;
+
+ begin
+ -- NOTE: must be done by caller: ???
+ -- if Left'Address = Right'Address then
+ -- return Left;
+ -- end if;
+
+ loop
+ if L_Node = Tree_Operations.Null_Node then
+ return Tree;
+ end if;
+
+ if R_Node = Tree_Operations.Null_Node then
+ return Tree;
+ end if;
+
+ if Is_Less (L_Node, R_Node) then
+ L_Node := Tree_Operations.Next (L_Node);
+
+ elsif Is_Less (R_Node, L_Node) then
+ R_Node := Tree_Operations.Next (R_Node);
+
+ else
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ Dst_Hint => Tree_Operations.Null_Node,
+ Src_Node => L_Node,
+ Dst_Node => Dst_Node);
+
+ L_Node := Tree_Operations.Next (L_Node);
+ R_Node := Tree_Operations.Next (R_Node);
+ end if;
+ end loop;
+
+ exception
+ when others =>
+ Delete_Tree (Tree.Root);
+ raise;
+ end Intersection;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset
+ (Subset : Tree_Type;
+ Of_Set : Tree_Type) return Boolean
+ is
+ begin
+ -- NOTE: must by done by caller:
+ -- if Subset'Address = Of_Set'Address then
+ -- return True;
+ -- end if;
+
+ if Subset.Length > Of_Set.Length then
+ return False;
+ end if;
+
+ declare
+ Subset_Node : Node_Access := Subset.First;
+ Set_Node : Node_Access := Of_Set.First;
+
+ begin
+ loop
+ if Set_Node = Tree_Operations.Null_Node then
+ return Subset_Node = Tree_Operations.Null_Node;
+ end if;
+
+ if Subset_Node = Tree_Operations.Null_Node then
+ return True;
+ end if;
+
+ if Is_Less (Subset_Node, Set_Node) then
+ return False;
+ end if;
+
+ if Is_Less (Set_Node, Subset_Node) then
+ Set_Node := Tree_Operations.Next (Set_Node);
+ else
+ Set_Node := Tree_Operations.Next (Set_Node);
+ Subset_Node := Tree_Operations.Next (Subset_Node);
+ end if;
+ end loop;
+ end;
+ end Is_Subset;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Tree_Type) return Boolean is
+ L_Node : Node_Access := Left.First;
+ R_Node : Node_Access := Right.First;
+
+ begin
+ -- NOTE: must be done by caller: ???
+ -- if Left'Address = Right'Address then
+ -- return Left.Tree.Length /= 0;
+ -- end if;
+
+ loop
+ if L_Node = Tree_Operations.Null_Node
+ or else R_Node = Tree_Operations.Null_Node
+ then
+ return False;
+ end if;
+
+ if Is_Less (L_Node, R_Node) then
+ L_Node := Tree_Operations.Next (L_Node);
+
+ elsif Is_Less (R_Node, L_Node) then
+ R_Node := Tree_Operations.Next (R_Node);
+
+ else
+ return True;
+ end if;
+ end loop;
+ end Overlap;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference
+ (Target : in out Tree_Type;
+ Source : Tree_Type)
+ is
+ Tgt : Node_Access := Target.First;
+ Src : Node_Access := Source.First;
+
+ New_Tgt_Node : Node_Access;
+
+ begin
+ -- NOTE: must by done by client: ???
+ -- if Target'Address = Source'Address then
+ -- Clear (Target);
+ -- return;
+ -- end if;
+
+ loop
+ if Tgt = Tree_Operations.Null_Node then
+ while Src /= Tree_Operations.Null_Node loop
+ Insert_With_Hint
+ (Dst_Tree => Target,
+ Dst_Hint => Tree_Operations.Null_Node,
+ Src_Node => Src,
+ Dst_Node => New_Tgt_Node);
+
+ Src := Tree_Operations.Next (Src);
+ end loop;
+
+ return;
+ end if;
+
+ if Src = Tree_Operations.Null_Node then
+ return;
+ end if;
+
+ if Is_Less (Tgt, Src) then
+ Tgt := Tree_Operations.Next (Tgt);
+
+ elsif Is_Less (Src, Tgt) then
+ Insert_With_Hint
+ (Dst_Tree => Target,
+ Dst_Hint => Tgt,
+ Src_Node => Src,
+ Dst_Node => New_Tgt_Node);
+
+ Src := Tree_Operations.Next (Src);
+
+ else
+ declare
+ X : Node_Access := Tgt;
+ begin
+ Tgt := Tree_Operations.Next (Tgt);
+ Tree_Operations.Delete_Node_Sans_Free (Target, X);
+ Free (X);
+ end;
+
+ Src := Tree_Operations.Next (Src);
+ end if;
+ end loop;
+ end Symmetric_Difference;
+
+ function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
+ Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);
+
+ L_Node : Node_Access := Left.First;
+ R_Node : Node_Access := Right.First;
+
+ Dst_Node : Node_Access;
+
+ begin
+ -- NOTE: must by done by caller ???
+ -- if Left'Address = Right'Address then
+ -- return Empty_Set;
+ -- end if;
+
+ loop
+ if L_Node = Tree_Operations.Null_Node then
+ while R_Node /= Tree_Operations.Null_Node loop
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ Dst_Hint => Tree_Operations.Null_Node,
+ Src_Node => R_Node,
+ Dst_Node => Dst_Node);
+ R_Node := Tree_Operations.Next (R_Node);
+ end loop;
+
+ return Tree;
+ end if;
+
+ if R_Node = Tree_Operations.Null_Node then
+ while L_Node /= Tree_Operations.Null_Node loop
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ Dst_Hint => Tree_Operations.Null_Node,
+ Src_Node => L_Node,
+ Dst_Node => Dst_Node);
+
+ L_Node := Tree_Operations.Next (L_Node);
+ end loop;
+
+ return Tree;
+ end if;
+
+ if Is_Less (L_Node, R_Node) then
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ Dst_Hint => Tree_Operations.Null_Node,
+ Src_Node => L_Node,
+ Dst_Node => Dst_Node);
+
+ L_Node := Tree_Operations.Next (L_Node);
+
+ elsif Is_Less (R_Node, L_Node) then
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ Dst_Hint => Tree_Operations.Null_Node,
+ Src_Node => R_Node,
+ Dst_Node => Dst_Node);
+
+ R_Node := Tree_Operations.Next (R_Node);
+
+ else
+ L_Node := Tree_Operations.Next (L_Node);
+ R_Node := Tree_Operations.Next (R_Node);
+ end if;
+ end loop;
+
+ exception
+ when others =>
+ Delete_Tree (Tree.Root);
+ raise;
+ end Symmetric_Difference;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union (Target : in out Tree_Type; Source : Tree_Type)
+ is
+ Hint : Node_Access;
+
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Insert_With_Hint
+ (Dst_Tree => Target,
+ Dst_Hint => Hint,
+ Src_Node => Node,
+ Dst_Node => Hint);
+ end Process;
+
+ -- Start of processing for Union
+
+ begin
+ -- NOTE: must be done by caller: ???
+ -- if Target'Address = Source'Address then
+ -- return;
+ -- end if;
+
+ Iterate (Source);
+ end Union;
+
+ function Union (Left, Right : Tree_Type) return Tree_Type is
+ Tree : Tree_Type;
+
+ begin
+ -- NOTE: must be done by caller:
+ -- if Left'Address = Right'Address then
+ -- return Left;
+ -- end if;
+
+ declare
+ Root : constant Node_Access := Copy_Tree (Left.Root);
+ begin
+ Tree := (Root => Root,
+ First => Tree_Operations.Min (Root),
+ Last => Tree_Operations.Max (Root),
+ Length => Left.Length);
+ end;
+
+ declare
+ Hint : Node_Access;
+
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is
+ new Tree_Operations.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ Dst_Hint => Hint,
+ Src_Node => Node,
+ Dst_Node => Hint);
+ end Process;
+
+ -- Start of processing for Union
+
+ begin
+ Iterate (Right);
+
+ exception
+ when others =>
+ Delete_Tree (Tree.Root);
+ raise;
+ end;
+
+ return Tree;
+ end Union;
+
+end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Red_Black_Trees.Generic_Operations;
+
+generic
+ with package Tree_Operations is new Generic_Operations (<>);
+
+ use Tree_Operations.Tree_Types;
+
+ with procedure Insert_With_Hint
+ (Dst_Tree : in out Tree_Type;
+ Dst_Hint : Node_Access;
+ Src_Node : Node_Access;
+ Dst_Node : out Node_Access);
+
+ with function Copy_Tree (Source_Root : Node_Access)
+ return Node_Access;
+
+ with procedure Delete_Tree (X : in out Node_Access);
+
+ with function Is_Less (Left, Right : Node_Access) return Boolean;
+
+ with procedure Free (X : in out Node_Access);
+
+package Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
+pragma Pure (Generic_Set_Operations);
+
+ procedure Union (Target : in out Tree_Type; Source : Tree_Type);
+
+ function Union (Left, Right : Tree_Type) return Tree_Type;
+
+ procedure Intersection (Target : in out Tree_Type; Source : Tree_Type);
+
+ function Intersection (Left, Right : Tree_Type) return Tree_Type;
+
+ procedure Difference (Target : in out Tree_Type; Source : Tree_Type);
+
+ function Difference (Left, Right : Tree_Type) return Tree_Type;
+
+ procedure Symmetric_Difference
+ (Target : in out Tree_Type;
+ Source : Tree_Type);
+
+ function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type;
+
+ function Is_Subset (Subset : Tree_Type; Of_Set : Tree_Type) return Boolean;
+
+ function Overlap (Left, Right : Tree_Type) return Boolean;
+
+end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.EQUAL_CASE_INSENSITIVE --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+function Ada.Strings.Equal_Case_Insensitive
+ (Left, Right : String) return Boolean
+is
+ LI : Integer := Left'First;
+ RI : Integer := Right'First;
+
+begin
+ if Left'Length /= Right'Length then
+ return False;
+ end if;
+
+ if Left'Length = 0 then
+ return True;
+ end if;
+
+ loop
+ if To_Lower (Left (LI)) /= To_Lower (Right (RI)) then
+ return False;
+ end if;
+
+ if LI = Left'Last then
+ return True;
+ end if;
+
+ LI := LI + 1;
+ RI := RI + 1;
+ end loop;
+end Ada.Strings.Equal_Case_Insensitive;
+
+
+
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.EQUAL_CASE_INSENSITIVE --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+function Ada.Strings.Equal_Case_Insensitive
+ (Left, Right : String) return Boolean;
+
+pragma Pure (Ada.Strings.Equal_Case_Insensitive);
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S H O R T _ F L O A T _ W I D E _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Short_Float_Wide_Wide_Text_IO is
+ new Ada.Wide_Wide_Text_IO.Float_IO (Short_Float);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.HASH_CASE_INSENSITIVE --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Hash_Case_Insensitive
+ (Key : String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ Tmp : Hash_Type;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+begin
+ Tmp := 0;
+ for J in Key'Range loop
+ Tmp := Rotate_Left (Tmp, 1) + Character'Pos (To_Lower (Key (J)));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Hash_Case_Insensitive;
+
+
+
+
+
+
+
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.HASH_CASE_INSENSITIVE --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Hash_Case_Insensitive
+ (Key : String) return Containers.Hash_Type;
+
+pragma Pure (Ada.Strings.Hash_Case_Insensitive);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S H O R T _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Short_Integer_Wide_Wide_Text_IO is
+ new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Integer);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.LESS_CASE_INSENSITIVE --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+function Ada.Strings.Less_Case_Insensitive
+ (Left, Right : String) return Boolean
+is
+ LI : Integer := Left'First;
+ RI : Integer := Right'First;
+
+ LC, RC : Character;
+
+begin
+ if LI > Left'Last then
+ return RI <= Right'Last;
+ end if;
+
+ if RI > Right'Last then
+ return False;
+ end if;
+
+ loop
+ LC := To_Lower (Left (LI));
+ RC := To_Lower (Right (RI));
+
+ if LC < RC then
+ return True;
+ end if;
+
+ if LC > RC then
+ return False;
+ end if;
+
+ if LI = Left'Last then
+ return RI < Right'Last;
+ end if;
+
+ if RI = Right'Last then
+ return False;
+ end if;
+
+ LI := LI + 1;
+ RI := RI + 1;
+ end loop;
+end Ada.Strings.Less_Case_Insensitive;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.LESS_CASE_INSENSITIVE --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+function Ada.Strings.Less_Case_Insensitive
+ (Left, Right : String) return Boolean;
+
+pragma Pure (Ada.Strings.Less_Case_Insensitive);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Short_Short_Integer_Wide_Wide_Text_IO is
+ new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Short_Integer);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.HASH --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Hash (Key : String) return Containers.Hash_Type is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in Key'Range loop
+ Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Hash;
+
+
+
+
+
+
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.HASH --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Hash (Key : String) return Containers.Hash_Type;
+
+pragma Pure (Ada.Strings.Hash);
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.UNBOUNDED.HASH --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Unbounded.Hash
+ (Key : Unbounded_String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in 1 .. Key.Last loop
+ Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key.Reference (J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Unbounded.Hash;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.UNBOUNDED.HASH --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Unbounded.Hash
+ (Key : Unbounded_String) return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Unbounded.Hash);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_HASH --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Wide_Hash
+ (Key : Wide_String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in Key'Range loop
+ Tmp := Rotate_Left (Tmp, 1) + Wide_Character'Pos (Key (J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Wide_Hash;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_HASH --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Wide_Hash
+ (Key : Wide_String) return Containers.Hash_Type;
+
+pragma Pure (Ada.Strings.Wide_Hash);
+
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Wide_Wide_Bounded is
+
+ package body Generic_Bounded_Length is
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_Character) return Bounded_Wide_Wide_String
+ is
+ begin
+ return Times (Left, Right, Max_Length);
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_String) return Bounded_Wide_Wide_String
+ is
+ begin
+ return Times (Left, Right, Max_Length);
+ end "*";
+
+ ---------------
+ -- Replicate --
+ ---------------
+
+ function Replicate
+ (Count : Natural;
+ Item : Wide_Wide_Character;
+ Drop : Strings.Truncation := Strings.Error)
+ return Bounded_Wide_Wide_String
+ is
+ begin
+ return Super_Replicate (Count, Item, Drop, Max_Length);
+ end Replicate;
+
+ function Replicate
+ (Count : Natural;
+ Item : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Bounded_Wide_Wide_String
+ is
+ begin
+ return Super_Replicate (Count, Item, Drop, Max_Length);
+ end Replicate;
+
+ ---------------------------------
+ -- To_Bounded_Wide_Wide_String --
+ ---------------------------------
+
+ function To_Bounded_Wide_Wide_String
+ (Source : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Bounded_Wide_Wide_String
+ is
+ begin
+ return To_Super_String (Source, Max_Length, Drop);
+ end To_Bounded_Wide_Wide_String;
+
+ end Generic_Bounded_Length;
+end Ada.Strings.Wide_Wide_Bounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Wide_Maps;
+with Ada.Strings.Wide_Wide_Superbounded;
+
+package Ada.Strings.Wide_Wide_Bounded is
+pragma Preelaborate (Wide_Wide_Bounded);
+
+ generic
+ Max : Positive;
+ -- Maximum length of a Bounded_Wide_Wide_String
+
+ package Generic_Bounded_Length is
+
+ Max_Length : constant Positive := Max;
+
+ type Bounded_Wide_Wide_String is private;
+
+ Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String;
+
+ subtype Length_Range is Natural range 0 .. Max_Length;
+
+ function Length (Source : Bounded_Wide_Wide_String) return Length_Range;
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Bounded_Wide_Wide_String
+ (Source : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ function To_Wide_Wide_String
+ (Source : Bounded_Wide_Wide_String) return Wide_Wide_String;
+
+ procedure Set_Bounded_Wide_Wide_String
+ (Target : out Bounded_Wide_Wide_String;
+ Source : Wide_Wide_String;
+ Drop : Truncation := Error);
+ pragma Ada_05 (Set_Bounded_Wide_Wide_String);
+
+ function Append
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ function Append
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ function Append
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ function Append
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_Character;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ function Append
+ (Left : Wide_Wide_Character;
+ Right : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ procedure Append
+ (Source : in out Bounded_Wide_Wide_String;
+ New_Item : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ procedure Append
+ (Source : in out Bounded_Wide_Wide_String;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ procedure Append
+ (Source : in out Bounded_Wide_Wide_String;
+ New_Item : Wide_Wide_Character;
+ Drop : Truncation := Error);
+
+ function "&"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Bounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_Character) return Bounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Wide_Wide_Character;
+ Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String;
+
+ function Element
+ (Source : Bounded_Wide_Wide_String;
+ Index : Positive) return Wide_Wide_Character;
+
+ procedure Replace_Element
+ (Source : in out Bounded_Wide_Wide_String;
+ Index : Positive;
+ By : Wide_Wide_Character);
+
+ function Slice
+ (Source : Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Wide_Wide_String;
+
+ function Bounded_Slice
+ (Source : Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Bounded_Wide_Wide_String;
+ pragma Ada_05 (Bounded_Slice);
+
+ procedure Bounded_Slice
+ (Source : Bounded_Wide_Wide_String;
+ Target : out Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural);
+ pragma Ada_05 (Bounded_Slice);
+
+ function "="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function "="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "="
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean;
+
+ ----------------------
+ -- Search Functions --
+ ----------------------
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index);
+
+ function Index_Non_Blank
+ (Source : Bounded_Wide_Wide_String;
+ Going : Direction := Forward) return Natural;
+
+ function Index_Non_Blank
+ (Source : Bounded_Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index_Non_Blank);
+
+ function Count
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : Bounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural;
+
+ procedure Find_Token
+ (Source : Bounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : Bounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Bounded_Wide_Wide_String;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping);
+
+ function Translate
+ (Source : Bounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Bounded_Wide_Wide_String;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function);
+
+ ---------------------------------------
+ -- String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ procedure Replace_Slice
+ (Source : in out Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ function Insert
+ (Source : Bounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ procedure Insert
+ (Source : in out Bounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ function Overwrite
+ (Source : Bounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ procedure Overwrite
+ (Source : in out Bounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ function Delete
+ (Source : Bounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural) return Bounded_Wide_Wide_String;
+
+ procedure Delete
+ (Source : in out Bounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural);
+
+ ---------------------------------
+ -- String Selector Subprograms --
+ ---------------------------------
+
+ function Trim
+ (Source : Bounded_Wide_Wide_String;
+ Side : Trim_End) return Bounded_Wide_Wide_String;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_Wide_String;
+ Side : Trim_End);
+
+ function Trim
+ (Source : Bounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ return Bounded_Wide_Wide_String;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set);
+
+ function Head
+ (Source : Bounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ procedure Head
+ (Source : in out Bounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error);
+
+ function Tail
+ (Source : Bounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ procedure Tail
+ (Source : in out Bounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error);
+
+ ------------------------------------
+ -- String Constructor Subprograms --
+ ------------------------------------
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_Character) return Bounded_Wide_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_String) return Bounded_Wide_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String;
+
+ function Replicate
+ (Count : Natural;
+ Item : Wide_Wide_Character;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ function Replicate
+ (Count : Natural;
+ Item : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ function Replicate
+ (Count : Natural;
+ Item : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String;
+
+ private
+ -- Most of the implementation is in the separate non generic package
+ -- Ada.Strings.Wide_Wide_Superbounded. Type Bounded_Wide_Wide_String is
+ -- derived from type Wide_Wide_Superbounded.Super_String with the
+ -- maximum length constraint. In almost all cases, the routines in
+ -- Wide_Wide_Superbounded can be called with no requirement to pass the
+ -- maximum length explicitly, since there is at least one
+ -- Bounded_Wide_Wide_String argument from which the maximum length can
+ -- be obtained. For all such routines, the implementation in this
+ -- private part is simply renaming of the corresponding routine in the
+ -- super bouded package.
+
+ -- The five exceptions are the * and Replicate routines operating on
+ -- character values. For these cases, we have a routine in the body
+ -- that calls the superbounded routine passing the maximum length
+ -- explicitly as an extra parameter.
+
+ type Bounded_Wide_Wide_String is
+ new Wide_Wide_Superbounded.Super_String (Max_Length);
+ -- Deriving Bounded_Wide_Wide_String from
+ -- Wide_Wide_Superbounded.Super_String is the real trick, it ensures
+ -- that the type Bounded_Wide_Wide_String declared in the generic
+ -- instantiation is compatible with the Super_String type declared in
+ -- the Wide_Wide_Superbounded package.
+
+ Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String :=
+ (Max_Length => Max_Length,
+ Current_Length => 0,
+ Data =>
+ (1 .. Max_Length =>
+ Wide_Wide_Superbounded.Wide_Wide_NUL));
+
+ pragma Inline (To_Bounded_Wide_Wide_String);
+
+ procedure Set_Bounded_Wide_Wide_String
+ (Target : out Bounded_Wide_Wide_String;
+ Source : Wide_Wide_String;
+ Drop : Truncation := Error)
+ renames Set_Super_String;
+
+ function Length
+ (Source : Bounded_Wide_Wide_String) return Length_Range
+ renames Super_Length;
+
+ function To_Wide_Wide_String
+ (Source : Bounded_Wide_Wide_String) return Wide_Wide_String
+ renames Super_To_String;
+
+ function Append
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Append;
+
+ function Append
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Append;
+
+ function Append
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Append;
+
+ function Append
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_Character;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Append;
+
+ function Append
+ (Left : Wide_Wide_Character;
+ Right : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_Wide_String;
+ New_Item : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error)
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_Wide_String;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error)
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_Wide_String;
+ New_Item : Wide_Wide_Character;
+ Drop : Truncation := Error)
+ renames Super_Append;
+
+ function "&"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String
+ renames Concat;
+
+ function "&"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Bounded_Wide_Wide_String
+ renames Concat;
+
+ function "&"
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String
+ renames Concat;
+
+ function "&"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_Character) return Bounded_Wide_Wide_String
+ renames Concat;
+
+ function "&"
+ (Left : Wide_Wide_Character;
+ Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String
+ renames Concat;
+
+ function Element
+ (Source : Bounded_Wide_Wide_String;
+ Index : Positive) return Wide_Wide_Character
+ renames Super_Element;
+
+ procedure Replace_Element
+ (Source : in out Bounded_Wide_Wide_String;
+ Index : Positive;
+ By : Wide_Wide_Character)
+ renames Super_Replace_Element;
+
+ function Slice
+ (Source : Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Wide_Wide_String
+ renames Super_Slice;
+
+ function Bounded_Slice
+ (Source : Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Bounded_Wide_Wide_String
+ renames Super_Slice;
+
+ procedure Bounded_Slice
+ (Source : Bounded_Wide_Wide_String;
+ Target : out Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural)
+ renames Super_Slice;
+
+ function "="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Equal;
+
+ function "="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ renames Equal;
+
+ function "="
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Equal;
+
+ function "<"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Less;
+
+ function "<"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ renames Less;
+
+ function "<"
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Less;
+
+ function "<="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Less_Or_Equal;
+
+ function "<="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ renames Less_Or_Equal;
+
+ function "<="
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Less_Or_Equal;
+
+ function ">"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Greater;
+
+ function ">"
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ renames Greater;
+
+ function ">"
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Greater;
+
+ function ">="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Greater_Or_Equal;
+
+ function ">="
+ (Left : Bounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ renames Greater_Or_Equal;
+
+ function ">="
+ (Left : Wide_Wide_String;
+ Right : Bounded_Wide_Wide_String) return Boolean
+ renames Greater_Or_Equal;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : Bounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ renames Super_Index;
+
+ function Index_Non_Blank
+ (Source : Bounded_Wide_Wide_String;
+ Going : Direction := Forward) return Natural
+ renames Super_Index_Non_Blank;
+
+ function Index_Non_Blank
+ (Source : Bounded_Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural
+ renames Super_Index_Non_Blank;
+
+ function Count
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ renames Super_Count;
+
+ function Count
+ (Source : Bounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ renames Super_Count;
+
+ function Count
+ (Source : Bounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural
+ renames Super_Count;
+
+ procedure Find_Token
+ (Source : Bounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural)
+ renames Super_Find_Token;
+
+ function Translate
+ (Source : Bounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Bounded_Wide_Wide_String
+ renames Super_Translate;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ renames Super_Translate;
+
+ function Translate
+ (Source : Bounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Bounded_Wide_Wide_String
+ renames Super_Translate;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ renames Super_Translate;
+
+ function Replace_Slice
+ (Source : Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Bounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Truncation := Error)
+ renames Super_Replace_Slice;
+
+ function Insert
+ (Source : Bounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Insert;
+
+ procedure Insert
+ (Source : in out Bounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error)
+ renames Super_Insert;
+
+ function Overwrite
+ (Source : Bounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Overwrite;
+
+ procedure Overwrite
+ (Source : in out Bounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error)
+ renames Super_Overwrite;
+
+ function Delete
+ (Source : Bounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural) return Bounded_Wide_Wide_String
+ renames Super_Delete;
+
+ procedure Delete
+ (Source : in out Bounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural)
+ renames Super_Delete;
+
+ function Trim
+ (Source : Bounded_Wide_Wide_String;
+ Side : Trim_End) return Bounded_Wide_Wide_String
+ renames Super_Trim;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_Wide_String;
+ Side : Trim_End)
+ renames Super_Trim;
+
+ function Trim
+ (Source : Bounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ return Bounded_Wide_Wide_String
+ renames Super_Trim;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ renames Super_Trim;
+
+ function Head
+ (Source : Bounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Head;
+
+ procedure Head
+ (Source : in out Bounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error)
+ renames Super_Head;
+
+ function Tail
+ (Source : Bounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Tail;
+
+ procedure Tail
+ (Source : in out Bounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error)
+ renames Super_Tail;
+
+ function "*"
+ (Left : Natural;
+ Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String
+ renames Times;
+
+ function Replicate
+ (Count : Natural;
+ Item : Bounded_Wide_Wide_String;
+ Drop : Truncation := Error) return Bounded_Wide_Wide_String
+ renames Super_Replicate;
+
+ end Generic_Bounded_Length;
+
+end Ada.Strings.Wide_Wide_Bounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ F I X E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps;
+with Ada.Strings.Wide_Wide_Search;
+
+package body Ada.Strings.Wide_Wide_Fixed is
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ renames Ada.Strings.Wide_Wide_Search.Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ renames Ada.Strings.Wide_Wide_Search.Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ renames Ada.Strings.Wide_Wide_Search.Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ renames Ada.Strings.Wide_Wide_Search.Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ renames Ada.Strings.Wide_Wide_Search.Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ renames Ada.Strings.Wide_Wide_Search.Index;
+
+ function Index_Non_Blank
+ (Source : Wide_Wide_String;
+ Going : Direction := Forward) return Natural
+ renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank;
+
+ function Index_Non_Blank
+ (Source : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural
+ renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ renames Ada.Strings.Wide_Wide_Search.Count;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ renames Ada.Strings.Wide_Wide_Search.Count;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural
+ renames Ada.Strings.Wide_Wide_Search.Count;
+
+ procedure Find_Token
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural)
+ renames Ada.Strings.Wide_Wide_Search.Find_Token;
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_Character) return Wide_Wide_String
+ is
+ Result : Wide_Wide_String (1 .. Left);
+
+ begin
+ for J in Result'Range loop
+ Result (J) := Right;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_String) return Wide_Wide_String
+ is
+ Result : Wide_Wide_String (1 .. Left * Right'Length);
+ Ptr : Integer := 1;
+
+ begin
+ for J in 1 .. Left loop
+ Result (Ptr .. Ptr + Right'Length - 1) := Right;
+ Ptr := Ptr + Right'Length;
+ end loop;
+
+ return Result;
+ end "*";
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : Wide_Wide_String;
+ From : Positive;
+ Through : Natural) return Wide_Wide_String
+ is
+ begin
+ if From not in Source'Range
+ or else Through > Source'Last
+ then
+ raise Index_Error;
+
+ elsif From > Through then
+ return Source;
+
+ else
+ declare
+ Len : constant Integer := Source'Length - (Through - From + 1);
+ Result : constant Wide_Wide_String
+ (Source'First .. Source'First + Len - 1) :=
+ Source (Source'First .. From - 1) &
+ Source (Through + 1 .. Source'Last);
+ begin
+ return Result;
+ end;
+ end if;
+ end Delete;
+
+ procedure Delete
+ (Source : in out Wide_Wide_String;
+ From : Positive;
+ Through : Natural;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ begin
+ Move (Source => Delete (Source, From, Through),
+ Target => Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Delete;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String
+ is
+ Result : Wide_Wide_String (1 .. Count);
+
+ begin
+ if Count <= Source'Length then
+ Result := Source (Source'First .. Source'First + Count - 1);
+
+ else
+ Result (1 .. Source'Length) := Source;
+
+ for J in Source'Length + 1 .. Count loop
+ Result (J) := Pad;
+ end loop;
+ end if;
+
+ return Result;
+ end Head;
+
+ procedure Head
+ (Source : in out Wide_Wide_String;
+ Count : Natural;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space)
+ is
+ begin
+ Move (Source => Head (Source, Count, Pad),
+ Target => Source,
+ Drop => Error,
+ Justify => Justify,
+ Pad => Pad);
+ end Head;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String) return Wide_Wide_String
+ is
+ Result : Wide_Wide_String (1 .. Source'Length + New_Item'Length);
+
+ begin
+ if Before < Source'First or else Before > Source'Last + 1 then
+ raise Index_Error;
+ end if;
+
+ Result := Source (Source'First .. Before - 1) & New_Item &
+ Source (Before .. Source'Last);
+ return Result;
+ end Insert;
+
+ procedure Insert
+ (Source : in out Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error)
+ is
+ begin
+ Move (Source => Insert (Source, Before, New_Item),
+ Target => Source,
+ Drop => Drop);
+ end Insert;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Source : Wide_Wide_String;
+ Target : out Wide_Wide_String;
+ Drop : Truncation := Error;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ Sfirst : constant Integer := Source'First;
+ Slast : constant Integer := Source'Last;
+ Slength : constant Integer := Source'Length;
+
+ Tfirst : constant Integer := Target'First;
+ Tlast : constant Integer := Target'Last;
+ Tlength : constant Integer := Target'Length;
+
+ function Is_Padding (Item : Wide_Wide_String) return Boolean;
+ -- Determinbe if all characters in Item are pad characters
+
+ function Is_Padding (Item : Wide_Wide_String) return Boolean is
+ begin
+ for J in Item'Range loop
+ if Item (J) /= Pad then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Is_Padding;
+
+ -- Start of processing for Move
+
+ begin
+ if Slength = Tlength then
+ Target := Source;
+
+ elsif Slength > Tlength then
+
+ case Drop is
+ when Left =>
+ Target := Source (Slast - Tlength + 1 .. Slast);
+
+ when Right =>
+ Target := Source (Sfirst .. Sfirst + Tlength - 1);
+
+ when Error =>
+ case Justify is
+ when Left =>
+ if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
+ Target :=
+ Source (Sfirst .. Sfirst + Target'Length - 1);
+ else
+ raise Length_Error;
+ end if;
+
+ when Right =>
+ if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
+ Target := Source (Slast - Tlength + 1 .. Slast);
+ else
+ raise Length_Error;
+ end if;
+
+ when Center =>
+ raise Length_Error;
+ end case;
+
+ end case;
+
+ -- Source'Length < Target'Length
+
+ else
+ case Justify is
+ when Left =>
+ Target (Tfirst .. Tfirst + Slength - 1) := Source;
+
+ for J in Tfirst + Slength .. Tlast loop
+ Target (J) := Pad;
+ end loop;
+
+ when Right =>
+ for J in Tfirst .. Tlast - Slength loop
+ Target (J) := Pad;
+ end loop;
+
+ Target (Tlast - Slength + 1 .. Tlast) := Source;
+
+ when Center =>
+ declare
+ Front_Pad : constant Integer := (Tlength - Slength) / 2;
+ Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
+
+ begin
+ for J in Tfirst .. Tfirst_Fpad - 1 loop
+ Target (J) := Pad;
+ end loop;
+
+ Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
+
+ for J in Tfirst_Fpad + Slength .. Tlast loop
+ Target (J) := Pad;
+ end loop;
+ end;
+ end case;
+ end if;
+ end Move;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String) return Wide_Wide_String
+ is
+ begin
+ if Position not in Source'First .. Source'Last + 1 then
+ raise Index_Error;
+ else
+ declare
+ Result_Length : constant Natural :=
+ Natural'Max
+ (Source'Length,
+ Position - Source'First + New_Item'Length);
+
+ Result : Wide_Wide_String (1 .. Result_Length);
+
+ begin
+ Result := Source (Source'First .. Position - 1) & New_Item &
+ Source (Position + New_Item'Length .. Source'Last);
+ return Result;
+ end;
+ end if;
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Right)
+ is
+ begin
+ Move (Source => Overwrite (Source, Position, New_Item),
+ Target => Source,
+ Drop => Drop);
+ end Overwrite;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String) return Wide_Wide_String
+ is
+ Result_Length : Natural;
+
+ begin
+ if Low > Source'Last + 1 or else High < Source'First - 1 then
+ raise Index_Error;
+ else
+ Result_Length :=
+ Source'Length - Natural'Max (High - Low + 1, 0) + By'Length;
+
+ declare
+ Result : Wide_Wide_String (1 .. Result_Length);
+
+ begin
+ if High >= Low then
+ Result :=
+ Source (Source'First .. Low - 1) & By &
+ Source (High + 1 .. Source'Last);
+ else
+ Result := Source (Source'First .. Low - 1) & By &
+ Source (Low .. Source'Last);
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Truncation := Error;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ begin
+ Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
+ end Replace_Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String
+ is
+ Result : Wide_Wide_String (1 .. Count);
+
+ begin
+ if Count < Source'Length then
+ Result := Source (Source'Last - Count + 1 .. Source'Last);
+
+ -- Pad on left
+
+ else
+ for J in 1 .. Count - Source'Length loop
+ Result (J) := Pad;
+ end loop;
+
+ Result (Count - Source'Length + 1 .. Count) := Source;
+ end if;
+
+ return Result;
+ end Tail;
+
+ procedure Tail
+ (Source : in out Wide_Wide_String;
+ Count : Natural;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space)
+ is
+ begin
+ Move (Source => Tail (Source, Count, Pad),
+ Target => Source,
+ Drop => Error,
+ Justify => Justify,
+ Pad => Pad);
+ end Tail;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Wide_Wide_String
+ is
+ Result : Wide_Wide_String (1 .. Source'Length);
+
+ begin
+ for J in Source'Range loop
+ Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ is
+ begin
+ for J in Source'Range loop
+ Source (J) := Value (Mapping, Source (J));
+ end loop;
+ end Translate;
+
+ function Translate
+ (Source : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Wide_Wide_String
+ is
+ Result : Wide_Wide_String (1 .. Source'Length);
+
+ begin
+ for J in Source'Range loop
+ Result (J - (Source'First - 1)) := Mapping (Source (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ is
+ begin
+ for J in Source'Range loop
+ Source (J) := Mapping (Source (J));
+ end loop;
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : Wide_Wide_String;
+ Side : Trim_End) return Wide_Wide_String
+ is
+ Low : Natural := Source'First;
+ High : Natural := Source'Last;
+
+ begin
+ if Side = Left or else Side = Both then
+ while Low <= High and then Source (Low) = Wide_Wide_Space loop
+ Low := Low + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while High >= Low and then Source (High) = Wide_Wide_Space loop
+ High := High - 1;
+ end loop;
+ end if;
+
+ -- All blanks case
+
+ if Low > High then
+ return "";
+
+ -- At least one non-blank
+
+ else
+ declare
+ Result : constant Wide_Wide_String (1 .. High - Low + 1) :=
+ Source (Low .. High);
+
+ begin
+ return Result;
+ end;
+ end if;
+ end Trim;
+
+ procedure Trim
+ (Source : in out Wide_Wide_String;
+ Side : Trim_End;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ begin
+ Move (Source => Trim (Source, Side),
+ Target => Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Trim;
+
+ function Trim
+ (Source : Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Wide_Wide_String
+ is
+ Low : Natural := Source'First;
+ High : Natural := Source'Last;
+
+ begin
+ while Low <= High and then Is_In (Source (Low), Left) loop
+ Low := Low + 1;
+ end loop;
+
+ while High >= Low and then Is_In (Source (High), Right) loop
+ High := High - 1;
+ end loop;
+
+ -- Case where source comprises only characters in the sets
+
+ if Low > High then
+ return "";
+ else
+ declare
+ subtype WS is Wide_Wide_String (1 .. High - Low + 1);
+
+ begin
+ return WS (Source (Low .. High));
+ end;
+ end if;
+ end Trim;
+
+ procedure Trim
+ (Source : in out Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Justify : Alignment := Strings.Left;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ begin
+ Move (Source => Trim (Source, Left, Right),
+ Target => Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Trim;
+
+end Ada.Strings.Wide_Wide_Fixed;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+
+with Ada.Strings.Wide_Wide_Maps;
+
+package Ada.Strings.Wide_Wide_Fixed is
+pragma Preelaborate (Wide_Wide_Fixed);
+
+ ------------------------------------------------------------------------
+ -- Copy Procedure for Wide_Wide_Strings of Possibly Different Lengths --
+ ------------------------------------------------------------------------
+
+ procedure Move
+ (Source : Wide_Wide_String;
+ Target : out Wide_Wide_String;
+ Drop : Truncation := Error;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space);
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index);
+
+ function Index_Non_Blank
+ (Source : Wide_Wide_String;
+ Going : Direction := Forward) return Natural;
+
+ function Index_Non_Blank
+ (Source : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index_Non_Blank);
+
+ function Count
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural;
+
+ procedure Find_Token
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ----------------------------------------------
+ -- Wide_Wide_String Translation Subprograms --
+ ----------------------------------------------
+
+ function Translate
+ (Source : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Wide_Wide_String;
+
+ procedure Translate
+ (Source : in out Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping);
+
+ function Translate
+ (Source : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Wide_Wide_String;
+
+ procedure Translate
+ (Source : in out Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function);
+
+ -------------------------------------------------
+ -- Wide_Wide_String Transformation Subprograms --
+ -------------------------------------------------
+
+ function Replace_Slice
+ (Source : Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String) return Wide_Wide_String;
+
+ procedure Replace_Slice
+ (Source : in out Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Truncation := Error;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space);
+
+ function Insert
+ (Source : Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String) return Wide_Wide_String;
+
+ procedure Insert
+ (Source : in out Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ function Overwrite
+ (Source : Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String) return Wide_Wide_String;
+
+ procedure Overwrite
+ (Source : in out Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Right);
+
+ function Delete
+ (Source : Wide_Wide_String;
+ From : Positive;
+ Through : Natural) return Wide_Wide_String;
+
+ procedure Delete
+ (Source : in out Wide_Wide_String;
+ From : Positive;
+ Through : Natural;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space);
+
+ -------------------------------------------
+ -- Wide_Wide_String Selector Subprograms --
+ -------------------------------------------
+
+ function Trim
+ (Source : Wide_Wide_String;
+ Side : Trim_End) return Wide_Wide_String;
+
+ procedure Trim
+ (Source : in out Wide_Wide_String;
+ Side : Trim_End;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Wide_Wide_Space);
+
+ function Trim
+ (Source : Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ return Wide_Wide_String;
+
+ procedure Trim
+ (Source : in out Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Justify : Alignment := Ada.Strings.Left;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space);
+
+ function Head
+ (Source : Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space)
+ return Wide_Wide_String;
+
+ procedure Head
+ (Source : in out Wide_Wide_String;
+ Count : Natural;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space);
+
+ function Tail
+ (Source : Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space)
+ return Wide_Wide_String;
+
+ procedure Tail
+ (Source : in out Wide_Wide_String;
+ Count : Natural;
+ Justify : Alignment := Left;
+ Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space);
+
+ --------------------------------------------
+ -- Wide_Wide_String Constructor Functions --
+ --------------------------------------------
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_Character) return Wide_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_String) return Wide_Wide_String;
+
+end Ada.Strings.Wide_Wide_Fixed;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ H A S H --
+-- --
+-- B o d y --
+-- --
+-- 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 --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Wide_Wide_Hash
+ (Key : Wide_Wide_String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in Key'Range loop
+ Tmp := Rotate_Left (Tmp, 1) + Wide_Wide_Character'Pos (Key (J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Wide_Wide_Hash;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ H A S H --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Wide_Wide_Hash
+ (Key : Wide_Wide_String) return Containers.Hash_Type;
+
+pragma Pure (Ada.Strings.Wide_Wide_Hash);
+
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ M A P S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Deallocation;
+
+package body Ada.Strings.Wide_Wide_Maps is
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
+ is
+ LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
+ RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
+
+ Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+ -- Each range on the right can generate at least one more range in
+ -- the result, by splitting one of the left operand ranges.
+
+ N : Natural := 0;
+ R : Natural := 1;
+ L : Natural := 1;
+
+ Left_Low : Wide_Wide_Character;
+ -- Left_Low is lowest character of the L'th range not yet dealt with
+
+ begin
+ if LS'Last = 0 or else RS'Last = 0 then
+ return Left;
+ end if;
+
+ Left_Low := LS (L).Low;
+ while R <= RS'Last loop
+
+ -- If next right range is below current left range, skip it
+
+ if RS (R).High < Left_Low then
+ R := R + 1;
+
+ -- If next right range above current left range, copy remainder of
+ -- the left range to the result
+
+ elsif RS (R).Low > LS (L).High then
+ N := N + 1;
+ Result (N).Low := Left_Low;
+ Result (N).High := LS (L).High;
+ L := L + 1;
+ exit when L > LS'Last;
+ Left_Low := LS (L).Low;
+
+ else
+ -- Next right range overlaps bottom of left range
+
+ if RS (R).Low <= Left_Low then
+
+ -- Case of right range complete overlaps left range
+
+ if RS (R).High >= LS (L).High then
+ L := L + 1;
+ exit when L > LS'Last;
+ Left_Low := LS (L).Low;
+
+ -- Case of right range eats lower part of left range
+
+ else
+ Left_Low := Wide_Wide_Character'Succ (RS (R).High);
+ R := R + 1;
+ end if;
+
+ -- Next right range overlaps some of left range, but not bottom
+
+ else
+ N := N + 1;
+ Result (N).Low := Left_Low;
+ Result (N).High := Wide_Wide_Character'Pred (RS (R).Low);
+
+ -- Case of right range splits left range
+
+ if RS (R).High < LS (L).High then
+ Left_Low := Wide_Wide_Character'Succ (RS (R).High);
+ R := R + 1;
+
+ -- Case of right range overlaps top of left range
+
+ else
+ L := L + 1;
+ exit when L > LS'Last;
+ Left_Low := LS (L).Low;
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ -- Copy remainder of left ranges to result
+
+ if L <= LS'Last then
+ N := N + 1;
+ Result (N).Low := Left_Low;
+ Result (N).High := LS (L).High;
+
+ loop
+ L := L + 1;
+ exit when L > LS'Last;
+ N := N + 1;
+ Result (N) := LS (L);
+ end loop;
+ end if;
+
+ return (AF.Controlled with
+ Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
+ end "-";
+
+ ---------
+ -- "=" --
+ ---------
+
+ -- The sorted, discontiguous form is canonical, so equality can be used
+
+ function "=" (Left, Right : in Wide_Wide_Character_Set) return Boolean is
+ begin
+ return Left.Set.all = Right.Set.all;
+ end "=";
+
+ -----------
+ -- "and" --
+ -----------
+
+ function "and"
+ (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
+ is
+ LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
+ RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
+
+ Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+ N : Natural := 0;
+ L, R : Natural := 1;
+
+ begin
+ -- Loop to search for overlapping character ranges
+
+ while L <= LS'Last and then R <= RS'Last loop
+
+ if LS (L).High < RS (R).Low then
+ L := L + 1;
+
+ elsif RS (R).High < LS (L).Low then
+ R := R + 1;
+
+ -- Here we have LS (L).High >= RS (R).Low
+ -- and RS (R).High >= LS (L).Low
+ -- so we have an overlapping range
+
+ else
+ N := N + 1;
+ Result (N).Low :=
+ Wide_Wide_Character'Max (LS (L).Low, RS (R).Low);
+ Result (N).High :=
+ Wide_Wide_Character'Min (LS (L).High, RS (R).High);
+
+ if RS (R).High = LS (L).High then
+ L := L + 1;
+ R := R + 1;
+ elsif RS (R).High < LS (L).High then
+ R := R + 1;
+ else
+ L := L + 1;
+ end if;
+ end if;
+ end loop;
+
+ return (AF.Controlled with
+ Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
+ end "and";
+
+ -----------
+ -- "not" --
+ -----------
+
+ function "not"
+ (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
+ is
+ RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
+
+ Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1);
+ N : Natural := 0;
+
+ begin
+ if RS'Last = 0 then
+ N := 1;
+ Result (1) := (Low => Wide_Wide_Character'First,
+ High => Wide_Wide_Character'Last);
+
+ else
+ if RS (1).Low /= Wide_Wide_Character'First then
+ N := N + 1;
+ Result (N).Low := Wide_Wide_Character'First;
+ Result (N).High := Wide_Wide_Character'Pred (RS (1).Low);
+ end if;
+
+ for K in 1 .. RS'Last - 1 loop
+ N := N + 1;
+ Result (N).Low := Wide_Wide_Character'Succ (RS (K).High);
+ Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low);
+ end loop;
+
+ if RS (RS'Last).High /= Wide_Wide_Character'Last then
+ N := N + 1;
+ Result (N).Low := Wide_Wide_Character'Succ (RS (RS'Last).High);
+ Result (N).High := Wide_Wide_Character'Last;
+ end if;
+ end if;
+
+ return (AF.Controlled with
+ Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
+ end "not";
+
+ ----------
+ -- "or" --
+ ----------
+
+ function "or"
+ (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
+ is
+ LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
+ RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
+
+ Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+ N : Natural;
+ L, R : Natural;
+
+ begin
+ N := 0;
+ L := 1;
+ R := 1;
+
+ -- Loop through ranges in output file
+
+ loop
+ -- If no left ranges left, copy next right range
+
+ if L > LS'Last then
+ exit when R > RS'Last;
+ N := N + 1;
+ Result (N) := RS (R);
+ R := R + 1;
+
+ -- If no right ranges left, copy next left range
+
+ elsif R > RS'Last then
+ N := N + 1;
+ Result (N) := LS (L);
+ L := L + 1;
+
+ else
+ -- We have two ranges, choose lower one
+
+ N := N + 1;
+
+ if LS (L).Low <= RS (R).Low then
+ Result (N) := LS (L);
+ L := L + 1;
+ else
+ Result (N) := RS (R);
+ R := R + 1;
+ end if;
+
+ -- Loop to collapse ranges into last range
+
+ loop
+ -- Collapse next length range into current result range
+ -- if possible.
+
+ if L <= LS'Last
+ and then LS (L).Low <=
+ Wide_Wide_Character'Succ (Result (N).High)
+ then
+ Result (N).High :=
+ Wide_Wide_Character'Max (Result (N).High, LS (L).High);
+ L := L + 1;
+
+ -- Collapse next right range into current result range
+ -- if possible
+
+ elsif R <= RS'Last
+ and then RS (R).Low <=
+ Wide_Wide_Character'Succ (Result (N).High)
+ then
+ Result (N).High :=
+ Wide_Wide_Character'Max (Result (N).High, RS (R).High);
+ R := R + 1;
+
+ -- If neither range collapses, then done with this range
+
+ else
+ exit;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ return (AF.Controlled with
+ Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
+ end "or";
+
+ -----------
+ -- "xor" --
+ -----------
+
+ function "xor"
+ (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
+ is
+ begin
+ return (Left or Right) - (Left and Right);
+ end "xor";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is
+ begin
+ Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all);
+ end Adjust;
+
+ procedure Adjust (Object : in out Wide_Wide_Character_Set) is
+ begin
+ Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all);
+ end Adjust;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is
+
+ procedure Free is new Unchecked_Deallocation
+ (Wide_Wide_Character_Mapping_Values,
+ Wide_Wide_Character_Mapping_Values_Access);
+
+ begin
+ if Object.Map /= Null_Map'Unrestricted_Access then
+ Free (Object.Map);
+ end if;
+ end Finalize;
+
+ procedure Finalize (Object : in out Wide_Wide_Character_Set) is
+
+ procedure Free is new Unchecked_Deallocation
+ (Wide_Wide_Character_Ranges,
+ Wide_Wide_Character_Ranges_Access);
+
+ begin
+ if Object.Set /= Null_Range'Unrestricted_Access then
+ Free (Object.Set);
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is
+ begin
+ Object := Identity;
+ end Initialize;
+
+ procedure Initialize (Object : in out Wide_Wide_Character_Set) is
+ begin
+ Object := Null_Set;
+ end Initialize;
+
+ -----------
+ -- Is_In --
+ -----------
+
+ function Is_In
+ (Element : Wide_Wide_Character;
+ Set : Wide_Wide_Character_Set) return Boolean
+ is
+ L, R, M : Natural;
+ SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
+
+ begin
+ L := 1;
+ R := SS'Last;
+
+ -- Binary search loop. The invariant is that if Element is in any of
+ -- of the constituent ranges it is in one between Set (L) and Set (R).
+
+ loop
+ if L > R then
+ return False;
+
+ else
+ M := (L + R) / 2;
+
+ if Element > SS (M).High then
+ L := M + 1;
+ elsif Element < SS (M).Low then
+ R := M - 1;
+ else
+ return True;
+ end if;
+ end if;
+ end loop;
+ end Is_In;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset
+ (Elements : Wide_Wide_Character_Set;
+ Set : Wide_Wide_Character_Set) return Boolean
+ is
+ ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set;
+ SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
+
+ S : Positive := 1;
+ E : Positive := 1;
+
+ begin
+ loop
+ -- If no more element ranges, done, and result is true
+
+ if E > ES'Last then
+ return True;
+
+ -- If more element ranges, but no more set ranges, result is false
+
+ elsif S > SS'Last then
+ return False;
+
+ -- Remove irrelevant set range
+
+ elsif SS (S).High < ES (E).Low then
+ S := S + 1;
+
+ -- Get rid of element range that is properly covered by set
+
+ elsif SS (S).Low <= ES (E).Low
+ and then ES (E).High <= SS (S).High
+ then
+ E := E + 1;
+
+ -- Otherwise we have a non-covered element range, result is false
+
+ else
+ return False;
+ end if;
+ end loop;
+ end Is_Subset;
+
+ ---------------
+ -- To_Domain --
+ ---------------
+
+ function To_Domain
+ (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
+ is
+ begin
+ return Map.Map.Domain;
+ end To_Domain;
+
+ ----------------
+ -- To_Mapping --
+ ----------------
+
+ function To_Mapping
+ (From, To : Wide_Wide_Character_Sequence)
+ return Wide_Wide_Character_Mapping
+ is
+ Domain : Wide_Wide_Character_Sequence (1 .. From'Length);
+ Rangev : Wide_Wide_Character_Sequence (1 .. To'Length);
+ N : Natural := 0;
+
+ begin
+ if From'Length /= To'Length then
+ raise Translation_Error;
+
+ else
+ pragma Warnings (Off); -- apparent uninit use of Domain
+
+ for J in From'Range loop
+ for M in 1 .. N loop
+ if From (J) = Domain (M) then
+ raise Translation_Error;
+ elsif From (J) < Domain (M) then
+ Domain (M + 1 .. N + 1) := Domain (M .. N);
+ Rangev (M + 1 .. N + 1) := Rangev (M .. N);
+ Domain (M) := From (J);
+ Rangev (M) := To (J);
+ goto Continue;
+ end if;
+ end loop;
+
+ Domain (N + 1) := From (J);
+ Rangev (N + 1) := To (J);
+
+ <<Continue>>
+ N := N + 1;
+ end loop;
+
+ pragma Warnings (On);
+
+ return (AF.Controlled with
+ Map => new Wide_Wide_Character_Mapping_Values'(
+ Length => N,
+ Domain => Domain (1 .. N),
+ Rangev => Rangev (1 .. N)));
+ end if;
+ end To_Mapping;
+
+ --------------
+ -- To_Range --
+ --------------
+
+ function To_Range
+ (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
+ is
+ begin
+ return Map.Map.Rangev;
+ end To_Range;
+
+ ---------------
+ -- To_Ranges --
+ ---------------
+
+ function To_Ranges
+ (Set : in Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges
+ is
+ begin
+ return Set.Set.all;
+ end To_Ranges;
+
+ -----------------
+ -- To_Sequence --
+ -----------------
+
+ function To_Sequence
+ (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence
+ is
+ SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
+
+ Result : Wide_Wide_String (Positive range 1 .. 2 ** 16);
+ N : Natural := 0;
+
+ begin
+ for J in SS'Range loop
+ for K in SS (J).Low .. SS (J).High loop
+ N := N + 1;
+ Result (N) := K;
+ end loop;
+ end loop;
+
+ return Result (1 .. N);
+ end To_Sequence;
+
+ ------------
+ -- To_Set --
+ ------------
+
+ -- Case of multiple range input
+
+ function To_Set
+ (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set
+ is
+ Result : Wide_Wide_Character_Ranges (Ranges'Range);
+ N : Natural := 0;
+ J : Natural;
+
+ begin
+ -- The output of To_Set is required to be sorted by increasing Low
+ -- values, and discontiguous, so first we sort them as we enter them,
+ -- using a simple insertion sort.
+
+ pragma Warnings (Off);
+ -- Kill bogus warning on Result being uninitialized
+
+ for J in Ranges'Range loop
+ for K in 1 .. N loop
+ if Ranges (J).Low < Result (K).Low then
+ Result (K + 1 .. N + 1) := Result (K .. N);
+ Result (K) := Ranges (J);
+ goto Continue;
+ end if;
+ end loop;
+
+ Result (N + 1) := Ranges (J);
+
+ <<Continue>>
+ N := N + 1;
+ end loop;
+
+ pragma Warnings (On);
+
+ -- Now collapse any contiguous or overlapping ranges
+
+ J := 1;
+ while J < N loop
+ if Result (J).High < Result (J).Low then
+ N := N - 1;
+ Result (J .. N) := Result (J + 1 .. N + 1);
+
+ elsif Wide_Wide_Character'Succ (Result (J).High) >=
+ Result (J + 1).Low
+ then
+ Result (J).High :=
+ Wide_Wide_Character'Max (Result (J).High, Result (J + 1).High);
+
+ N := N - 1;
+ Result (J + 1 .. N) := Result (J + 2 .. N + 1);
+
+ else
+ J := J + 1;
+ end if;
+ end loop;
+
+ if Result (N).High < Result (N).Low then
+ N := N - 1;
+ end if;
+
+ return (AF.Controlled with
+ Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
+ end To_Set;
+
+ -- Case of single range input
+
+ function To_Set
+ (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set
+ is
+ begin
+ if Span.Low > Span.High then
+ return Null_Set;
+ -- This is safe, because there is no procedure with parameter
+ -- Wide_Wide_Character_Set of mode "out" or "in out".
+
+ else
+ return (AF.Controlled with
+ Set => new Wide_Wide_Character_Ranges'(1 => Span));
+ end if;
+ end To_Set;
+
+ -- Case of wide string input
+
+ function To_Set
+ (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set
+ is
+ R : Wide_Wide_Character_Ranges (1 .. Sequence'Length);
+
+ begin
+ for J in R'Range loop
+ R (J) := (Sequence (J), Sequence (J));
+ end loop;
+
+ return To_Set (R);
+ end To_Set;
+
+ -- Case of single wide character input
+
+ function To_Set
+ (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set
+ is
+ begin
+ return
+ (AF.Controlled with
+ Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton)));
+ end To_Set;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value
+ (Map : Wide_Wide_Character_Mapping;
+ Element : Wide_Wide_Character) return Wide_Wide_Character
+ is
+ L, R, M : Natural;
+
+ MV : constant Wide_Wide_Character_Mapping_Values_Access := Map.Map;
+
+ begin
+ L := 1;
+ R := MV.Domain'Last;
+
+ -- Binary search loop
+
+ loop
+ -- If not found, identity
+
+ if L > R then
+ return Element;
+
+ -- Otherwise do binary divide
+
+ else
+ M := (L + R) / 2;
+
+ if Element < MV.Domain (M) then
+ R := M - 1;
+
+ elsif Element > MV.Domain (M) then
+ L := M + 1;
+
+ else -- Element = MV.Domain (M) then
+ return MV.Rangev (M);
+ end if;
+ end if;
+ end loop;
+ end Value;
+
+end Ada.Strings.Wide_Wide_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ M A P S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+
+package Ada.Strings.Wide_Wide_Maps is
+ pragma Preelaborate (Wide_Wide_Maps);
+
+ ------------------------------------------
+ -- Wide_Wide_Character Set Declarations --
+ ------------------------------------------
+
+ type Wide_Wide_Character_Set is private;
+ -- Representation for a set of Wide_Wide_Character values:
+
+ Null_Set : constant Wide_Wide_Character_Set;
+
+ -----------------------------------------------
+ -- Constructors for Wide_Wide_Character Sets --
+ -----------------------------------------------
+
+ type Wide_Wide_Character_Range is record
+ Low : Wide_Wide_Character;
+ High : Wide_Wide_Character;
+ end record;
+ -- Represents Wide_Wide_Character range Low .. High
+
+ type Wide_Wide_Character_Ranges is
+ array (Positive range <>) of Wide_Wide_Character_Range;
+
+ function To_Set
+ (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set;
+
+ function To_Set
+ (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set;
+
+ function To_Ranges
+ (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges;
+
+ ---------------------------------------
+ -- Operations on Wide Character Sets --
+ ---------------------------------------
+
+ function "=" (Left, Right : in Wide_Wide_Character_Set) return Boolean;
+
+ function "not"
+ (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set;
+
+ function "and"
+ (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set;
+
+ function "or"
+ (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set;
+
+ function "xor"
+ (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set;
+
+ function "-"
+ (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set;
+
+ function Is_In
+ (Element : Wide_Wide_Character;
+ Set : Wide_Wide_Character_Set) return Boolean;
+
+ function Is_Subset
+ (Elements : Wide_Wide_Character_Set;
+ Set : Wide_Wide_Character_Set) return Boolean;
+
+ function "<="
+ (Left : Wide_Wide_Character_Set;
+ Right : Wide_Wide_Character_Set) return Boolean
+ renames Is_Subset;
+
+ subtype Wide_Wide_Character_Sequence is Wide_Wide_String;
+ -- Alternative representation for a set of character values
+
+ function To_Set
+ (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set;
+
+ function To_Set
+ (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set;
+
+ function To_Sequence
+ (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence;
+
+ ----------------------------------------------
+ -- Wide_Wide_Character Mapping Declarations --
+ ----------------------------------------------
+
+ type Wide_Wide_Character_Mapping is private;
+ -- Representation for a wide character to wide character mapping:
+
+ function Value
+ (Map : Wide_Wide_Character_Mapping;
+ Element : Wide_Wide_Character) return Wide_Wide_Character;
+
+ Identity : constant Wide_Wide_Character_Mapping;
+
+ --------------------------------------
+ -- Operations on Wide Wide Mappings --
+ ---------------------------------------
+
+ function To_Mapping
+ (From, To : Wide_Wide_Character_Sequence)
+ return Wide_Wide_Character_Mapping;
+
+ function To_Domain
+ (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence;
+
+ function To_Range
+ (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence;
+
+ type Wide_Wide_Character_Mapping_Function is
+ access function (From : Wide_Wide_Character) return Wide_Wide_Character;
+
+private
+ package AF renames Ada.Finalization;
+
+ -----------------------------------------------
+ -- Representation of Wide_Wide_Character_Set --
+ -----------------------------------------------
+
+ -- A wide character set is represented as a sequence of wide character
+ -- ranges (i.e. an object of type Wide_Wide_Character_Ranges) in which the
+ -- following hold:
+
+ -- The lower bound is 1
+ -- The ranges are in order by increasing Low values
+ -- The ranges are non-overlapping and discontigous
+
+ -- A character value is in the set if it is contained in one of the
+ -- ranges. The actual Wide_Wide_Character_Set value is a controlled pointer
+ -- to this Wide_Wide_Character_Ranges value. The use of a controlled type
+ -- is necessary to prevent storage leaks.
+
+ type Wide_Wide_Character_Ranges_Access is
+ access all Wide_Wide_Character_Ranges;
+
+ type Wide_Wide_Character_Set is new AF.Controlled with record
+ Set : Wide_Wide_Character_Ranges_Access;
+ end record;
+
+ pragma Finalize_Storage_Only (Wide_Wide_Character_Set);
+ -- This avoids useless finalizations, and, more importantly avoids
+ -- incorrect attempts to finalize constants that are statically
+ -- declared here and in Ada.Strings.Wide_Wide_Maps, which is incorrect.
+
+ procedure Initialize (Object : in out Wide_Wide_Character_Set);
+ procedure Adjust (Object : in out Wide_Wide_Character_Set);
+ procedure Finalize (Object : in out Wide_Wide_Character_Set);
+
+ Null_Range : aliased constant Wide_Wide_Character_Ranges :=
+ (1 .. 0 => (Low => ' ', High => ' '));
+
+ Null_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Set => Null_Range'Unrestricted_Access);
+
+ ---------------------------------------------------
+ -- Representation of Wide_Wide_Character_Mapping --
+ ---------------------------------------------------
+
+ -- A wide character mapping is represented as two strings of equal
+ -- length, where any character appearing in Domain is mapped to the
+ -- corresponding character in Rangev. A character not appearing in
+ -- Domain is mapped to itself. The characters in Domain are sorted
+ -- in ascending order.
+
+ -- The actual Wide_Wide_Character_Mapping value is a controlled record
+ -- that contains a pointer to a discriminated record containing the
+ -- range and domain values.
+
+ -- Note: this representation is canonical, and the values stored in
+ -- Domain and Rangev are exactly the values that are returned by the
+ -- functions To_Domain and To_Range. The use of a controlled type is
+ -- necessary to prevent storage leaks.
+
+ type Wide_Wide_Character_Mapping_Values (Length : Natural) is record
+ Domain : Wide_Wide_Character_Sequence (1 .. Length);
+ Rangev : Wide_Wide_Character_Sequence (1 .. Length);
+ end record;
+
+ type Wide_Wide_Character_Mapping_Values_Access is
+ access all Wide_Wide_Character_Mapping_Values;
+
+ type Wide_Wide_Character_Mapping is new AF.Controlled with record
+ Map : Wide_Wide_Character_Mapping_Values_Access;
+ end record;
+
+ pragma Finalize_Storage_Only (Wide_Wide_Character_Mapping);
+ -- This avoids useless finalizations, and, more importantly avoids
+ -- incorrect attempts to finalize constants that are statically
+ -- declared here and in Ada.Strings.Wide_Wide_Maps, which is incorrect.
+
+ procedure Initialize (Object : in out Wide_Wide_Character_Mapping);
+ procedure Adjust (Object : in out Wide_Wide_Character_Mapping);
+ procedure Finalize (Object : in out Wide_Wide_Character_Mapping);
+
+ Null_Map : aliased constant Wide_Wide_Character_Mapping_Values :=
+ (Length => 0,
+ Domain => "",
+ Rangev => "");
+
+ Identity : constant Wide_Wide_Character_Mapping :=
+ (AF.Controlled with
+ Map => Null_Map'Unrestricted_Access);
+
+end Ada.Strings.Wide_Wide_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps;
+
+package body Ada.Strings.Wide_Wide_Search is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Belongs
+ (Element : Wide_Wide_Character;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership) return Boolean;
+ pragma Inline (Belongs);
+ -- Determines if the given element is in (Test = Inside) or not in
+ -- (Test = Outside) the given character set.
+
+ -------------
+ -- Belongs --
+ -------------
+
+ function Belongs
+ (Element : Wide_Wide_Character;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership) return Boolean
+ is
+ begin
+ if Test = Inside then
+ return Is_In (Element, Set);
+ else
+ return not Is_In (Element, Set);
+ end if;
+ end Belongs;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ is
+ N : Natural;
+ J : Natural;
+
+ begin
+ if Pattern = "" then
+ raise Pattern_Error;
+ end if;
+
+ -- Handle the case of non-identity mappings by creating a mapped
+ -- string and making a recursive call using the identity mapping
+ -- on this mapped string.
+
+ if Mapping /= Wide_Wide_Maps.Identity then
+ declare
+ Mapped_Source : Wide_Wide_String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Value (Mapping, Source (J));
+ end loop;
+
+ return Count (Mapped_Source, Pattern);
+ end;
+ end if;
+
+ N := 0;
+ J := Source'First;
+
+ while J <= Source'Last - (Pattern'Length - 1) loop
+ if Source (J .. J + (Pattern'Length - 1)) = Pattern then
+ N := N + 1;
+ J := J + Pattern'Length;
+ else
+ J := J + 1;
+ end if;
+ end loop;
+
+ return N;
+ end Count;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ Mapped_Source : Wide_Wide_String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Mapping (Source (J));
+ end loop;
+
+ return Count (Mapped_Source, Pattern);
+ end Count;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural
+ is
+ N : Natural := 0;
+
+ begin
+ for J in Source'Range loop
+ if Is_In (Source (J), Set) then
+ N := N + 1;
+ end if;
+ end loop;
+
+ return N;
+ end Count;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ for J in Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ First := J;
+
+ for K in J + 1 .. Source'Last loop
+ if not Belongs (Source (K), Set, Test) then
+ Last := K - 1;
+ return;
+ end if;
+ end loop;
+
+ -- Here if J indexes 1st char of token, and all chars
+ -- after J are in the token
+
+ Last := Source'Last;
+ return;
+ end if;
+ end loop;
+
+ -- Here if no token found
+
+ First := Source'First;
+ Last := 0;
+ end Find_Token;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ if Pattern = "" then
+ raise Pattern_Error;
+ end if;
+
+ -- Handle the case of non-identity mappings by creating a mapped
+ -- string and making a recursive call using the identity mapping
+ -- on this mapped string.
+
+ if Mapping /= Identity then
+ declare
+ Mapped_Source : Wide_Wide_String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Value (Mapping, Source (J));
+ end loop;
+
+ return Index (Mapped_Source, Pattern, Going);
+ end;
+ end if;
+
+ if Going = Forward then
+ for J in Source'First .. Source'Last - Pattern'Length + 1 loop
+ if Pattern = Source (J .. J + Pattern'Length - 1) then
+ return J;
+ end if;
+ end loop;
+
+ else -- Going = Backward
+ for J in reverse Source'First .. Source'Last - Pattern'Length + 1 loop
+ if Pattern = Source (J .. J + Pattern'Length - 1) then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match found. Note that the loops are skipped
+ -- completely in the case of the pattern being longer than the source.
+
+ return 0;
+ end Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ Mapped_Source : Wide_Wide_String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Mapping (Source (J));
+ end loop;
+
+ return Index (Mapped_Source, Pattern, Going);
+ end Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ is
+ begin
+ if Going = Forward then
+ for J in Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ return J;
+ end if;
+ end loop;
+
+ else -- Going = Backward
+ for J in reverse Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match
+
+ return 0;
+ end Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ if Going = Forward then
+ if From < Source'First then
+ raise Index_Error;
+ end if;
+
+ return
+ Index (Source (From .. Source'Last), Pattern, Forward, Mapping);
+
+ else
+ if From > Source'Last then
+ raise Index_Error;
+ end if;
+
+ return
+ Index (Source (Source'First .. From), Pattern, Backward, Mapping);
+ end if;
+ end Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ if Going = Forward then
+ if From < Source'First then
+ raise Index_Error;
+ end if;
+
+ return Index
+ (Source (From .. Source'Last), Pattern, Forward, Mapping);
+
+ else
+ if From > Source'Last then
+ raise Index_Error;
+ end if;
+
+ return Index
+ (Source (Source'First .. From), Pattern, Backward, Mapping);
+ end if;
+ end Index;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ is
+ begin
+ if Going = Forward then
+ if From < Source'First then
+ raise Index_Error;
+ end if;
+
+ return
+ Index (Source (From .. Source'Last), Set, Test, Forward);
+
+ else
+ if From > Source'Last then
+ raise Index_Error;
+ end if;
+
+ return
+ Index (Source (Source'First .. From), Set, Test, Backward);
+ end if;
+ end Index;
+
+ ---------------------
+ -- Index_Non_Blank --
+ ---------------------
+
+ function Index_Non_Blank
+ (Source : Wide_Wide_String;
+ Going : Direction := Forward) return Natural
+ is
+ begin
+ if Going = Forward then
+ for J in Source'Range loop
+ if Source (J) /= Wide_Wide_Space then
+ return J;
+ end if;
+ end loop;
+
+ else -- Going = Backward
+ for J in reverse Source'Range loop
+ if Source (J) /= Wide_Wide_Space then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match
+
+ return 0;
+ end Index_Non_Blank;
+
+ function Index_Non_Blank
+ (Source : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural
+ is
+ begin
+ if Going = Forward then
+ if From < Source'First then
+ raise Index_Error;
+ end if;
+
+ return
+ Index_Non_Blank (Source (From .. Source'Last), Forward);
+
+ else
+ if From > Source'Last then
+ raise Index_Error;
+ end if;
+
+ return
+ Index_Non_Blank (Source (Source'First .. From), Backward);
+ end if;
+ end Index_Non_Blank;
+
+end Ada.Strings.Wide_Wide_Search;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains search functions from Ada.Strings.Wide_Wide_Fixed.
+-- They are separated because Ada.Strings.Wide_Wide_Bounded shares these
+-- search functions with Ada.Strings.Wide_Wide_Unbounded, and we don't want
+-- to drag other irrelevant stuff from Ada.Strings.Wide_Wide_Fixed when using
+-- the other two packages. We make this a private package, since user
+-- programs should access these subprograms via one of the standard string
+-- packages.
+
+with Ada.Strings.Wide_Wide_Maps;
+
+private package Ada.Strings.Wide_Wide_Search is
+pragma Preelaborate (Wide_Wide_Search);
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Index_Non_Blank
+ (Source : Wide_Wide_String;
+ Going : Direction := Forward) return Natural;
+
+ function Index_Non_Blank
+ (Source : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural;
+
+ procedure Find_Token
+ (Source : Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+end Ada.Strings.Wide_Wide_Search;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ S U P E R B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps;
+with Ada.Strings.Wide_Wide_Search;
+
+package body Ada.Strings.Wide_Wide_Superbounded is
+
+ ------------
+ -- Concat --
+ ------------
+
+ function Concat
+ (Left : Super_String;
+ Right : Super_String) return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ Nlen : constant Natural := Llen + Right'Length;
+
+ begin
+ if Nlen > Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+ end if;
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Llen : constant Natural := Left'Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Super_String;
+ Right : Wide_Wide_Character) return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ begin
+ if Llen = Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Result.Current_Length) := Right;
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Wide_Wide_Character;
+ Right : Super_String) return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Rlen : constant Natural := Right.Current_Length;
+
+ begin
+ if Rlen = Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ -----------
+ -- Equal --
+ -----------
+
+ function "="
+ (Left : Super_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left.Current_Length = Right.Current_Length
+ and then Left.Data (1 .. Left.Current_Length) =
+ Right.Data (1 .. Right.Current_Length);
+ end "=";
+
+ function Equal
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Current_Length = Right'Length
+ and then Left.Data (1 .. Left.Current_Length) = Right;
+ end Equal;
+
+ function Equal
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left'Length = Right.Current_Length
+ and then Left = Right.Data (1 .. Right.Current_Length);
+ end Equal;
+
+ -------------
+ -- Greater --
+ -------------
+
+ function Greater
+ (Left : Super_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >
+ Right.Data (1 .. Right.Current_Length);
+ end Greater;
+
+ function Greater
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) > Right;
+ end Greater;
+
+ function Greater
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left > Right.Data (1 .. Right.Current_Length);
+ end Greater;
+
+ ----------------------
+ -- Greater_Or_Equal --
+ ----------------------
+
+ function Greater_Or_Equal
+ (Left : Super_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >=
+ Right.Data (1 .. Right.Current_Length);
+ end Greater_Or_Equal;
+
+ function Greater_Or_Equal
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >= Right;
+ end Greater_Or_Equal;
+
+ function Greater_Or_Equal
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left >= Right.Data (1 .. Right.Current_Length);
+ end Greater_Or_Equal;
+
+ ----------
+ -- Less --
+ ----------
+
+ function Less
+ (Left : Super_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <
+ Right.Data (1 .. Right.Current_Length);
+ end Less;
+
+ function Less
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) < Right;
+ end Less;
+
+ function Less
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left < Right.Data (1 .. Right.Current_Length);
+ end Less;
+
+ -------------------
+ -- Less_Or_Equal --
+ -------------------
+
+ function Less_Or_Equal
+ (Left : Super_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <=
+ Right.Data (1 .. Right.Current_Length);
+ end Less_Or_Equal;
+
+ function Less_Or_Equal
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <= Right;
+ end Less_Or_Equal;
+
+ function Less_Or_Equal
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean
+ is
+ begin
+ return Left <= Right.Data (1 .. Right.Current_Length);
+ end Less_Or_Equal;
+
+ ----------------------
+ -- Set_Super_String --
+ ----------------------
+
+ procedure Set_Super_String
+ (Target : out Super_String;
+ Source : Wide_Wide_String;
+ Drop : Truncation := Error)
+ is
+ Slen : constant Natural := Source'Length;
+ Max_Length : constant Positive := Target.Max_Length;
+
+ begin
+ if Slen <= Max_Length then
+ Target.Current_Length := Slen;
+ Target.Data (1 .. Slen) := Source;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Target.Current_Length := Max_Length;
+ Target.Data (1 .. Max_Length) :=
+ Source (Source'First .. Source'First - 1 + Max_Length);
+
+ when Strings.Left =>
+ Target.Current_Length := Max_Length;
+ Target.Data (1 .. Max_Length) :=
+ Source (Source'Last - (Max_Length - 1) .. Source'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Set_Super_String;
+
+ ------------------
+ -- Super_Append --
+ ------------------
+
+ -- Case of Super_String and Super_String
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Result.Data := Right.Data;
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Super_String;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+ Rlen : constant Natural := New_Item.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Current_Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Source.Data := New_Item.Data;
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of Super_String and Wide_Wide_String
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right (Right'First .. Right'First - 1 +
+ Max_Length - Llen);
+
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right (Right'Last - (Max_Length - 1) .. Right'Last);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+ Rlen : constant Natural := New_Item'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Current_Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item;
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item (New_Item'First ..
+ New_Item'First - 1 + Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - (Max_Length - 1) ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of Wide_Wide_String and Super_String
+
+ function Super_Append
+ (Left : Wide_Wide_String;
+ Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Right.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left'Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Left (Left'First .. Left'First + (Max_Length - 1));
+
+ else
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right.Data (Rlen - (Max_Length - 1) .. Rlen);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ -- Case of Super_String and Wide_Wide_Character
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Wide_Wide_Character;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ begin
+ if Llen < Max_Length then
+ Result.Current_Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1) := Right;
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ return Left;
+
+ when Strings.Left =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length - 1) :=
+ Left.Data (2 .. Max_Length);
+ Result.Data (Max_Length) := Right;
+ return Result;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Wide_Wide_Character;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+
+ begin
+ if Llen < Max_Length then
+ Source.Current_Length := Llen + 1;
+ Source.Data (Llen + 1) := New_Item;
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ null;
+
+ when Strings.Left =>
+ Source.Data (1 .. Max_Length - 1) :=
+ Source.Data (2 .. Max_Length);
+ Source.Data (Max_Length) := New_Item;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of Wide_Wide_Character and Super_String
+
+ function Super_Append
+ (Left : Wide_Wide_Character;
+ Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Right.Max_Length;
+ Result : Super_String (Max_Length);
+ Rlen : constant Natural := Right.Current_Length;
+
+ begin
+ if Rlen < Max_Length then
+ Result.Current_Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen);
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - 1);
+ return Result;
+
+ when Strings.Left =>
+ return Right;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Append;
+
+ -----------------
+ -- Super_Count --
+ -----------------
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return
+ Wide_Wide_Search.Count
+ (Source.Data (1 .. Source.Current_Length), Pattern, Mapping);
+ end Super_Count;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return
+ Wide_Wide_Search.Count
+ (Source.Data (1 .. Source.Current_Length), Pattern, Mapping);
+ end Super_Count;
+
+ function Super_Count
+ (Source : Super_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural
+ is
+ begin
+ return Wide_Wide_Search.Count
+ (Source.Data (1 .. Source.Current_Length), Set);
+ end Super_Count;
+
+ ------------------
+ -- Super_Delete --
+ ------------------
+
+ function Super_Delete
+ (Source : Super_String;
+ From : Positive;
+ Through : Natural) return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Num_Delete : constant Integer := Through - From + 1;
+
+ begin
+ if Num_Delete <= 0 then
+ return Source;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Result.Current_Length := From - 1;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ return Result;
+
+ else
+ Result.Current_Length := Slen - Num_Delete;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ Result.Data (From .. Result.Current_Length) :=
+ Source.Data (Through + 1 .. Slen);
+ return Result;
+ end if;
+ end Super_Delete;
+
+ procedure Super_Delete
+ (Source : in out Super_String;
+ From : Positive;
+ Through : Natural)
+ is
+ Slen : constant Natural := Source.Current_Length;
+ Num_Delete : constant Integer := Through - From + 1;
+
+ begin
+ if Num_Delete <= 0 then
+ return;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Source.Current_Length := From - 1;
+
+ else
+ Source.Current_Length := Slen - Num_Delete;
+ Source.Data (From .. Source.Current_Length) :=
+ Source.Data (Through + 1 .. Slen);
+ end if;
+ end Super_Delete;
+
+ -------------------
+ -- Super_Element --
+ -------------------
+
+ function Super_Element
+ (Source : Super_String;
+ Index : Positive) return Wide_Wide_Character
+ is
+ begin
+ if Index in 1 .. Source.Current_Length then
+ return Source.Data (Index);
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Super_Element;
+
+ ----------------------
+ -- Super_Find_Token --
+ ----------------------
+
+ procedure Super_Find_Token
+ (Source : Super_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ Wide_Wide_Search.Find_Token
+ (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last);
+ end Super_Find_Token;
+
+ ----------------
+ -- Super_Head --
+ ----------------
+
+ function Super_Head
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Count) := Source.Data (1 .. Count);
+
+ elsif Count <= Max_Length then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Max_Length - Npad) :=
+ Source.Data (Count - Max_Length + 1 .. Slen);
+ Result.Data (Max_Length - Npad + 1 .. Max_Length) :=
+ (others => Pad);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Head;
+
+ procedure Super_Head
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+ Temp : Wide_Wide_String (1 .. Max_Length);
+
+ begin
+ if Npad <= 0 then
+ Source.Current_Length := Count;
+
+ elsif Count <= Max_Length then
+ Source.Current_Length := Count;
+ Source.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad > Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Temp := Source.Data;
+ Source.Data (1 .. Max_Length - Npad) :=
+ Temp (Count - Max_Length + 1 .. Slen);
+
+ for J in Max_Length - Npad + 1 .. Max_Length loop
+ Source.Data (J) := Pad;
+ end loop;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Head;
+
+ -----------------
+ -- Super_Index --
+ -----------------
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length), Set, Test, Going);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length),
+ Pattern, From, Going, Mapping);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length),
+ Pattern, From, Going, Mapping);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going);
+ end Super_Index;
+
+ ---------------------------
+ -- Super_Index_Non_Blank --
+ ---------------------------
+
+ function Super_Index_Non_Blank
+ (Source : Super_String;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ begin
+ return
+ Wide_Wide_Search.Index_Non_Blank
+ (Source.Data (1 .. Source.Current_Length), Going);
+ end Super_Index_Non_Blank;
+
+ function Super_Index_Non_Blank
+ (Source : Super_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural
+ is
+ begin
+ return
+ Wide_Wide_Search.Index_Non_Blank
+ (Source.Data (1 .. Source.Current_Length), From, Going);
+ end Super_Index_Non_Blank;
+
+ ------------------
+ -- Super_Insert --
+ ------------------
+
+ function Super_Insert
+ (Source : Super_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Nlen : constant Natural := New_Item'Length;
+ Tlen : constant Natural := Slen + Nlen;
+ Blen : constant Natural := Before - 1;
+ Alen : constant Integer := Slen - Blen;
+ Droplen : constant Integer := Tlen - Max_Length;
+
+ -- Tlen is the length of the total string before possible truncation.
+ -- Blen, Alen are the lengths of the before and after pieces of the
+ -- source string.
+
+ begin
+ if Alen < 0 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Droplen <= 0 then
+ Result.Current_Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Tlen) :=
+ Source.Data (Before .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Before .. Max_Length) :=
+ New_Item (New_Item'First
+ .. New_Item'First + Max_Length - Before);
+ else
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Max_Length) :=
+ Source.Data (Before .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (Before .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ New_Item (New_Item'Last - (Max_Length - Alen) + 1
+ .. New_Item'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) :=
+ New_Item;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Insert;
+
+ procedure Super_Insert
+ (Source : in out Super_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Super_Insert (Source, Before, New_Item, Drop);
+ end Super_Insert;
+
+ ------------------
+ -- Super_Length --
+ ------------------
+
+ function Super_Length (Source : Super_String) return Natural is
+ begin
+ return Source.Current_Length;
+ end Super_Length;
+
+ ---------------------
+ -- Super_Overwrite --
+ ---------------------
+
+ function Super_Overwrite
+ (Source : Super_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Endpos : constant Natural := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Current_Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif New_Item'Length = 0 then
+ return Source;
+
+ elsif Endpos <= Slen then
+ Result.Current_Length := Source.Current_Length;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ elsif Endpos <= Max_Length then
+ Result.Current_Length := Endpos;
+ Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ else
+ Result.Current_Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Position - 1) :=
+ Source.Data (1 .. Position - 1);
+
+ Result.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+ return Result;
+
+ when Strings.Left =>
+ if New_Item'Length >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+ return Result;
+
+ else
+ Result.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+ Result.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ return Result;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Overwrite;
+
+ procedure Super_Overwrite
+ (Source : in out Super_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Endpos : constant Positive := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Current_Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Endpos <= Slen then
+ Source.Data (Position .. Endpos) := New_Item;
+
+ elsif Endpos <= Max_Length then
+ Source.Data (Position .. Endpos) := New_Item;
+ Source.Current_Length := Endpos;
+
+ else
+ Source.Current_Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+
+ when Strings.Left =>
+ if New_Item'Length > Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+
+ Source.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Overwrite;
+
+ ---------------------------
+ -- Super_Replace_Element --
+ ---------------------------
+
+ procedure Super_Replace_Element
+ (Source : in out Super_String;
+ Index : Positive;
+ By : Wide_Wide_Character)
+ is
+ begin
+ if Index <= Source.Current_Length then
+ Source.Data (Index) := By;
+ else
+ raise Ada.Strings.Index_Error;
+ end if;
+ end Super_Replace_Element;
+
+ -------------------------
+ -- Super_Replace_Slice --
+ -------------------------
+
+ function Super_Replace_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+
+ begin
+ if Low > Slen + 1 then
+ raise Strings.Index_Error;
+
+ elsif High < Low then
+ return Super_Insert (Source, Low, By, Drop);
+
+ else
+ declare
+ Blen : constant Natural := Natural'Max (0, Low - 1);
+ Alen : constant Natural := Natural'Max (0, Slen - High);
+ Tlen : constant Natural := Blen + By'Length + Alen;
+ Droplen : constant Integer := Tlen - Max_Length;
+ Result : Super_String (Max_Length);
+
+ -- Tlen is the total length of the result string before any
+ -- truncation. Blen and Alen are the lengths of the pieces
+ -- of the original string that end up in the result string
+ -- before and after the replaced slice.
+
+ begin
+ if Droplen <= 0 then
+ Result.Current_Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Tlen) :=
+ Source.Data (High + 1 .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Low .. Max_Length) :=
+ By (By'First .. By'First + Max_Length - Low);
+ else
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Max_Length) :=
+ Source.Data (High + 1 .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (High + 1 .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ By (By'Last - (Max_Length - Alen) + 1 .. By'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) := By;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end Super_Replace_Slice;
+
+ procedure Super_Replace_Slice
+ (Source : in out Super_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Super_Replace_Slice (Source, Low, High, By, Drop);
+ end Super_Replace_Slice;
+
+ ---------------------
+ -- Super_Replicate --
+ ---------------------
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Wide_Wide_Character;
+ Drop : Truncation := Error;
+ Max_Length : Positive) return Super_String
+ is
+ Result : Super_String (Max_Length);
+
+ begin
+ if Count <= Max_Length then
+ Result.Current_Length := Count;
+
+ elsif Drop = Strings.Error then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Max_Length;
+ end if;
+
+ Result.Data (1 .. Result.Current_Length) := (others => Item);
+ return Result;
+ end Super_Replicate;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Wide_Wide_String;
+ Drop : Truncation := Error;
+ Max_Length : Positive) return Super_String
+ is
+ Length : constant Integer := Count * Item'Length;
+ Result : Super_String (Max_Length);
+ Indx : Positive;
+
+ begin
+ if Length <= Max_Length then
+ Result.Current_Length := Length;
+
+ if Length > 0 then
+ Indx := 1;
+
+ for J in 1 .. Count loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+ end if;
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Indx := 1;
+
+ while Indx + Item'Length <= Max_Length + 1 loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+
+ Result.Data (Indx .. Max_Length) :=
+ Item (Item'First .. Item'First + Max_Length - Indx);
+
+ when Strings.Left =>
+ Indx := Max_Length;
+
+ while Indx - Item'Length >= 1 loop
+ Result.Data (Indx - (Item'Length - 1) .. Indx) := Item;
+ Indx := Indx - Item'Length;
+ end loop;
+
+ Result.Data (1 .. Indx) :=
+ Item (Item'Last - Indx + 1 .. Item'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Replicate;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Super_String;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ begin
+ return
+ Super_Replicate
+ (Count,
+ Item.Data (1 .. Item.Current_Length),
+ Drop,
+ Item.Max_Length);
+ end Super_Replicate;
+
+ -----------------
+ -- Super_Slice --
+ -----------------
+
+ function Super_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural) return Wide_Wide_String
+ is
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > Source.Current_Length + 1
+ or else High > Source.Current_Length
+ then
+ raise Index_Error;
+ else
+ return Source.Data (Low .. High);
+ end if;
+ end Super_Slice;
+
+ function Super_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural) return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ if Low > Source.Current_Length + 1
+ or else High > Source.Current_Length
+ then
+ raise Index_Error;
+ else
+ Result.Current_Length := High - Low + 1;
+ Result.Data (1 .. Source.Current_Length) := Source.Data (Low .. High);
+ end if;
+
+ return Result;
+ end Super_Slice;
+
+ procedure Super_Slice
+ (Source : Super_String;
+ Target : out Super_String;
+ Low : Positive;
+ High : Natural)
+ is
+ begin
+ if Low > Source.Current_Length + 1
+ or else High > Source.Current_Length
+ then
+ raise Index_Error;
+ else
+ Target.Current_Length := High - Low + 1;
+ Target.Data (1 .. Source.Current_Length) := Source.Data (Low .. High);
+ end if;
+ end Super_Slice;
+
+ ----------------
+ -- Super_Tail --
+ ----------------
+
+ function Super_Tail
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Strings.Truncation := Strings.Error) return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Count) :=
+ Source.Data (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Max_Length) :=
+ Source.Data (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (1 .. Max_Length - Slen) := (others => Pad);
+ Result.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Source.Data (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Tail;
+
+ procedure Super_Tail
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ Temp : constant Wide_Wide_String (1 .. Max_Length) := Source.Data;
+
+ begin
+ if Npad <= 0 then
+ Source.Current_Length := Count;
+ Source.Data (1 .. Count) :=
+ Temp (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Source.Current_Length := Count;
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Max_Length) :=
+ Temp (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ for J in 1 .. Max_Length - Slen loop
+ Source.Data (J) := Pad;
+ end loop;
+
+ Source.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Temp (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Tail;
+
+ ---------------------
+ -- Super_To_String --
+ ---------------------
+
+ function Super_To_String
+ (Source : Super_String) return Wide_Wide_String
+ is
+ begin
+ return Source.Data (1 .. Source.Current_Length);
+ end Super_To_String;
+
+ ---------------------
+ -- Super_Translate --
+ ---------------------
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ Result.Current_Length := Source.Current_Length;
+
+ for J in 1 .. Source.Current_Length loop
+ Result.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+
+ return Result;
+ end Super_Translate;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ is
+ begin
+ for J in 1 .. Source.Current_Length loop
+ Source.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+ end Super_Translate;
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ Result.Current_Length := Source.Current_Length;
+
+ for J in 1 .. Source.Current_Length loop
+ Result.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+
+ return Result;
+ end Super_Translate;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ is
+ begin
+ for J in 1 .. Source.Current_Length loop
+ Source.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+ end Super_Translate;
+
+ ----------------
+ -- Super_Trim --
+ ----------------
+
+ function Super_Trim
+ (Source : Super_String;
+ Side : Trim_End) return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+ Last : Natural := Source.Current_Length;
+ First : Positive := 1;
+
+ begin
+ if Side = Left or else Side = Both then
+ while First <= Last and then Source.Data (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Source.Data (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Result.Current_Length := Last - First + 1;
+ Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last);
+ return Result;
+ end Super_Trim;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Side : Trim_End)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Last : Natural := Source.Current_Length;
+ First : Positive := 1;
+ Temp : Wide_Wide_String (1 .. Max_Length);
+
+ begin
+ Temp (1 .. Last) := Source.Data (1 .. Last);
+
+ if Side = Left or else Side = Both then
+ while First <= Last and then Temp (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Temp (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Source.Data := (others => Wide_Wide_NUL);
+ Source.Current_Length := Last - First + 1;
+ Source.Data (1 .. Source.Current_Length) := Temp (First .. Last);
+ end Super_Trim;
+
+ function Super_Trim
+ (Source : Super_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ for First in 1 .. Source.Current_Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Current_Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ Result.Current_Length := Last - First + 1;
+ Result.Data (1 .. Result.Current_Length) :=
+ Source.Data (First .. Last);
+ return Result;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ Result.Current_Length := 0;
+ return Result;
+ end Super_Trim;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ is
+ begin
+ for First in 1 .. Source.Current_Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Current_Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ if First = 1 then
+ Source.Current_Length := Last;
+ return;
+ else
+ Source.Current_Length := Last - First + 1;
+ Source.Data (1 .. Source.Current_Length) :=
+ Source.Data (First .. Last);
+
+ for J in Source.Current_Length + 1 ..
+ Source.Max_Length
+ loop
+ Source.Data (J) := Wide_Wide_NUL;
+ end loop;
+
+ return;
+ end if;
+ end if;
+ end loop;
+
+ Source.Current_Length := 0;
+ return;
+ end if;
+ end loop;
+
+ Source.Current_Length := 0;
+ end Super_Trim;
+
+ -----------
+ -- Times --
+ -----------
+
+ function Times
+ (Left : Natural;
+ Right : Wide_Wide_Character;
+ Max_Length : Positive) return Super_String
+ is
+ Result : Super_String (Max_Length);
+
+ begin
+ if Left > Max_Length then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Left;
+
+ for J in 1 .. Left loop
+ Result.Data (J) := Right;
+ end loop;
+ end if;
+
+ return Result;
+ end Times;
+
+ function Times
+ (Left : Natural;
+ Right : Wide_Wide_String;
+ Max_Length : Positive) return Super_String
+ is
+ Result : Super_String (Max_Length);
+ Pos : Positive := 1;
+ Rlen : constant Natural := Right'Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Index_Error;
+
+ else
+ Result.Current_Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) := Right;
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end Times;
+
+ function Times
+ (Left : Natural;
+ Right : Super_String) return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Pos : Positive := 1;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) :=
+ Right.Data (1 .. Rlen);
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end Times;
+
+ ---------------------
+ -- To_Super_String --
+ ---------------------
+
+ function To_Super_String
+ (Source : Wide_Wide_String;
+ Max_Length : Natural;
+ Drop : Truncation := Error) return Super_String
+ is
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source'Length;
+
+ begin
+ if Slen <= Max_Length then
+ Result.Current_Length := Slen;
+ Result.Data (1 .. Slen) := Source;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'First .. Source'First - 1 + Max_Length);
+
+ when Strings.Left =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'Last - (Max_Length - 1) .. Source'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end To_Super_String;
+
+end Ada.Strings.Wide_Wide_Superbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ S U P E R B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2003-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This non generic package contains most of the implementation of the
+-- generic package Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length.
+
+-- It defines type Super_String as a discriminated record with the maximum
+-- length as the discriminant. Individual instantiations of the package
+-- Strings.Wide_Wide_Bounded.Generic_Bounded_Length use this type with
+-- an appropriate discriminant value set.
+
+with Ada.Strings.Wide_Wide_Maps;
+
+package Ada.Strings.Wide_Wide_Superbounded is
+pragma Preelaborate (Wide_Wide_Superbounded);
+
+ Wide_Wide_NUL : constant Wide_Wide_Character :=
+ Wide_Wide_Character'Val (0);
+
+ type Super_String (Max_Length : Positive) is record
+ Current_Length : Natural := 0;
+ Data : Wide_Wide_String (1 .. Max_Length) :=
+ (others => Wide_Wide_NUL);
+ end record;
+ -- Wide_Wide_Bounded.Generic_Bounded_Length.Wide_Wide_Bounded_String is
+ -- derived from this type, with the constraint of the maximum length.
+
+ -- The subprograms defined for Super_String are similar to those defined
+ -- for Bounded_Wide_Wide_String, except that they have different names, so
+ -- that they can be renamed in Wide_Wide_Bounded.Generic_Bounded_Length.
+
+ function Super_Length (Source : Super_String) return Natural;
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Super_String
+ (Source : Wide_Wide_String;
+ Max_Length : Natural;
+ Drop : Truncation := Error) return Super_String;
+ -- Note the additional parameter Max_Length, which specifies the maximum
+ -- length setting of the resulting Super_String value.
+
+ -- The following procedures have declarations (and semantics) that are
+ -- exactly analogous to those declared in Ada.Strings.Wide_Wide_Bounded.
+
+ function Super_To_String (Source : Super_String) return Wide_Wide_String;
+
+ procedure Set_Super_String
+ (Target : out Super_String;
+ Source : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Super_String;
+ Drop : Truncation := Error) return Super_String;
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Wide_Wide_String;
+ Drop : Truncation := Error) return Super_String;
+
+ function Super_Append
+ (Left : Wide_Wide_String;
+ Right : Super_String;
+ Drop : Truncation := Error) return Super_String;
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Wide_Wide_Character;
+ Drop : Truncation := Error) return Super_String;
+
+ function Super_Append
+ (Left : Wide_Wide_Character;
+ Right : Super_String;
+ Drop : Truncation := Error) return Super_String;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Super_String;
+ Drop : Truncation := Error);
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Wide_Wide_Character;
+ Drop : Truncation := Error);
+
+ function Concat
+ (Left : Super_String;
+ Right : Super_String) return Super_String;
+
+ function Concat
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Super_String;
+
+ function Concat
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Super_String;
+
+ function Concat
+ (Left : Super_String;
+ Right : Wide_Wide_Character) return Super_String;
+
+ function Concat
+ (Left : Wide_Wide_Character;
+ Right : Super_String) return Super_String;
+
+ function Super_Element
+ (Source : Super_String;
+ Index : Positive) return Wide_Wide_Character;
+
+ procedure Super_Replace_Element
+ (Source : in out Super_String;
+ Index : Positive;
+ By : Wide_Wide_Character);
+
+ function Super_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural) return Wide_Wide_String;
+
+ function Super_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural) return Super_String;
+
+ procedure Super_Slice
+ (Source : Super_String;
+ Target : out Super_String;
+ Low : Positive;
+ High : Natural);
+
+ function "="
+ (Left : Super_String;
+ Right : Super_String) return Boolean;
+
+ function Equal
+ (Left : Super_String;
+ Right : Super_String) return Boolean renames "=";
+
+ function Equal
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function Equal
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean;
+
+ function Less
+ (Left : Super_String;
+ Right : Super_String) return Boolean;
+
+ function Less
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function Less
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean;
+
+ function Less_Or_Equal
+ (Left : Super_String;
+ Right : Super_String) return Boolean;
+
+ function Less_Or_Equal
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function Less_Or_Equal
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean;
+
+ function Greater
+ (Left : Super_String;
+ Right : Super_String) return Boolean;
+
+ function Greater
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function Greater
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean;
+
+ function Greater_Or_Equal
+ (Left : Super_String;
+ Right : Super_String) return Boolean;
+
+ function Greater_Or_Equal
+ (Left : Super_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function Greater_Or_Equal
+ (Left : Wide_Wide_String;
+ Right : Super_String) return Boolean;
+
+ ----------------------
+ -- Search Functions --
+ ----------------------
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Super_Index_Non_Blank
+ (Source : Super_String;
+ Going : Direction := Forward) return Natural;
+
+ function Super_Index_Non_Blank
+ (Source : Super_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural;
+
+ procedure Super_Find_Token
+ (Source : Super_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- String Translation Subprograms --
+ ------------------------------------
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Super_String;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping);
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Super_String;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function);
+
+ ---------------------------------------
+ -- String Transformation Subprograms --
+ ---------------------------------------
+
+ function Super_Replace_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Truncation := Error) return Super_String;
+
+ procedure Super_Replace_Slice
+ (Source : in out Super_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ function Super_Insert
+ (Source : Super_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error) return Super_String;
+
+ procedure Super_Insert
+ (Source : in out Super_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ function Super_Overwrite
+ (Source : Super_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error) return Super_String;
+
+ procedure Super_Overwrite
+ (Source : in out Super_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String;
+ Drop : Truncation := Error);
+
+ function Super_Delete
+ (Source : Super_String;
+ From : Positive;
+ Through : Natural) return Super_String;
+
+ procedure Super_Delete
+ (Source : in out Super_String;
+ From : Positive;
+ Through : Natural);
+
+ ---------------------------------
+ -- String Selector Subprograms --
+ ---------------------------------
+
+ function Super_Trim
+ (Source : Super_String;
+ Side : Trim_End) return Super_String;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Side : Trim_End);
+
+ function Super_Trim
+ (Source : Super_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Super_String;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set);
+
+ function Super_Head
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error) return Super_String;
+
+ procedure Super_Head
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error);
+
+ function Super_Tail
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error) return Super_String;
+
+ procedure Super_Tail
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space;
+ Drop : Truncation := Error);
+
+ ------------------------------------
+ -- String Constructor Subprograms --
+ ------------------------------------
+
+ -- Note: in some of the following routines, there is an extra parameter
+ -- Max_Length which specifies the value of the maximum length for the
+ -- resulting Super_String value.
+
+ function Times
+ (Left : Natural;
+ Right : Wide_Wide_Character;
+ Max_Length : Positive) return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Times
+ (Left : Natural;
+ Right : Wide_Wide_String;
+ Max_Length : Positive) return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Times
+ (Left : Natural;
+ Right : Super_String) return Super_String;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Wide_Wide_Character;
+ Drop : Truncation := Error;
+ Max_Length : Positive) return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Wide_Wide_String;
+ Drop : Truncation := Error;
+ Max_Length : Positive) return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Super_String;
+ Drop : Truncation := Error) return Super_String;
+
+private
+ -- Pragma Inline declarations
+
+ pragma Inline ("=");
+ pragma Inline (Less);
+ pragma Inline (Less_Or_Equal);
+ pragma Inline (Greater);
+ pragma Inline (Greater_Or_Equal);
+ pragma Inline (Concat);
+ pragma Inline (Super_Count);
+ pragma Inline (Super_Element);
+ pragma Inline (Super_Find_Token);
+ pragma Inline (Super_Index);
+ pragma Inline (Super_Index_Non_Blank);
+ pragma Inline (Super_Length);
+ pragma Inline (Super_Replace_Element);
+ pragma Inline (Super_Slice);
+ pragma Inline (Super_To_String);
+
+end Ada.Strings.Wide_Wide_Superbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Wide_Fixed;
+with Ada.Strings.Wide_Wide_Search;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Strings.Wide_Wide_Unbounded is
+
+ use Ada.Finalization;
+
+ procedure Realloc_For_Chunk
+ (Source : in out Unbounded_Wide_Wide_String;
+ Chunk_Size : Natural);
+ pragma Inline (Realloc_For_Chunk);
+ -- Adjust the size allocated for the string. Add at least Chunk_Size so it
+ -- is safe to add a string of this size at the end of the current content.
+ -- The real size allocated for the string is Chunk_Size + x of the current
+ -- string size. This buffered handling makes the Append unbounded wide
+ -- string routines very fast.
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ L_Length : constant Natural := Left.Last;
+ R_Length : constant Natural := Right.Last;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Result.Last := L_Length + R_Length;
+
+ Result.Reference := new Wide_Wide_String (1 .. Result.Last);
+
+ Result.Reference (1 .. L_Length) :=
+ Left.Reference (1 .. Left.Last);
+ Result.Reference (L_Length + 1 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ L_Length : constant Natural := Left.Last;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Result.Last := L_Length + Right'Length;
+
+ Result.Reference := new Wide_Wide_String (1 .. Result.Last);
+
+ Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last);
+ Result.Reference (L_Length + 1 .. Result.Last) := Right;
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ R_Length : constant Natural := Right.Last;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Result.Last := Left'Length + R_Length;
+
+ Result.Reference := new Wide_Wide_String (1 .. Result.Last);
+
+ Result.Reference (1 .. Left'Length) := Left;
+ Result.Reference (Left'Length + 1 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String
+ is
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Result.Last := Left.Last + 1;
+
+ Result.Reference := new Wide_Wide_String (1 .. Result.Last);
+
+ Result.Reference (1 .. Result.Last - 1) :=
+ Left.Reference (1 .. Left.Last);
+ Result.Reference (Result.Last) := Right;
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Wide_Wide_Character;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Result.Last := Right.Last + 1;
+
+ Result.Reference := new Wide_Wide_String (1 .. Result.Last);
+ Result.Reference (1) := Left;
+ Result.Reference (2 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
+
+ return Result;
+ end "&";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String
+ is
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Result.Last := Left;
+
+ Result.Reference := new Wide_Wide_String (1 .. Left);
+ for J in Result.Reference'Range loop
+ Result.Reference (J) := Right;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ Len : constant Natural := Right'Length;
+ K : Positive;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Result.Last := Left * Len;
+
+ Result.Reference := new Wide_Wide_String (1 .. Result.Last);
+
+ K := 1;
+ for J in 1 .. Left loop
+ Result.Reference (K .. K + Len - 1) := Right;
+ K := K + Len;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ Len : constant Natural := Right.Last;
+ K : Positive;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Result.Last := Left * Len;
+
+ Result.Reference := new Wide_Wide_String (1 .. Result.Last);
+
+ K := 1;
+ for I in 1 .. Left loop
+ Result.Reference (K .. K + Len - 1) :=
+ Right.Reference (1 .. Right.Last);
+ K := K + Len;
+ end loop;
+
+ return Result;
+ end "*";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return
+ Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last);
+ end "<";
+
+ function "<"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Reference (1 .. Left.Last) < Right;
+ end "<";
+
+ function "<"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left < Right.Reference (1 .. Right.Last);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return
+ Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last);
+ end "<=";
+
+ function "<="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Reference (1 .. Left.Last) <= Right;
+ end "<=";
+
+ function "<="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left <= Right.Reference (1 .. Right.Last);
+ end "<=";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return
+ Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last);
+ end "=";
+
+ function "="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Reference (1 .. Left.Last) = Right;
+ end "=";
+
+ function "="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left = Right.Reference (1 .. Right.Last);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return
+ Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last);
+ end ">";
+
+ function ">"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Reference (1 .. Left.Last) > Right;
+ end ">";
+
+ function ">"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left > Right.Reference (1 .. Right.Last);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return
+ Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last);
+ end ">=";
+
+ function ">="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left.Reference (1 .. Left.Last) >= Right;
+ end ">=";
+
+ function ">="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ begin
+ return Left >= Right.Reference (1 .. Right.Last);
+ end ">=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is
+ begin
+ -- Copy string, except we do not copy the statically allocated null
+ -- string, since it can never be deallocated. Note that we do not copy
+ -- extra string room here to avoid dragging unused allocated memory.
+
+ if Object.Reference /= Null_Wide_Wide_String'Access then
+ Object.Reference :=
+ new Wide_Wide_String'(Object.Reference (1 .. Object.Last));
+ end if;
+ end Adjust;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Unbounded_Wide_Wide_String)
+ is
+ begin
+ Realloc_For_Chunk (Source, New_Item.Last);
+ Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) :=
+ New_Item.Reference (1 .. New_Item.Last);
+ Source.Last := Source.Last + New_Item.Last;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Wide_Wide_String)
+ is
+ begin
+ Realloc_For_Chunk (Source, New_Item'Length);
+ Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) :=
+ New_Item;
+ Source.Last := Source.Last + New_Item'Length;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Wide_Wide_Character)
+ is
+ begin
+ Realloc_For_Chunk (Source, 1);
+ Source.Reference (Source.Last + 1) := New_Item;
+ Source.Last := Source.Last + 1;
+ end Append;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural
+ is
+ begin
+ return Wide_Wide_Search.Count
+ (Source.Reference (1 .. Source.Last), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Wide_Wide_Search.Count
+ (Source.Reference (1 .. Source.Last), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural
+ is
+ begin
+ return Wide_Wide_Search.Count
+ (Source.Reference (1 .. Source.Last), Set);
+ end Count;
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : Unbounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural) return Unbounded_Wide_Wide_String
+ is
+ begin
+ return To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Delete
+ (Source.Reference (1 .. Source.Last), From, Through));
+ end Delete;
+
+ procedure Delete
+ (Source : in out Unbounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural)
+ is
+ begin
+ if From > Through then
+ null;
+
+ elsif From < Source.Reference'First or else Through > Source.Last then
+ raise Index_Error;
+
+ else
+ declare
+ Len : constant Natural := Through - From + 1;
+
+ begin
+ Source.Reference (From .. Source.Last - Len) :=
+ Source.Reference (Through + 1 .. Source.Last);
+ Source.Last := Source.Last - Len;
+ end;
+ end if;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Source : Unbounded_Wide_Wide_String;
+ Index : Positive) return Wide_Wide_Character
+ is
+ begin
+ if Index <= Source.Last then
+ return Source.Reference (Index);
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation
+ (Wide_Wide_String, Wide_Wide_String_Access);
+
+ begin
+ -- Note: Don't try to free statically allocated null string
+
+ if Object.Reference /= Null_Wide_Wide_String'Access then
+ Deallocate (Object.Reference);
+ Object.Reference := Null_Unbounded_Wide_Wide_String.Reference;
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ Wide_Wide_Search.Find_Token
+ (Source.Reference (1 .. Source.Last), Set, Test, First, Last);
+ end Find_Token;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Wide_Wide_String_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation
+ (Wide_Wide_String, Wide_Wide_String_Access);
+ begin
+ -- Note: Do not try to free statically allocated null string
+
+ if X /= Null_Unbounded_Wide_Wide_String.Reference then
+ Deallocate (X);
+ end if;
+ end Free;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ return Unbounded_Wide_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Head
+ (Source.Reference (1 .. Source.Last), Count, Pad));
+ end Head;
+
+ procedure Head
+ (Source : in out Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ Old : Wide_Wide_String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new Wide_Wide_String'
+ (Wide_Wide_Fixed.Head
+ (Source.Reference (1 .. Source.Last), Count, Pad));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
+ end Head;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index
+ (Source.Reference (1 .. Source.Last), Set, Test, Going);
+ end Index;
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_Wide_String;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ begin
+ return Wide_Wide_Search.Index_Non_Blank
+ (Source.Reference (1 .. Source.Last), Going);
+ end Index_Non_Blank;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is
+ begin
+ Object.Reference := Null_Unbounded_Wide_Wide_String.Reference;
+ Object.Last := 0;
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : Unbounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ begin
+ return To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Insert
+ (Source.Reference (1 .. Source.Last), Before, New_Item));
+ end Insert;
+
+ procedure Insert
+ (Source : in out Unbounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String)
+ is
+ begin
+ if Before not in Source.Reference'First .. Source.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ Realloc_For_Chunk (Source, New_Item'Size);
+
+ Source.Reference
+ (Before + New_Item'Length .. Source.Last + New_Item'Length) :=
+ Source.Reference (Before .. Source.Last);
+
+ Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item;
+ Source.Last := Source.Last + New_Item'Length;
+ end Insert;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Source : Unbounded_Wide_Wide_String) return Natural is
+ begin
+ return Source.Last;
+ end Length;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : Unbounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ begin
+ return To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Overwrite
+ (Source.Reference (1 .. Source.Last), Position, New_Item));
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Unbounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String)
+ is
+ NL : constant Natural := New_Item'Length;
+
+ begin
+ if Position <= Source.Last - NL + 1 then
+ Source.Reference (Position .. Position + NL - 1) := New_Item;
+
+ else
+ declare
+ Old : Wide_Wide_String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new Wide_Wide_String'
+ (Wide_Wide_Fixed.Overwrite
+ (Source.Reference (1 .. Source.Last), Position, New_Item));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
+ end;
+ end if;
+ end Overwrite;
+
+ -----------------------
+ -- Realloc_For_Chunk --
+ -----------------------
+
+ procedure Realloc_For_Chunk
+ (Source : in out Unbounded_Wide_Wide_String;
+ Chunk_Size : Natural)
+ is
+ Growth_Factor : constant := 50;
+ S_Length : constant Natural := Source.Reference'Length;
+
+ begin
+ if Chunk_Size > S_Length - Source.Last then
+ declare
+ Alloc_Chunk_Size : constant Positive :=
+ Chunk_Size + (S_Length / Growth_Factor);
+ Tmp : Wide_Wide_String_Access;
+
+ begin
+ Tmp := new Wide_Wide_String (1 .. S_Length + Alloc_Chunk_Size);
+ Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last);
+ Free (Source.Reference);
+ Source.Reference := Tmp;
+ end;
+ end if;
+ end Realloc_For_Chunk;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Source : in out Unbounded_Wide_Wide_String;
+ Index : Positive;
+ By : Wide_Wide_Character)
+ is
+ begin
+ if Index <= Source.Last then
+ Source.Reference (Index) := By;
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Replace_Element;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Replace_Slice
+ (Source.Reference (1 .. Source.Last), Low, High, By));
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String)
+ is
+ Old : Wide_Wide_String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new Wide_Wide_String'
+ (Wide_Wide_Fixed.Replace_Slice
+ (Source.Reference (1 .. Source.Last), Low, High, By));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
+ end Replace_Slice;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Wide_Wide_String
+ is
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > Source.Last + 1 or else High > Source.Last then
+ raise Index_Error;
+
+ else
+ return Source.Reference (Low .. High);
+ end if;
+ end Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ return Unbounded_Wide_Wide_String
+ is
+ begin
+ return To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Tail
+ (Source.Reference (1 .. Source.Last), Count, Pad));
+ end Tail;
+
+ procedure Tail
+ (Source : in out Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ Old : Wide_Wide_String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new Wide_Wide_String'
+ (Wide_Wide_Fixed.Tail
+ (Source.Reference (1 .. Source.Last), Count, Pad));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
+ end Tail;
+
+ ------------------------------
+ -- To_Unbounded_Wide_Wide_String --
+ ------------------------------
+
+ function To_Unbounded_Wide_Wide_String
+ (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ Result : Unbounded_Wide_Wide_String;
+ begin
+ Result.Last := Source'Length;
+ Result.Reference := new Wide_Wide_String (1 .. Source'Length);
+ Result.Reference.all := Source;
+ return Result;
+ end To_Unbounded_Wide_Wide_String;
+
+ function To_Unbounded_Wide_Wide_String
+ (Length : Natural) return Unbounded_Wide_Wide_String
+ is
+ Result : Unbounded_Wide_Wide_String;
+ begin
+ Result.Last := Length;
+ Result.Reference := new Wide_Wide_String (1 .. Length);
+ return Result;
+ end To_Unbounded_Wide_Wide_String;
+
+ --------------------
+ -- To_Wide_Wide_String --
+ --------------------
+
+ function To_Wide_Wide_String
+ (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String
+ is
+ begin
+ return Source.Reference (1 .. Source.Last);
+ end To_Wide_Wide_String;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Unbounded_Wide_Wide_String
+ is
+ begin
+ return To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Translate
+ (Source.Reference (1 .. Source.Last), Mapping));
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ is
+ begin
+ Wide_Wide_Fixed.Translate
+ (Source.Reference (1 .. Source.Last), Mapping);
+ end Translate;
+
+ function Translate
+ (Source : Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Unbounded_Wide_Wide_String
+ is
+ begin
+ return To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Translate
+ (Source.Reference (1 .. Source.Last), Mapping));
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ is
+ begin
+ Wide_Wide_Fixed.Translate
+ (Source.Reference (1 .. Source.Last), Mapping);
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : Unbounded_Wide_Wide_String;
+ Side : Trim_End) return Unbounded_Wide_Wide_String
+ is
+ begin
+ return To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side));
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_Wide_String;
+ Side : Trim_End)
+ is
+ Old : Wide_Wide_String_Access := Source.Reference;
+ begin
+ Source.Reference :=
+ new Wide_Wide_String'
+ (Wide_Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
+ end Trim;
+
+ function Trim
+ (Source : Unbounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ return Unbounded_Wide_Wide_String
+ is
+ begin
+ return To_Unbounded_Wide_Wide_String
+ (Wide_Wide_Fixed.Trim
+ (Source.Reference (1 .. Source.Last), Left, Right));
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ is
+ Old : Wide_Wide_String_Access := Source.Reference;
+ begin
+ Source.Reference := new Wide_Wide_String'
+ (Wide_Wide_Fixed.Trim
+ (Source.Reference (1 .. Source.Last), Left, Right));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
+ end Trim;
+
+end Ada.Strings.Wide_Wide_Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Wide_Maps;
+with Ada.Finalization;
+
+package Ada.Strings.Wide_Wide_Unbounded is
+pragma Preelaborate (Wide_Wide_Unbounded);
+
+ type Unbounded_Wide_Wide_String is private;
+
+ Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String;
+
+ function Length (Source : Unbounded_Wide_Wide_String) return Natural;
+
+ type Wide_Wide_String_Access is access all Wide_Wide_String;
+
+ procedure Free (X : in out Wide_Wide_String_Access);
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Unbounded_Wide_Wide_String
+ (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function To_Unbounded_Wide_Wide_String
+ (Length : Natural) return Unbounded_Wide_Wide_String;
+
+ function To_Wide_Wide_String
+ (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Unbounded_Wide_Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Wide_Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Wide_Wide_Character);
+
+ function "&"
+ (Left, Right : Unbounded_Wide_Wide_String)
+ return Unbounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Wide_Wide_Character;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function Element
+ (Source : Unbounded_Wide_Wide_String;
+ Index : Positive) return Wide_Wide_Character;
+
+ procedure Replace_Element
+ (Source : in out Unbounded_Wide_Wide_String;
+ Index : Positive;
+ By : Wide_Wide_Character);
+
+ function Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Wide_Wide_String;
+
+ function "="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_Wide_String;
+ Going : Direction := Forward) return Natural;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural;
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- Wide_Wide_String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping);
+
+ function Translate
+ (Source : Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function);
+
+ ---------------------------------------
+ -- Wide_Wide_String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String);
+
+ function Insert
+ (Source : Unbounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ procedure Insert
+ (Source : in out Unbounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String);
+
+ function Overwrite
+ (Source : Unbounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ procedure Overwrite
+ (Source : in out Unbounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String);
+
+ function Delete
+ (Source : Unbounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural) return Unbounded_Wide_Wide_String;
+
+ procedure Delete
+ (Source : in out Unbounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural);
+
+ function Trim
+ (Source : Unbounded_Wide_Wide_String;
+ Side : Trim_End) return Unbounded_Wide_Wide_String;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_Wide_String;
+ Side : Trim_End);
+
+ function Trim
+ (Source : Unbounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set);
+
+ function Head
+ (Source : Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Head
+ (Source : in out Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space);
+
+ function Tail
+ (Source : Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Tail
+ (Source : in out Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space);
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+private
+ pragma Inline (Length);
+
+ package AF renames Ada.Finalization;
+
+ Null_Wide_Wide_String : aliased Wide_Wide_String := "";
+
+ function To_Unbounded_Wide
+ (S : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ renames To_Unbounded_Wide_Wide_String;
+
+ type Unbounded_Wide_Wide_String is new AF.Controlled with record
+ Reference : Wide_Wide_String_Access := Null_Wide_Wide_String'Access;
+ Last : Natural := 0;
+ end record;
+
+ -- The Unbounded_Wide_Wide_String is using a buffered implementation to
+ -- increase speed of the Append/Delete/Insert procedures. The Reference
+ -- string pointer above contains the current string value and extra room
+ -- at the end to be used by the next Append routine. Last is the index of
+ -- the string ending character. So the current string value is really
+ -- Reference (1 .. Last).
+
+ pragma Stream_Convert
+ (Unbounded_Wide_Wide_String, To_Unbounded_Wide, To_Wide_Wide_String);
+
+ pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String);
+
+ procedure Initialize (Object : in out Unbounded_Wide_Wide_String);
+ procedure Adjust (Object : in out Unbounded_Wide_Wide_String);
+ procedure Finalize (Object : in out Unbounded_Wide_Wide_String);
+
+ Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String :=
+ (AF.Controlled with Reference => Null_Wide_Wide_String'Access, Last => 0);
+
+end Ada.Strings.Wide_Wide_Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Wide_Unbounded.Aux is
+
+ --------------------
+ -- Get_Wide_String --
+ ---------------------
+
+ function Get_Wide_String
+ (U : Unbounded_Wide_String) return Wide_String_Access
+ is
+ begin
+ if U.Last = U.Reference'Length then
+ return U.Reference;
+
+ else
+ declare
+ type Unbounded_Wide_String_Access is
+ access all Unbounded_Wide_String;
+
+ U_Ptr : constant Unbounded_Wide_String_Access :=
+ U'Unrestricted_Access;
+ -- Unbounded_Wide_String is a controlled type which is always
+ -- passed by copy it is always safe to take the pointer to such
+ -- object here. This pointer is used to set the U.Reference value
+ -- which would not be possible otherwise as U is read-only.
+
+ Old : Wide_String_Access := U.Reference;
+
+ begin
+ U_Ptr.Reference := new Wide_String'(U.Reference (1 .. U.Last));
+ Free (Old);
+ return U.Reference;
+ end;
+ end if;
+ end Get_Wide_String;
+
+ ---------------------
+ -- Set_Wide_String --
+ ---------------------
+
+ procedure Set_Wide_String
+ (UP : in out Unbounded_Wide_String;
+ S : Wide_String)
+ is
+ begin
+ if UP.Last = S'Length then
+ UP.Reference.all := S;
+
+ else
+ declare
+ subtype String_1 is Wide_String (1 .. S'Length);
+ Tmp : Wide_String_Access;
+ begin
+ Tmp := new Wide_String'(String_1 (S));
+ Finalize (UP);
+ UP.Reference := Tmp;
+ UP.Last := UP.Reference'Length;
+ end;
+ end if;
+ end Set_Wide_String;
+
+ procedure Set_Wide_String
+ (UP : in out Unbounded_Wide_String;
+ S : Wide_String_Access)
+ is
+ begin
+ Finalize (UP);
+ UP.Reference := S;
+ UP.Last := UP.Reference'Length;
+ end Set_Wide_String;
+
+end Ada.Strings.Wide_Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This child package of Ada.Strings.Wide_Unbounded provides some specialized
+-- access functions which are intended to allow more efficient use of the
+-- facilities of Ada.Strings.Wide_Unbounded, particularly by other layered
+-- utilities.
+
+package Ada.Strings.Wide_Unbounded.Aux is
+pragma Preelaborate (Aux);
+
+ function Get_Wide_String
+ (U : Unbounded_Wide_String) return Wide_String_Access;
+ pragma Inline (Get_Wide_String);
+ -- This function returns the internal string pointer used in the
+ -- representation of an unbounded string. There is no copy involved,
+ -- so the value obtained references the same string as the original
+ -- unbounded string. The characters of this string may not be modified
+ -- via the returned pointer, and are valid only as long as the original
+ -- unbounded string is not modified. Violating either of these two
+ -- rules results in erroneous execution.
+ --
+ -- This function is much more efficient than the use of To_Wide_String
+ -- since it avoids the need to copy the string. The lower bound of the
+ -- referenced string returned by this call is always one.
+
+ procedure Set_Wide_String
+ (UP : in out Unbounded_Wide_String;
+ S : Wide_String);
+ pragma Inline (Set_Wide_String);
+ -- This function sets the string contents of the referenced unbounded
+ -- string to the given string value. It is significantly more efficient
+ -- than the use of To_Unbounded_Wide_String with an assignment, since it
+ -- avoids the necessity of messing with finalization chains. The lower
+ -- bound of the string S is not required to be one.
+
+ procedure Set_Wide_String
+ (UP : in out Unbounded_Wide_String;
+ S : Wide_String_Access);
+ pragma Inline (Set_Wide_String);
+ -- This version of Set_Wide_String takes a string access value, rather
+ -- than string. The lower bound of the string value is required to be one,
+ -- and this requirement is not checked.
+
+end Ada.Strings.Wide_Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_UNBOUNDED.HASH --
+-- --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Wide_Unbounded.Hash
+ (Key : Unbounded_Wide_String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in 1 .. Key.Last loop
+ Tmp := Rotate_Left (Tmp, 1) + Wide_Character'Pos (Key.Reference (J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Wide_Unbounded.Hash;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_UNBOUNDED.HASH --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Wide_Unbounded.Hash
+ (Key : Unbounded_Wide_String) return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Wide_Unbounded.Hash);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_WIDE_MAPS.WIDE_WIDE_CONSTANTS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Wide_Wide_Latin_1;
+
+package Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants is
+pragma Preelaborate (Wide_Wide_Constants);
+
+ Control_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Graphic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Letter_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Lower_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Upper_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Basic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Decimal_Digit_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Hexadecimal_Digit_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Alphanumeric_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Special_Graphic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ ISO_646_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Character_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set;
+
+ Lower_Case_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping;
+ -- Maps to lower case for letters, else identity
+
+ Upper_Case_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping;
+ -- Maps to upper case for letters, else identity
+
+ Basic_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping;
+ -- Maps to basic letter for letters, else identity
+
+private
+ package W renames Ada.Characters.Wide_Wide_Latin_1;
+
+ subtype WC is Wide_Wide_Character;
+
+ Control_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ ((W.NUL, W.US),
+ (W.DEL, W.APC));
+
+ Control_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Control_Ranges'Unrestricted_Access);
+
+ Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ ((W.Space, W.Tilde),
+ (WC'Val (256), WC'Last));
+
+ Graphic_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Graphic_Ranges'Unrestricted_Access);
+
+ Letter_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (('A', 'Z'),
+ (W.LC_A, W.LC_Z),
+ (W.UC_A_Grave, W.UC_O_Diaeresis),
+ (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis),
+ (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis));
+
+ Letter_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Letter_Ranges'Unrestricted_Access);
+
+ Lower_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => (W.LC_A, W.LC_Z),
+ 2 => (W.LC_German_Sharp_S, W.LC_O_Diaeresis),
+ 3 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis));
+
+ Lower_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Lower_Ranges'Unrestricted_Access);
+
+ Upper_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => ('A', 'Z'),
+ 2 => (W.UC_A_Grave, W.UC_O_Diaeresis),
+ 3 => (W.UC_O_Oblique_Stroke, W.UC_Icelandic_Thorn));
+
+ Upper_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Upper_Ranges'Unrestricted_Access);
+
+ Basic_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => ('A', 'Z'),
+ 2 => (W.LC_A, W.LC_Z),
+ 3 => (W.UC_AE_Diphthong, W.UC_AE_Diphthong),
+ 4 => (W.LC_AE_Diphthong, W.LC_AE_Diphthong),
+ 5 => (W.LC_German_Sharp_S, W.LC_German_Sharp_S),
+ 6 => (W.UC_Icelandic_Thorn, W.UC_Icelandic_Thorn),
+ 7 => (W.LC_Icelandic_Thorn, W.LC_Icelandic_Thorn),
+ 8 => (W.UC_Icelandic_Eth, W.UC_Icelandic_Eth),
+ 9 => (W.LC_Icelandic_Eth, W.LC_Icelandic_Eth));
+
+ Basic_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Basic_Ranges'Unrestricted_Access);
+
+ Decimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => ('0', '9'));
+
+ Decimal_Digit_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Decimal_Digit_Ranges'Unrestricted_Access);
+
+ Hexadecimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => ('0', '9'),
+ 2 => ('A', 'F'),
+ 3 => (W.LC_A, W.LC_F));
+
+ Hexadecimal_Digit_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Hexadecimal_Digit_Ranges'Unrestricted_Access);
+
+ Alphanumeric_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => ('0', '9'),
+ 2 => ('A', 'Z'),
+ 3 => (W.LC_A, W.LC_Z),
+ 4 => (W.UC_A_Grave, W.UC_O_Diaeresis),
+ 5 => (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis),
+ 6 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis));
+
+ Alphanumeric_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Alphanumeric_Ranges'Unrestricted_Access);
+
+ Special_Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => (Wide_Wide_Space, W.Solidus),
+ 2 => (W.Colon, W.Commercial_At),
+ 3 => (W.Left_Square_Bracket, W.Grave),
+ 4 => (W.Left_Curly_Bracket, W.Tilde),
+ 5 => (W.No_Break_Space, W.Inverted_Question),
+ 6 => (W.Multiplication_Sign, W.Multiplication_Sign),
+ 7 => (W.Division_Sign, W.Division_Sign));
+
+ Special_Graphic_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Special_Graphic_Ranges'Unrestricted_Access);
+
+ ISO_646_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => (W.NUL, W.DEL));
+
+ ISO_646_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ ISO_646_Ranges'Unrestricted_Access);
+
+ Character_Ranges : aliased constant Wide_Wide_Character_Ranges :=
+ (1 => (W.NUL, WC'Val (255)));
+
+ Character_Set : constant Wide_Wide_Character_Set :=
+ (AF.Controlled with
+ Character_Ranges'Unrestricted_Access);
+
+
+ Lower_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values :=
+ (Length => 56,
+
+ Domain =>
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
+ W.UC_A_Grave &
+ W.UC_A_Acute &
+ W.UC_A_Circumflex &
+ W.UC_A_Tilde &
+ W.UC_A_Diaeresis &
+ W.UC_A_Ring &
+ W.UC_AE_Diphthong &
+ W.UC_C_Cedilla &
+ W.UC_E_Grave &
+ W.UC_E_Acute &
+ W.UC_E_Circumflex &
+ W.UC_E_Diaeresis &
+ W.UC_I_Grave &
+ W.UC_I_Acute &
+ W.UC_I_Circumflex &
+ W.UC_I_Diaeresis &
+ W.UC_Icelandic_Eth &
+ W.UC_N_Tilde &
+ W.UC_O_Grave &
+ W.UC_O_Acute &
+ W.UC_O_Circumflex &
+ W.UC_O_Tilde &
+ W.UC_O_Diaeresis &
+ W.UC_O_Oblique_Stroke &
+ W.UC_U_Grave &
+ W.UC_U_Acute &
+ W.UC_U_Circumflex &
+ W.UC_U_Diaeresis &
+ W.UC_Y_Acute &
+ W.UC_Icelandic_Thorn,
+
+ Rangev =>
+ "abcdefghijklmnopqrstuvwxyz" &
+ W.LC_A_Grave &
+ W.LC_A_Acute &
+ W.LC_A_Circumflex &
+ W.LC_A_Tilde &
+ W.LC_A_Diaeresis &
+ W.LC_A_Ring &
+ W.LC_AE_Diphthong &
+ W.LC_C_Cedilla &
+ W.LC_E_Grave &
+ W.LC_E_Acute &
+ W.LC_E_Circumflex &
+ W.LC_E_Diaeresis &
+ W.LC_I_Grave &
+ W.LC_I_Acute &
+ W.LC_I_Circumflex &
+ W.LC_I_Diaeresis &
+ W.LC_Icelandic_Eth &
+ W.LC_N_Tilde &
+ W.LC_O_Grave &
+ W.LC_O_Acute &
+ W.LC_O_Circumflex &
+ W.LC_O_Tilde &
+ W.LC_O_Diaeresis &
+ W.LC_O_Oblique_Stroke &
+ W.LC_U_Grave &
+ W.LC_U_Acute &
+ W.LC_U_Circumflex &
+ W.LC_U_Diaeresis &
+ W.LC_Y_Acute &
+ W.LC_Icelandic_Thorn);
+
+ Lower_Case_Map : constant Wide_Wide_Character_Mapping :=
+ (AF.Controlled with
+ Map => Lower_Case_Mapping'Unrestricted_Access);
+
+ Upper_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values :=
+ (Length => 56,
+
+ Domain =>
+ "abcdefghijklmnopqrstuvwxyz" &
+ W.LC_A_Grave &
+ W.LC_A_Acute &
+ W.LC_A_Circumflex &
+ W.LC_A_Tilde &
+ W.LC_A_Diaeresis &
+ W.LC_A_Ring &
+ W.LC_AE_Diphthong &
+ W.LC_C_Cedilla &
+ W.LC_E_Grave &
+ W.LC_E_Acute &
+ W.LC_E_Circumflex &
+ W.LC_E_Diaeresis &
+ W.LC_I_Grave &
+ W.LC_I_Acute &
+ W.LC_I_Circumflex &
+ W.LC_I_Diaeresis &
+ W.LC_Icelandic_Eth &
+ W.LC_N_Tilde &
+ W.LC_O_Grave &
+ W.LC_O_Acute &
+ W.LC_O_Circumflex &
+ W.LC_O_Tilde &
+ W.LC_O_Diaeresis &
+ W.LC_O_Oblique_Stroke &
+ W.LC_U_Grave &
+ W.LC_U_Acute &
+ W.LC_U_Circumflex &
+ W.LC_U_Diaeresis &
+ W.LC_Y_Acute &
+ W.LC_Icelandic_Thorn,
+
+ Rangev =>
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
+ W.UC_A_Grave &
+ W.UC_A_Acute &
+ W.UC_A_Circumflex &
+ W.UC_A_Tilde &
+ W.UC_A_Diaeresis &
+ W.UC_A_Ring &
+ W.UC_AE_Diphthong &
+ W.UC_C_Cedilla &
+ W.UC_E_Grave &
+ W.UC_E_Acute &
+ W.UC_E_Circumflex &
+ W.UC_E_Diaeresis &
+ W.UC_I_Grave &
+ W.UC_I_Acute &
+ W.UC_I_Circumflex &
+ W.UC_I_Diaeresis &
+ W.UC_Icelandic_Eth &
+ W.UC_N_Tilde &
+ W.UC_O_Grave &
+ W.UC_O_Acute &
+ W.UC_O_Circumflex &
+ W.UC_O_Tilde &
+ W.UC_O_Diaeresis &
+ W.UC_O_Oblique_Stroke &
+ W.UC_U_Grave &
+ W.UC_U_Acute &
+ W.UC_U_Circumflex &
+ W.UC_U_Diaeresis &
+ W.UC_Y_Acute &
+ W.UC_Icelandic_Thorn);
+
+ Upper_Case_Map : constant Wide_Wide_Character_Mapping :=
+ (AF.Controlled with
+ Upper_Case_Mapping'Unrestricted_Access);
+
+ Basic_Mapping : aliased constant Wide_Wide_Character_Mapping_Values :=
+ (Length => 55,
+
+ Domain =>
+ W.UC_A_Grave &
+ W.UC_A_Acute &
+ W.UC_A_Circumflex &
+ W.UC_A_Tilde &
+ W.UC_A_Diaeresis &
+ W.UC_A_Ring &
+ W.UC_C_Cedilla &
+ W.UC_E_Grave &
+ W.UC_E_Acute &
+ W.UC_E_Circumflex &
+ W.UC_E_Diaeresis &
+ W.UC_I_Grave &
+ W.UC_I_Acute &
+ W.UC_I_Circumflex &
+ W.UC_I_Diaeresis &
+ W.UC_N_Tilde &
+ W.UC_O_Grave &
+ W.UC_O_Acute &
+ W.UC_O_Circumflex &
+ W.UC_O_Tilde &
+ W.UC_O_Diaeresis &
+ W.UC_O_Oblique_Stroke &
+ W.UC_U_Grave &
+ W.UC_U_Acute &
+ W.UC_U_Circumflex &
+ W.UC_U_Diaeresis &
+ W.UC_Y_Acute &
+ W.LC_A_Grave &
+ W.LC_A_Acute &
+ W.LC_A_Circumflex &
+ W.LC_A_Tilde &
+ W.LC_A_Diaeresis &
+ W.LC_A_Ring &
+ W.LC_C_Cedilla &
+ W.LC_E_Grave &
+ W.LC_E_Acute &
+ W.LC_E_Circumflex &
+ W.LC_E_Diaeresis &
+ W.LC_I_Grave &
+ W.LC_I_Acute &
+ W.LC_I_Circumflex &
+ W.LC_I_Diaeresis &
+ W.LC_N_Tilde &
+ W.LC_O_Grave &
+ W.LC_O_Acute &
+ W.LC_O_Circumflex &
+ W.LC_O_Tilde &
+ W.LC_O_Diaeresis &
+ W.LC_O_Oblique_Stroke &
+ W.LC_U_Grave &
+ W.LC_U_Acute &
+ W.LC_U_Circumflex &
+ W.LC_U_Diaeresis &
+ W.LC_Y_Acute &
+ W.LC_Y_Diaeresis,
+
+ Rangev =>
+ 'A' & -- UC_A_Grave
+ 'A' & -- UC_A_Acute
+ 'A' & -- UC_A_Circumflex
+ 'A' & -- UC_A_Tilde
+ 'A' & -- UC_A_Diaeresis
+ 'A' & -- UC_A_Ring
+ 'C' & -- UC_C_Cedilla
+ 'E' & -- UC_E_Grave
+ 'E' & -- UC_E_Acute
+ 'E' & -- UC_E_Circumflex
+ 'E' & -- UC_E_Diaeresis
+ 'I' & -- UC_I_Grave
+ 'I' & -- UC_I_Acute
+ 'I' & -- UC_I_Circumflex
+ 'I' & -- UC_I_Diaeresis
+ 'N' & -- UC_N_Tilde
+ 'O' & -- UC_O_Grave
+ 'O' & -- UC_O_Acute
+ 'O' & -- UC_O_Circumflex
+ 'O' & -- UC_O_Tilde
+ 'O' & -- UC_O_Diaeresis
+ 'O' & -- UC_O_Oblique_Stroke
+ 'U' & -- UC_U_Grave
+ 'U' & -- UC_U_Acute
+ 'U' & -- UC_U_Circumflex
+ 'U' & -- UC_U_Diaeresis
+ 'Y' & -- UC_Y_Acute
+ 'a' & -- LC_A_Grave
+ 'a' & -- LC_A_Acute
+ 'a' & -- LC_A_Circumflex
+ 'a' & -- LC_A_Tilde
+ 'a' & -- LC_A_Diaeresis
+ 'a' & -- LC_A_Ring
+ 'c' & -- LC_C_Cedilla
+ 'e' & -- LC_E_Grave
+ 'e' & -- LC_E_Acute
+ 'e' & -- LC_E_Circumflex
+ 'e' & -- LC_E_Diaeresis
+ 'i' & -- LC_I_Grave
+ 'i' & -- LC_I_Acute
+ 'i' & -- LC_I_Circumflex
+ 'i' & -- LC_I_Diaeresis
+ 'n' & -- LC_N_Tilde
+ 'o' & -- LC_O_Grave
+ 'o' & -- LC_O_Acute
+ 'o' & -- LC_O_Circumflex
+ 'o' & -- LC_O_Tilde
+ 'o' & -- LC_O_Diaeresis
+ 'o' & -- LC_O_Oblique_Stroke
+ 'u' & -- LC_U_Grave
+ 'u' & -- LC_U_Acute
+ 'u' & -- LC_U_Circumflex
+ 'u' & -- LC_U_Diaeresis
+ 'y' & -- LC_Y_Acute
+ 'y'); -- LC_Y_Diaeresis
+
+ Basic_Map : constant Wide_Wide_Character_Mapping :=
+ (AF.Controlled with
+ Basic_Mapping'Unrestricted_Access);
+
+end Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Wide_Wide_Unbounded.Aux is
+
+ --------------------------
+ -- Get_Wide_Wide_String --
+ --------------------------
+
+ function Get_Wide_Wide_String
+ (U : Unbounded_Wide_Wide_String) return Wide_Wide_String_Access
+ is
+ begin
+ if U.Last = U.Reference'Length then
+ return U.Reference;
+
+ else
+ declare
+ type Unbounded_Wide_Wide_String_Access is
+ access all Unbounded_Wide_Wide_String;
+
+ U_Ptr : constant Unbounded_Wide_Wide_String_Access :=
+ U'Unrestricted_Access;
+ -- Unbounded_Wide_Wide_String is a controlled type which is always
+ -- passed by copy it is always safe to take the pointer to such
+ -- object here. This pointer is used to set the U.Reference value
+ -- which would not be possible otherwise as U is read-only.
+
+ Old : Wide_Wide_String_Access := U.Reference;
+
+ begin
+ U_Ptr.Reference :=
+ new Wide_Wide_String'(U.Reference (1 .. U.Last));
+ Free (Old);
+ return U.Reference;
+ end;
+ end if;
+ end Get_Wide_Wide_String;
+
+ --------------------------
+ -- Set_Wide_Wide_String --
+ --------------------------
+
+ procedure Set_Wide_Wide_String
+ (UP : in out Unbounded_Wide_Wide_String;
+ S : Wide_Wide_String)
+ is
+ begin
+ if UP.Last = S'Length then
+ UP.Reference.all := S;
+
+ else
+ declare
+ subtype String_1 is Wide_Wide_String (1 .. S'Length);
+ Tmp : Wide_Wide_String_Access;
+ begin
+ Tmp := new Wide_Wide_String'(String_1 (S));
+ Finalize (UP);
+ UP.Reference := Tmp;
+ UP.Last := UP.Reference'Length;
+ end;
+ end if;
+ end Set_Wide_Wide_String;
+
+ procedure Set_Wide_Wide_String
+ (UP : in out Unbounded_Wide_Wide_String;
+ S : Wide_Wide_String_Access)
+ is
+ begin
+ Finalize (UP);
+ UP.Reference := S;
+ UP.Last := UP.Reference'Length;
+ end Set_Wide_Wide_String;
+
+end Ada.Strings.Wide_Wide_Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This child package of Ada.Strings.Wide_Wide_Unbounded provides some
+-- specialized access functions which are intended to allow more efficient
+-- use of the facilities of Ada.Strings.Wide_Wide_Unbounded, particularly by
+-- other layered utilities.
+
+package Ada.Strings.Wide_Wide_Unbounded.Aux is
+pragma Preelaborate (Aux);
+
+ function Get_Wide_Wide_String
+ (U : Unbounded_Wide_Wide_String) return Wide_Wide_String_Access;
+ pragma Inline (Get_Wide_Wide_String);
+ -- This function returns the internal string pointer used in the
+ -- representation of an unbounded string. There is no copy involved,
+ -- so the value obtained references the same string as the original
+ -- unbounded string. The characters of this string may not be modified
+ -- via the returned pointer, and are valid only as long as the original
+ -- unbounded string is not modified. Violating either of these two
+ -- rules results in erroneous execution.
+ --
+ -- This function is much more efficient than the use of To_Wide_Wide_String
+ -- since it avoids the need to copy the string. The lower bound of the
+ -- referenced string returned by this call is always one.
+
+ procedure Set_Wide_Wide_String
+ (UP : in out Unbounded_Wide_Wide_String;
+ S : Wide_Wide_String);
+ pragma Inline (Set_Wide_Wide_String);
+ -- This function sets the string contents of the referenced unbounded
+ -- string to the given string value. It is significantly more efficient
+ -- than the use of To_Unbounded_Wide_Wide_String with an assignment, since
+ -- it avoids the necessity of messing with finalization chains. The lower
+ -- bound of the string S is not required to be one.
+
+ procedure Set_Wide_Wide_String
+ (UP : in out Unbounded_Wide_Wide_String;
+ S : Wide_Wide_String_Access);
+ pragma Inline (Set_Wide_Wide_String);
+ -- This version of Set_Wide_Wide_String takes a string access value, rather
+ -- than string. The lower bound of the string value is required to be one,
+ -- and this requirement is not checked.
+
+end Ada.Strings.Wide_Wide_Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . H A S H --
+-- --
+-- B o d y --
+-- --
+-- 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 --
+-- 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 was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Wide_Wide_Unbounded.Hash
+ (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in 1 .. Key.Last loop
+ Tmp := Rotate_Left (Tmp, 1) +
+ Wide_Wide_Character'Pos (Key.Reference (J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Wide_Wide_Unbounded.Hash;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . H A S H --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Wide_Wide_Unbounded.Hash
+ (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Hash);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_WIDE_UNBOUNDED.WIDE_WIDE_TEXT_IO --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Wide_Unbounded.Aux;
+use Ada.Strings.Wide_Wide_Unbounded.Aux;
+with Ada.Wide_Wide_Text_IO;
+use Ada.Wide_Wide_Text_IO;
+
+package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ function Get_Line return Unbounded_Wide_Wide_String is
+ Buffer : Wide_Wide_String (1 .. 1000);
+ Last : Natural;
+ Str1 : Wide_Wide_String_Access;
+ Str2 : Wide_Wide_String_Access;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Get_Line (Buffer, Last);
+ Str1 := new Wide_Wide_String'(Buffer (1 .. Last));
+ while Last = Buffer'Last loop
+ Get_Line (Buffer, Last);
+ Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last));
+ Free (Str1);
+ Str1 := Str2;
+ end loop;
+
+ Set_Wide_Wide_String (Result, Str1);
+ return Result;
+ end Get_Line;
+
+ function Get_Line
+ (File : Ada.Wide_Wide_Text_IO.File_Type)
+ return Unbounded_Wide_Wide_String
+ is
+ Buffer : Wide_Wide_String (1 .. 1000);
+ Last : Natural;
+ Str1 : Wide_Wide_String_Access;
+ Str2 : Wide_Wide_String_Access;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Str1 := new Wide_Wide_String'(Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last));
+ Free (Str1);
+ Str1 := Str2;
+ end loop;
+
+ Set_Wide_Wide_String (Result, Str1);
+ return Result;
+ end Get_Line;
+
+ procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is
+ Buffer : Wide_Wide_String (1 .. 1000);
+ Last : Natural;
+ Str1 : Wide_Wide_String_Access;
+ Str2 : Wide_Wide_String_Access;
+
+ begin
+ Get_Line (Buffer, Last);
+ Str1 := new Wide_Wide_String'(Buffer (1 .. Last));
+ while Last = Buffer'Last loop
+ Get_Line (Buffer, Last);
+ Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last));
+ Free (Str1);
+ Str1 := Str2;
+ end loop;
+
+ Set_Wide_Wide_String (Item, Str1);
+ end Get_Line;
+
+ procedure Get_Line
+ (File : Ada.Wide_Wide_Text_IO.File_Type;
+ Item : out Unbounded_Wide_Wide_String)
+ is
+ Buffer : Wide_Wide_String (1 .. 1000);
+ Last : Natural;
+ Str1 : Wide_Wide_String_Access;
+ Str2 : Wide_Wide_String_Access;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Str1 := new Wide_Wide_String'(Buffer (1 .. Last));
+ while Last = Buffer'Last loop
+ Get_Line (Buffer, Last);
+ Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last));
+ Free (Str1);
+ Str1 := Str2;
+ end loop;
+
+ Set_Wide_Wide_String (Item, Str1);
+ end Get_Line;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (U : Unbounded_Wide_Wide_String) is
+ begin
+ Put (Get_Wide_Wide_String (U).all);
+ end Put;
+
+ procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is
+ begin
+ Put (File, Get_Wide_Wide_String (U).all);
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (U : Unbounded_Wide_Wide_String) is
+ begin
+ Put_Line (Get_Wide_Wide_String (U).all);
+ end Put_Line;
+
+ procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is
+ begin
+ Put_Line (File, Get_Wide_Wide_String (U).all);
+ end Put_Line;
+
+end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_WIDE_UNBOUNDED.WIDE_WIDE_TEXT_IO --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1997-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This child package of Ada.Strings.Wide_Wide_Unbounded provides specialized
+-- Wide_Wide_Text_IO routines that work directly with unbounded wide wide
+-- strings, avoiding the inefficiencies of access via the standard interface,
+-- and also taking direct advantage of the variable length semantics of these
+-- strings.
+
+with Ada.Wide_Wide_Text_IO;
+
+package Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is
+
+ function Get_Line
+ return Unbounded_Wide_Wide_String;
+ function Get_Line
+ (File : Ada.Wide_Wide_Text_IO.File_Type)
+ return Unbounded_Wide_Wide_String;
+ -- Reads up to the end of the current line, returning the result
+ -- as an unbounded string of appropriate length. If no File parameter
+ -- is present, input is from Current_Input.
+
+ procedure Get_Line
+ (File : Ada.Wide_Wide_Text_IO.File_Type;
+ Item : out Unbounded_Wide_Wide_String);
+ procedure Get_Line (Item : out Unbounded_Wide_Wide_String);
+ -- Similar to the above, but in procedure form with an out parameter
+
+ procedure Put
+ (U : Unbounded_Wide_Wide_String);
+ procedure Put
+ (File : Ada.Wide_Wide_Text_IO.File_Type;
+ U : Unbounded_Wide_Wide_String);
+ procedure Put_Line
+ (U : Unbounded_Wide_Wide_String);
+ procedure Put_Line
+ (File : Ada.Wide_Wide_Text_IO.File_Type;
+ U : Unbounded_Wide_Wide_String);
+ -- These are equivalent to the standard Wide_Wide_Text_IO routines passed
+ -- the value To_Wide_Wide_String (U), but operate more efficiently,
+ -- because the extra copy of the argument is avoided.
+
+end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . U N B O U N D E D _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: historically GNAT provided these subprograms as a child of the
+-- package Ada.Strings.Unbounded. So we implement this new Ada 2005 package
+-- by renaming the subprograms in that child. This is a more straightforward
+-- implementation anyway, since we need access to the internal representation
+-- of Ada.Strings.Unbounded.Unbounded_String.
+
+
+with Ada.Strings.Unbounded;
+with Ada.Strings.Unbounded.Text_IO;
+
+package Ada.Text_IO.Unbounded_IO is
+
+ procedure Put
+ (File : File_Type;
+ Item : Strings.Unbounded.Unbounded_String)
+ renames Ada.Strings.Unbounded.Text_IO.Put;
+
+ procedure Put
+ (Item : Strings.Unbounded.Unbounded_String)
+ renames Ada.Strings.Unbounded.Text_IO.Put;
+
+ procedure Put_Line
+ (File : Text_IO.File_Type;
+ Item : Strings.Unbounded.Unbounded_String)
+ renames Ada.Strings.Unbounded.Text_IO.Put_Line;
+
+ procedure Put_Line
+ (Item : Strings.Unbounded.Unbounded_String)
+ renames Ada.Strings.Unbounded.Text_IO.Put_Line;
+
+ function Get_Line
+ (File : File_Type) return Strings.Unbounded.Unbounded_String
+ renames Ada.Strings.Unbounded.Text_IO.Get_Line;
+
+ function Get_Line return Strings.Unbounded.Unbounded_String
+ renames Ada.Strings.Unbounded.Text_IO.Get_Line;
+
+ procedure Get_Line
+ (File : File_Type;
+ Item : out Strings.Unbounded.Unbounded_String)
+ renames Ada.Strings.Unbounded.Text_IO.Get_Line;
+
+ procedure Get_Line
+ (Item : out Strings.Unbounded.Unbounded_String)
+ renames Ada.Strings.Unbounded.Text_IO.Get_Line;
+
+end Ada.Text_IO.Unbounded_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . W I D E _ U N B O U N D E D _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: historically GNAT provided these subprograms as a child of the
+-- package Ada.Strings.Wide_Unbounded. So we implement this new Ada 2005
+-- package by renaming the subprograms in that child. This is a more
+-- straightforward implementation anyway, since we need access to the
+-- internal representation of Unbounded_Wide_String.
+
+
+with Ada.Strings.Wide_Unbounded;
+with Ada.Strings.Wide_Unbounded.Wide_Text_IO;
+
+package Ada.Wide_Text_IO.Wide_Unbounded_IO is
+
+ procedure Put
+ (File : File_Type;
+ Item : Strings.Wide_Unbounded.Unbounded_Wide_String)
+ renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put;
+
+ procedure Put
+ (Item : Strings.Wide_Unbounded.Unbounded_Wide_String)
+ renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put;
+
+ procedure Put_Line
+ (File : Wide_Text_IO.File_Type;
+ Item : Strings.Wide_Unbounded.Unbounded_Wide_String)
+ renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line;
+
+ procedure Put_Line
+ (Item : Strings.Wide_Unbounded.Unbounded_Wide_String)
+ renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line;
+
+ function Get_Line
+ (File : File_Type) return Strings.Wide_Unbounded.Unbounded_Wide_String
+ renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line;
+
+ function Get_Line return Strings.Wide_Unbounded.Unbounded_Wide_String
+ renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line;
+
+ procedure Get_Line
+ (File : File_Type;
+ Item : out Strings.Wide_Unbounded.Unbounded_Wide_String)
+ renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line;
+
+ procedure Get_Line
+ (Item : out Strings.Wide_Unbounded.Unbounded_Wide_String)
+ renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line;
+
+end Ada.Wide_Text_IO.Wide_Unbounded_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+with Ada.Wide_Wide_Text_IO.Float_Aux;
+
+with System.Img_Real; use System.Img_Real;
+
+package body Ada.Wide_Wide_Text_IO.Complex_Aux is
+
+ package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer;
+ Paren : Boolean := False;
+
+ begin
+ -- General note for following code, exceptions from the calls
+ -- to Get for components of the complex value are propagated.
+
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr);
+
+ for J in Ptr + 1 .. Stop loop
+ if not Is_Blank (Buf (J)) then
+ raise Data_Error;
+ end if;
+ end loop;
+
+ -- Case of width = 0
+
+ else
+ Load_Skip (File);
+ Ptr := 0;
+ Load (File, Buf, Ptr, '(', Paren);
+ Aux.Get (File, ItemR, 0);
+ Load_Skip (File);
+ Load (File, Buf, Ptr, ',');
+ Aux.Get (File, ItemI, 0);
+
+ if Paren then
+ Load_Skip (File);
+ Load (File, Buf, Ptr, ')', Paren);
+
+ if not Paren then
+ raise Data_Error;
+ end if;
+ end if;
+ end if;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ procedure Gets
+ (From : String;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Last : out Positive)
+ is
+ Paren : Boolean;
+ Pos : Integer;
+
+ begin
+ String_Skip (From, Pos);
+
+ if From (Pos) = '(' then
+ Pos := Pos + 1;
+ Paren := True;
+ else
+ Paren := False;
+ end if;
+
+ Aux.Gets (From (Pos .. From'Last), ItemR, Pos);
+
+ String_Skip (From (Pos + 1 .. From'Last), Pos);
+
+ if From (Pos) = ',' then
+ Pos := Pos + 1;
+ end if;
+
+ Aux.Gets (From (Pos .. From'Last), ItemI, Pos);
+
+ if Paren then
+ String_Skip (From (Pos + 1 .. From'Last), Pos);
+
+ if From (Pos) /= ')' then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Last := Pos;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field)
+ is
+ begin
+ Put (File, '(');
+ Aux.Put (File, ItemR, Fore, Aft, Exp);
+ Put (File, ',');
+ Aux.Put (File, ItemI, Fore, Aft, Exp);
+ Put (File, ')');
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Aft : Field;
+ Exp : Field)
+ is
+ I_String : String (1 .. 3 * Field'Last);
+ R_String : String (1 .. 3 * Field'Last);
+
+ Iptr : Natural;
+ Rptr : Natural;
+
+ begin
+ -- Both parts are initially converted with a Fore of 0
+
+ Rptr := 0;
+ Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp);
+ Iptr := 0;
+ Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp);
+
+ -- Check room for both parts plus parens plus comma (RM G.1.3(34))
+
+ if Rptr + Iptr + 3 > To'Length then
+ raise Layout_Error;
+ end if;
+
+ -- If there is room, layout result according to (RM G.1.3(31-33))
+
+ To (To'First) := '(';
+ To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr);
+ To (To'First + Rptr + 1) := ',';
+
+ To (To'Last) := ')';
+
+
+ To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr);
+
+ for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop
+ To (J) := ' ';
+ end loop;
+ end Puts;
+
+end Ada.Wide_Wide_Text_IO.Complex_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Wide_Text_IO.Complex_IO
+-- that are shared among separate instantiations of this package. The routines
+-- in this package are identical semantically to those in Complex_IO itself,
+-- except that the generic parameter Complex has been replaced by separate
+-- real and imaginary values of type Long_Long_Float, and default parameters
+-- have been removed because they are supplied explicitly by the calls from
+-- within the generic template.
+
+package Ada.Wide_Wide_Text_IO.Complex_Aux is
+
+ procedure Get
+ (File : File_Type;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Width : Field);
+
+ procedure Gets
+ (From : String;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Last : out Positive);
+
+ procedure Put
+ (File : File_Type;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field);
+
+ procedure Puts
+ (To : out String;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Aft : Field;
+ Exp : Field);
+
+end Ada.Wide_Wide_Text_IO.Complex_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Complex_Aux;
+
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+with Ada.Unchecked_Conversion;
+
+package body Ada.Wide_Wide_Text_IO.Complex_IO is
+
+ package Aux renames Ada.Wide_Wide_Text_IO.Complex_Aux;
+
+ subtype LLF is Long_Long_Float;
+ -- Type used for calls to routines in Aux
+
+ function TFT is new
+ Ada.Unchecked_Conversion (File_Type, Ada.Wide_Wide_Text_IO.File_Type);
+ -- This unchecked conversion is to get around a visibility bug in
+ -- GNAT version 2.04w. It should be possible to simply use the
+ -- subtype declared above and do normal checked conversions.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Complex;
+ Width : Field := 0)
+ is
+ Real_Item : Real'Base;
+ Imag_Item : Real'Base;
+
+ begin
+ Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width);
+ Item := (Real_Item, Imag_Item);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (Item : out Complex;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Complex;
+ Last : out Positive)
+ is
+ Real_Item : Real'Base;
+ Imag_Item : Real'Base;
+
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last);
+ Item := (Real_Item, Imag_Item);
+
+ exception
+ when Data_Error => raise Constraint_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Complex;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp);
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (Item : Complex;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Complex;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp);
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Complex_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Numerics.Generic_Complex_Types;
+
+generic
+ with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>);
+
+package Ada.Wide_Wide_Text_IO.Complex_IO is
+
+ use Complex_Types;
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Real'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Get
+ (File : File_Type;
+ Item : out Complex;
+ Width : Field := 0);
+
+ procedure Get
+ (Item : out Complex;
+ Width : Field := 0);
+
+ procedure Put
+ (File : File_Type;
+ Item : Complex;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Put
+ (Item : Complex;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Complex;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Complex;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+end Ada.Wide_Wide_Text_IO.Complex_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . C _ S T R E A M S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.File_IO;
+with System.File_Control_Block;
+with Unchecked_Conversion;
+
+package body Ada.Wide_Wide_Text_IO.C_Streams is
+
+ package FIO renames System.File_IO;
+ package FCB renames System.File_Control_Block;
+
+ subtype AP is FCB.AFCB_Ptr;
+
+ function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
+
+ --------------
+ -- C_Stream --
+ --------------
+
+ function C_Stream (F : File_Type) return FILEs is
+ begin
+ FIO.Check_File_Open (AP (F));
+ return F.Stream;
+ end C_Stream;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : File_Mode;
+ C_Stream : FILEs;
+ Form : String := "";
+ Name : String := "")
+ is
+ Dummy_File_Control_Block : Wide_Wide_Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => Dummy_File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'W',
+ Creat => False,
+ Text => True,
+ C_Stream => C_Stream);
+
+ end Open;
+
+end Ada.Wide_Wide_Text_IO.C_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . C _ S T R E A M S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides an interface between Ada.Wide_Wide_Text_IO and the
+-- C streams. This allows sharing of a stream between Ada and C or C++,
+-- as well as allowing the Ada program to operate directly on the stream.
+
+with Interfaces.C_Streams;
+
+package Ada.Wide_Wide_Text_IO.C_Streams is
+
+ package ICS renames Interfaces.C_Streams;
+
+ function C_Stream (F : File_Type) return ICS.FILEs;
+ -- Obtain stream from existing open file
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : File_Mode;
+ C_Stream : ICS.FILEs;
+ Form : String := "";
+ Name : String := "");
+ -- Create new file from existing stream
+
+end Ada.Wide_Wide_Text_IO.C_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux;
+
+with System.Img_Dec; use System.Img_Dec;
+with System.Img_LLD; use System.Img_LLD;
+with System.Val_Dec; use System.Val_Dec;
+with System.Val_LLD; use System.Val_LLD;
+
+package body Ada.Wide_Wide_Text_IO.Decimal_Aux is
+
+ -------------
+ -- Get_Dec --
+ -------------
+
+ function Get_Dec
+ (File : File_Type;
+ Width : Field;
+ Scale : Integer) return Integer
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Integer;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ return Item;
+ end Get_Dec;
+
+ -------------
+ -- Get_LLD --
+ -------------
+
+ function Get_LLD
+ (File : File_Type;
+ Width : Field;
+ Scale : Integer) return Long_Long_Integer
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Long_Long_Integer;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ return Item;
+ end Get_LLD;
+
+ --------------
+ -- Gets_Dec --
+ --------------
+
+ function Gets_Dec
+ (From : String;
+ Last : access Positive;
+ Scale : Integer) return Integer
+ is
+ Pos : aliased Integer;
+ Item : Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
+ Last.all := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last.all := Pos - 1;
+ raise Data_Error;
+
+ end Gets_Dec;
+
+ --------------
+ -- Gets_LLD --
+ --------------
+
+ function Gets_LLD
+ (From : String;
+ Last : access Positive;
+ Scale : Integer) return Long_Long_Integer
+ is
+ Pos : aliased Integer;
+ Item : Long_Long_Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
+ Last.all := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last.all := Pos - 1;
+ raise Data_Error;
+
+ end Gets_LLD;
+
+ -------------
+ -- Put_Dec --
+ -------------
+
+ procedure Put_Dec
+ (File : File_Type;
+ Item : Integer;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Dec;
+
+ -------------
+ -- Put_LLD --
+ -------------
+
+ procedure Put_LLD
+ (File : File_Type;
+ Item : Long_Long_Integer;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLD;
+
+ --------------
+ -- Puts_Dec --
+ --------------
+
+ procedure Puts_Dec
+ (To : out String;
+ Item : Integer;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ if Exp = 0 then
+ Fore := To'Length - 1 - Aft;
+ else
+ Fore := To'Length - 2 - Aft - Exp;
+ end if;
+
+ if Fore < 1 then
+ raise Layout_Error;
+ end if;
+
+ Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts_Dec;
+
+ --------------
+ -- Puts_Dec --
+ --------------
+
+ procedure Puts_LLD
+ (To : out String;
+ Item : Long_Long_Integer;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ if Exp = 0 then
+ Fore := To'Length - 1 - Aft;
+ else
+ Fore := To'Length - 2 - Aft - Exp;
+ end if;
+
+ if Fore < 1 then
+ raise Layout_Error;
+ end if;
+
+ Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLD;
+
+end Ada.Wide_Wide_Text_IO.Decimal_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Wide_Text_IO.Decimal_IO
+-- that are shared among separate instantiations of this package. The
+-- routines in the package are identical semantically to those declared
+-- in Wide_Wide_Text_IO, except that default values have been supplied by the
+-- generic, and the Num parameter has been replaced by Integer or
+-- Long_Long_Integer, with an additional Scale parameter giving the
+-- value of Num'Scale. In addition the Get routines return the value
+-- rather than store it in an Out parameter.
+
+private package Ada.Wide_Wide_Text_IO.Decimal_Aux is
+
+ function Get_Dec
+ (File : File_Type;
+ Width : Field;
+ Scale : Integer) return Integer;
+
+ function Get_LLD
+ (File : File_Type;
+ Width : Field;
+ Scale : Integer) return Long_Long_Integer;
+
+ function Gets_Dec
+ (From : String;
+ Last : access Positive;
+ Scale : Integer) return Integer;
+
+ function Gets_LLD
+ (From : String;
+ Last : access Positive;
+ Scale : Integer) return Long_Long_Integer;
+
+ procedure Put_Dec
+ (File : File_Type;
+ Item : Integer;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer);
+
+ procedure Put_LLD
+ (File : File_Type;
+ Item : Long_Long_Integer;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer);
+
+ procedure Puts_Dec
+ (To : out String;
+ Item : Integer;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer);
+
+ procedure Puts_LLD
+ (To : out String;
+ Item : Long_Long_Integer;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer);
+
+end Ada.Wide_Wide_Text_IO.Decimal_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Decimal_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Decimal_IO is
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Wide_Text_IO.Decimal_Aux;
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ if Num'Size > Integer'Size then
+ Item := Num (Aux.Get_LLD (TFT (File), Width, Scale));
+ -- Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale));
+ -- above is what we should write, but gets assert error ???
+
+ else
+ Item := Num (Aux.Get_Dec (TFT (File), Width, Scale));
+ -- Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale));
+ -- above is what we should write, but gets assert error ???
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Num'Size > Integer'Size then
+ -- Item := Num'Fixed_Value
+ -- should write above, but gets assert error ???
+ Item := Num
+ (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale));
+ else
+ -- Item := Num'Fixed_Value
+ -- should write above, but gets assert error ???
+ Item := Num
+ (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Num'Size > Integer'Size then
+ Aux.Put_LLD
+-- (TFT (File), Long_Long_Integer'Integer_Value (Item),
+-- ???
+ (TFT (File), Long_Long_Integer (Item),
+ Fore, Aft, Exp, Scale);
+ else
+ Aux.Put_Dec
+-- (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
+-- ???
+ (TFT (File), Integer (Item), Fore, Aft, Exp, Scale);
+
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ pragma Unreferenced (Fore);
+ -- ??? how come this is unreferenced, sounds wrong ???
+ begin
+ Put (Current_Output, Item, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Num'Size > Integer'Size then
+-- Aux.Puts_LLD
+-- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
+-- ???
+ Aux.Puts_LLD
+ (S, Long_Long_Integer (Item), Aft, Exp, Scale);
+ else
+-- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale);
+-- ???
+ Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Decimal_IO is a subpackage of
+-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading the
+-- necessary code if Decimal_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the difference
+-- in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is delta <> digits <>;
+
+package Ada.Wide_Wide_Text_IO.Decimal_IO is
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Num'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0);
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+end Ada.Wide_Wide_Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Fixed;
+with Ada.Strings.Wide_Wide_Fixed;
+
+package body Ada.Wide_Wide_Text_IO.Editing is
+
+ package Strings renames Ada.Strings;
+ package Strings_Fixed renames Ada.Strings.Fixed;
+ package Strings_Wide_Wide_Fixed renames Ada.Strings.Wide_Wide_Fixed;
+ package Wide_Wide_Text_IO renames Ada.Wide_Wide_Text_IO;
+
+ -----------------------
+ -- Local_Subprograms --
+ -----------------------
+
+ function To_Wide (C : Character) return Wide_Wide_Character;
+ pragma Inline (To_Wide);
+ -- Convert Character to corresponding Wide_Wide_Character
+
+ ---------------------
+ -- Blank_When_Zero --
+ ---------------------
+
+ function Blank_When_Zero (Pic : in Picture) return Boolean is
+ begin
+ return Pic.Contents.Original_BWZ;
+ end Blank_When_Zero;
+
+ --------------------
+ -- Decimal_Output --
+ --------------------
+
+ package body Decimal_Output is
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image
+ (Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency;
+ Fill : Wide_Wide_Character := Default_Fill;
+ Separator : Wide_Wide_Character := Default_Separator;
+ Radix_Mark : Wide_Wide_Character := Default_Radix_Mark)
+ return Wide_Wide_String
+ is
+ begin
+ return Format_Number
+ (Pic.Contents, Num'Image (Item),
+ Currency, Fill, Separator, Radix_Mark);
+ end Image;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length
+ (Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency) return Natural
+ is
+ Picstr : constant String := Pic_String (Pic);
+ V_Adjust : Integer := 0;
+ Cur_Adjust : Integer := 0;
+
+ begin
+ -- Check if Picstr has 'V' or '$'
+
+ -- If 'V', then length is 1 less than otherwise
+
+ -- If '$', then length is Currency'Length-1 more than otherwise
+
+ -- This should use the string handling package ???
+
+ for J in Picstr'Range loop
+ if Picstr (J) = 'V' then
+ V_Adjust := -1;
+
+ elsif Picstr (J) = '$' then
+ Cur_Adjust := Currency'Length - 1;
+ end if;
+ end loop;
+
+ return Picstr'Length - V_Adjust + Cur_Adjust;
+ end Length;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : Wide_Wide_Text_IO.File_Type;
+ Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency;
+ Fill : Wide_Wide_Character := Default_Fill;
+ Separator : Wide_Wide_Character := Default_Separator;
+ Radix_Mark : Wide_Wide_Character := Default_Radix_Mark)
+ is
+ begin
+ Wide_Wide_Text_IO.Put (File, Image (Item, Pic,
+ Currency, Fill, Separator, Radix_Mark));
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency;
+ Fill : Wide_Wide_Character := Default_Fill;
+ Separator : Wide_Wide_Character := Default_Separator;
+ Radix_Mark : Wide_Wide_Character := Default_Radix_Mark)
+ is
+ begin
+ Wide_Wide_Text_IO.Put (Image (Item, Pic,
+ Currency, Fill, Separator, Radix_Mark));
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency;
+ Fill : Wide_Wide_Character := Default_Fill;
+ Separator : Wide_Wide_Character := Default_Separator;
+ Radix_Mark : Wide_Wide_Character := Default_Radix_Mark)
+ is
+ Result : constant Wide_Wide_String :=
+ Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
+
+ begin
+ if Result'Length > To'Length then
+ raise Wide_Wide_Text_IO.Layout_Error;
+ else
+ Strings_Wide_Wide_Fixed.Move (Source => Result, Target => To,
+ Justify => Strings.Right);
+ end if;
+ end Put;
+
+ -----------
+ -- Valid --
+ -----------
+
+ function Valid
+ (Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency) return Boolean
+ is
+ begin
+ declare
+ Temp : constant Wide_Wide_String := Image (Item, Pic, Currency);
+ pragma Warnings (Off, Temp);
+ begin
+ return True;
+ end;
+
+ exception
+ when Layout_Error => return False;
+
+ end Valid;
+ end Decimal_Output;
+
+ ------------
+ -- Expand --
+ ------------
+
+ function Expand (Picture : in String) return String is
+ Result : String (1 .. MAX_PICSIZE);
+ Picture_Index : Integer := Picture'First;
+ Result_Index : Integer := Result'First;
+ Count : Natural;
+ Last : Integer;
+
+ begin
+ if Picture'Length < 1 then
+ raise Picture_Error;
+ end if;
+
+ if Picture (Picture'First) = '(' then
+ raise Picture_Error;
+ end if;
+
+ loop
+ case Picture (Picture_Index) is
+
+ when '(' =>
+
+ -- We now need to scan out the count after a left paren. In
+ -- the non-wide version we used Integer_IO.Get, but that is
+ -- not convenient here, since we don't want to drag in normal
+ -- Text_IO just for this purpose. So we do the scan ourselves,
+ -- with the normal validity checks.
+
+ Last := Picture_Index + 1;
+ Count := 0;
+
+ if Picture (Last) not in '0' .. '9' then
+ raise Picture_Error;
+ end if;
+
+ Count := Character'Pos (Picture (Last)) - Character'Pos ('0');
+ Last := Last + 1;
+
+ loop
+ if Last > Picture'Last then
+ raise Picture_Error;
+ end if;
+
+ if Picture (Last) = '_' then
+ if Picture (Last - 1) = '_' then
+ raise Picture_Error;
+ end if;
+
+ elsif Picture (Last) = ')' then
+ exit;
+
+ elsif Picture (Last) not in '0' .. '9' then
+ raise Picture_Error;
+
+ else
+ Count := Count * 10
+ + Character'Pos (Picture (Last)) -
+ Character'Pos ('0');
+ end if;
+
+ Last := Last + 1;
+ end loop;
+
+ -- In what follows note that one copy of the repeated
+ -- character has already been made, so a count of one is
+ -- no-op, and a count of zero erases a character.
+
+ for J in 2 .. Count loop
+ Result (Result_Index + J - 2) := Picture (Picture_Index - 1);
+ end loop;
+
+ Result_Index := Result_Index + Count - 1;
+
+ -- Last was a ')' throw it away too.
+
+ Picture_Index := Last + 1;
+
+ when ')' =>
+ raise Picture_Error;
+
+ when others =>
+ Result (Result_Index) := Picture (Picture_Index);
+ Picture_Index := Picture_Index + 1;
+ Result_Index := Result_Index + 1;
+
+ end case;
+
+ exit when Picture_Index > Picture'Last;
+ end loop;
+
+ return Result (1 .. Result_Index - 1);
+
+ exception
+ when others =>
+ raise Picture_Error;
+ end Expand;
+
+ -------------------
+ -- Format_Number --
+ -------------------
+
+ function Format_Number
+ (Pic : Format_Record;
+ Number : String;
+ Currency_Symbol : Wide_Wide_String;
+ Fill_Character : Wide_Wide_Character;
+ Separator_Character : Wide_Wide_Character;
+ Radix_Point : Wide_Wide_Character) return Wide_Wide_String
+ is
+ Attrs : Number_Attributes := Parse_Number_String (Number);
+ Position : Integer;
+ Rounded : String := Number;
+
+ Sign_Position : Integer := Pic.Sign_Position; -- may float.
+
+ Answer : Wide_Wide_String (1 .. Pic.Picture.Length);
+ Last : Integer;
+ Currency_Pos : Integer := Pic.Start_Currency;
+
+ Dollar : Boolean := False;
+ -- Overridden immediately if necessary.
+
+ Zero : Boolean := True;
+ -- Set to False when a non-zero digit is output.
+
+ begin
+
+ -- If the picture has fewer decimal places than the number, the image
+ -- must be rounded according to the usual rules.
+
+ if Attrs.Has_Fraction then
+ declare
+ R : constant Integer :=
+ (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1)
+ - Pic.Max_Trailing_Digits;
+ R_Pos : Integer;
+
+ begin
+ if R > 0 then
+ R_Pos := Rounded'Length - R;
+
+ if Rounded (R_Pos + 1) > '4' then
+
+ if Rounded (R_Pos) = '.' then
+ R_Pos := R_Pos - 1;
+ end if;
+
+ if Rounded (R_Pos) /= '9' then
+ Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
+ else
+ Rounded (R_Pos) := '0';
+ R_Pos := R_Pos - 1;
+
+ while R_Pos > 1 loop
+ if Rounded (R_Pos) = '.' then
+ R_Pos := R_Pos - 1;
+ end if;
+
+ if Rounded (R_Pos) /= '9' then
+ Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
+ exit;
+ else
+ Rounded (R_Pos) := '0';
+ R_Pos := R_Pos - 1;
+ end if;
+ end loop;
+
+ -- The rounding may add a digit in front. Either the
+ -- leading blank or the sign (already captured) can be
+ -- overwritten.
+
+ if R_Pos = 1 then
+ Rounded (R_Pos) := '1';
+ Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1;
+ end if;
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+
+ for J in Answer'Range loop
+ Answer (J) := To_Wide (Pic.Picture.Expanded (J));
+ end loop;
+
+ if Pic.Start_Currency /= Invalid_Position then
+ Dollar := Answer (Pic.Start_Currency) = '$';
+ end if;
+
+ -- Fix up "direct inserts" outside the playing field. Set up as one
+ -- loop to do the beginning, one (reverse) loop to do the end.
+
+ Last := 1;
+ loop
+ exit when Last = Pic.Start_Float;
+ exit when Last = Pic.Radix_Position;
+ exit when Answer (Last) = '9';
+
+ case Answer (Last) is
+
+ when '_' =>
+ Answer (Last) := Separator_Character;
+
+ when 'b' =>
+ Answer (Last) := ' ';
+
+ when others =>
+ null;
+
+ end case;
+
+ exit when Last = Answer'Last;
+
+ Last := Last + 1;
+ end loop;
+
+ -- Now for the end...
+
+ for J in reverse Last .. Answer'Last loop
+ exit when J = Pic.Radix_Position;
+
+ -- Do this test First, Separator_Character can equal Pic.Floater
+
+ if Answer (J) = Pic.Floater then
+ exit;
+ end if;
+
+ case Answer (J) is
+
+ when '_' =>
+ Answer (J) := Separator_Character;
+
+ when 'b' =>
+ Answer (J) := ' ';
+
+ when '9' =>
+ exit;
+
+ when others =>
+ null;
+
+ end case;
+ end loop;
+
+ -- Non-floating sign
+
+ if Pic.Start_Currency /= -1
+ and then Answer (Pic.Start_Currency) = '#'
+ and then Pic.Floater /= '#'
+ then
+ if Currency_Symbol'Length >
+ Pic.End_Currency - Pic.Start_Currency + 1
+ then
+ raise Picture_Error;
+
+ elsif Currency_Symbol'Length =
+ Pic.End_Currency - Pic.Start_Currency + 1
+ then
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ Currency_Symbol;
+
+ elsif Pic.Radix_Position = Invalid_Position
+ or else Pic.Start_Currency < Pic.Radix_Position
+ then
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ (others => ' ');
+ Answer (Pic.End_Currency - Currency_Symbol'Length + 1 ..
+ Pic.End_Currency) := Currency_Symbol;
+
+ else
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ (others => ' ');
+ Answer (Pic.Start_Currency ..
+ Pic.Start_Currency + Currency_Symbol'Length - 1) :=
+ Currency_Symbol;
+ end if;
+ end if;
+
+ -- Fill in leading digits
+
+ if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
+ Pic.Max_Leading_Digits
+ then
+ raise Layout_Error;
+ end if;
+
+ if Pic.Radix_Position = Invalid_Position then
+ Position := Answer'Last;
+ else
+ Position := Pic.Radix_Position - 1;
+ end if;
+
+ for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop
+
+ while Answer (Position) /= '9'
+ and Answer (Position) /= Pic.Floater
+ loop
+ if Answer (Position) = '_' then
+ Answer (Position) := Separator_Character;
+
+ elsif Answer (Position) = 'b' then
+ Answer (Position) := ' ';
+ end if;
+
+ Position := Position - 1;
+ end loop;
+
+ Answer (Position) := To_Wide (Rounded (J));
+
+ if Rounded (J) /= '0' then
+ Zero := False;
+ end if;
+
+ Position := Position - 1;
+ end loop;
+
+ -- Do lead float
+
+ if Pic.Start_Float = Invalid_Position then
+
+ -- No leading floats, but need to change '9' to '0', '_' to
+ -- Separator_Character and 'b' to ' '.
+
+ for J in Last .. Position loop
+
+ -- Last set when fixing the "uninteresting" leaders above.
+ -- Don't duplicate the work.
+
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ end if;
+
+ end loop;
+
+ elsif Pic.Floater = '<'
+ or else
+ Pic.Floater = '+'
+ or else
+ Pic.Floater = '-'
+ then
+ for J in Pic.End_Float .. Position loop -- May be null range
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position - 1 loop
+ Answer (J) := ' ';
+ end loop;
+
+ Answer (Position) := Pic.Floater;
+ Sign_Position := Position;
+
+ elsif Pic.Floater = '$' then
+
+ for J in Pic.End_Float .. Position loop -- May be null range
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := ' '; -- no separator before leftmost digit
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position - 1 loop
+ Answer (J) := ' ';
+ end loop;
+
+ Answer (Position) := Pic.Floater;
+ Currency_Pos := Position;
+
+ elsif Pic.Floater = '*' then
+
+ for J in Pic.End_Float .. Position loop -- May be null range
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := '*';
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position loop
+ Answer (J) := '*';
+ end loop;
+
+ else
+ if Pic.Floater = '#' then
+ Currency_Pos := Currency_Symbol'Length;
+ end if;
+
+ for J in reverse Pic.Start_Float .. Position loop
+ case Answer (J) is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'b' | '/' | '0' =>
+ Answer (J) := ' ';
+
+ when '9' =>
+ Answer (J) := '0';
+
+ when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' =>
+ null;
+
+ when '#' =>
+ if Currency_Pos = 0 then
+ Answer (J) := ' ';
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos - 1;
+ end if;
+
+ when '_' =>
+
+ case Pic.Floater is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'b' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos = 0 then
+ Answer (J) := ' ';
+
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos - 1;
+ end if;
+
+ when others =>
+ null;
+
+ end case;
+
+ when others =>
+ null;
+
+ end case;
+ end loop;
+
+ if Pic.Floater = '#' and then Currency_Pos /= 0 then
+ raise Layout_Error;
+ end if;
+ end if;
+
+ -- Do sign
+
+ if Sign_Position = Invalid_Position then
+ if Attrs.Negative then
+ raise Layout_Error;
+ end if;
+
+ else
+ if Attrs.Negative then
+ case Answer (Sign_Position) is
+ when 'C' | 'D' | '-' =>
+ null;
+
+ when '+' =>
+ Answer (Sign_Position) := '-';
+
+ when '<' =>
+ Answer (Sign_Position) := '(';
+ Answer (Pic.Second_Sign) := ')';
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+
+ else -- positive
+
+ case Answer (Sign_Position) is
+
+ when '-' =>
+ Answer (Sign_Position) := ' ';
+
+ when '<' | 'C' | 'D' =>
+ Answer (Sign_Position) := ' ';
+ Answer (Pic.Second_Sign) := ' ';
+
+ when '+' =>
+ null;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+ end if;
+ end if;
+
+ -- Fill in trailing digits
+
+ if Pic.Max_Trailing_Digits > 0 then
+
+ if Attrs.Has_Fraction then
+ Position := Attrs.Start_Of_Fraction;
+ Last := Pic.Radix_Position + 1;
+
+ for J in Last .. Answer'Last loop
+
+ if Answer (J) = '9' or Answer (J) = Pic.Floater then
+ Answer (J) := To_Wide (Rounded (Position));
+
+ if Rounded (Position) /= '0' then
+ Zero := False;
+ end if;
+
+ Position := Position + 1;
+ Last := J + 1;
+
+ -- Used up fraction but remember place in Answer
+
+ exit when Position > Attrs.End_Of_Fraction;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ end if;
+
+ Last := J + 1;
+ end loop;
+
+ Position := Last;
+
+ else
+ Position := Pic.Radix_Position + 1;
+ end if;
+
+ -- Now fill remaining 9's with zeros and _ with separators
+
+ Last := Answer'Last;
+
+ for J in Position .. Last loop
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = Pic.Floater then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ end if;
+ end loop;
+
+ Position := Last + 1;
+
+ else
+ if Pic.Floater = '#' and then Currency_Pos /= 0 then
+ raise Layout_Error;
+ end if;
+
+ -- No trailing digits, but now J may need to stick in a currency
+ -- symbol or sign.
+
+ if Pic.Start_Currency = Invalid_Position then
+ Position := Answer'Last + 1;
+ else
+ Position := Pic.Start_Currency;
+ end if;
+ end if;
+
+ for J in Position .. Answer'Last loop
+
+ if Pic.Start_Currency /= Invalid_Position and then
+ Answer (Pic.Start_Currency) = '#' then
+ Currency_Pos := 1;
+ end if;
+
+ -- Note: There are some weird cases J can imagine with 'b' or '#'
+ -- in currency strings where the following code will cause
+ -- glitches. The trick is to tell when the character in the
+ -- answer should be checked, and when to look at the original
+ -- string. Some other time. RIE 11/26/96 ???
+
+ case Answer (J) is
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'b' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos > Currency_Symbol'Length then
+ Answer (J) := ' ';
+
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
+ end if;
+
+ when '_' =>
+
+ case Pic.Floater is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'z' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos > Currency_Symbol'Length then
+ Answer (J) := ' ';
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
+ end if;
+
+ when others =>
+ null;
+
+ end case;
+
+ when others =>
+ exit;
+
+ end case;
+ end loop;
+
+ -- Now get rid of Blank_when_Zero and complete Star fill.
+
+ if Zero and Pic.Blank_When_Zero then
+
+ -- Value is zero, and blank it.
+
+ Last := Answer'Last;
+
+ if Dollar then
+ Last := Last - 1 + Currency_Symbol'Length;
+ end if;
+
+ if Pic.Radix_Position /= Invalid_Position and then
+ Answer (Pic.Radix_Position) = 'V' then
+ Last := Last - 1;
+ end if;
+
+ return Wide_Wide_String'(1 .. Last => ' ');
+
+ elsif Zero and Pic.Star_Fill then
+ Last := Answer'Last;
+
+ if Dollar then
+ Last := Last - 1 + Currency_Symbol'Length;
+ end if;
+
+ if Pic.Radix_Position /= Invalid_Position then
+
+ if Answer (Pic.Radix_Position) = 'V' then
+ Last := Last - 1;
+
+ elsif Dollar then
+ if Pic.Radix_Position > Pic.Start_Currency then
+ return
+ Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
+ Radix_Point &
+ Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
+
+ else
+ return
+ Wide_Wide_String'
+ (1 ..
+ Pic.Radix_Position + Currency_Symbol'Length - 2
+ => '*') &
+ Radix_Point &
+ Wide_Wide_String'
+ (Pic.Radix_Position + Currency_Symbol'Length .. Last
+ => '*');
+ end if;
+
+ else
+ return
+ Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
+ Radix_Point &
+ Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
+ end if;
+ end if;
+
+ return Wide_Wide_String'(1 .. Last => '*');
+ end if;
+
+ -- This was once a simple return statement, now there are nine
+ -- different return cases. Not to mention the five above to deal
+ -- with zeros. Why not split things out?
+
+ -- Processing the radix and sign expansion separately
+ -- would require lots of copying--the string and some of its
+ -- indicies--without really simplifying the logic. The cases are:
+
+ -- 1) Expand $, replace '.' with Radix_Point
+ -- 2) No currency expansion, replace '.' with Radix_Point
+ -- 3) Expand $, radix blanked
+ -- 4) No currency expansion, radix blanked
+ -- 5) Elide V
+ -- 6) Expand $, Elide V
+ -- 7) Elide V, Expand $ (Two cases depending on order.)
+ -- 8) No radix, expand $
+ -- 9) No radix, no currency expansion
+
+ if Pic.Radix_Position /= Invalid_Position then
+
+ if Answer (Pic.Radix_Position) = '.' then
+ Answer (Pic.Radix_Position) := Radix_Point;
+
+ if Dollar then
+
+ -- 1) Expand $, replace '.' with Radix_Point
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 2) No currency expansion, replace '.' with Radix_Point
+
+ return Answer;
+ end if;
+
+ elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix.
+ if Dollar then
+
+ -- 3) Expand $, radix blanked
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 4) No expansion, radix blanked
+
+ return Answer;
+ end if;
+
+ -- V cases
+
+ else
+ if not Dollar then
+
+ -- 5) Elide V
+
+ return Answer (1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Answer'Last);
+
+ elsif Currency_Pos < Pic.Radix_Position then
+
+ -- 6) Expand $, Elide V
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Answer'Last);
+
+ else
+ -- 7) Elide V, Expand $
+
+ return Answer (1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) &
+ Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+ end if;
+ end if;
+
+ elsif Dollar then
+
+ -- 8) No radix, expand $
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 9) No radix, no currency expansion
+
+ return Answer;
+ end if;
+ end Format_Number;
+
+ -------------------------
+ -- Parse_Number_String --
+ -------------------------
+
+ function Parse_Number_String (Str : String) return Number_Attributes is
+ Answer : Number_Attributes;
+
+ begin
+ for J in Str'Range loop
+ case Str (J) is
+
+ when ' ' =>
+ null; -- ignore
+
+ when '1' .. '9' =>
+
+ -- Decide if this is the start of a number.
+ -- If so, figure out which one...
+
+ if Answer.Has_Fraction then
+ Answer.End_Of_Fraction := J;
+ else
+ if Answer.Start_Of_Int = Invalid_Position then
+ -- start integer
+ Answer.Start_Of_Int := J;
+ end if;
+ Answer.End_Of_Int := J;
+ end if;
+
+ when '0' =>
+
+ -- Only count a zero before the decimal point if it follows a
+ -- non-zero digit. After the decimal point, zeros will be
+ -- counted if followed by a non-zero digit.
+
+ if not Answer.Has_Fraction then
+ if Answer.Start_Of_Int /= Invalid_Position then
+ Answer.End_Of_Int := J;
+ end if;
+ end if;
+
+ when '-' =>
+
+ -- Set negative
+
+ Answer.Negative := True;
+
+ when '.' =>
+
+ -- Close integer, start fraction
+
+ if Answer.Has_Fraction then
+ raise Picture_Error;
+ end if;
+
+ -- Two decimal points is a no-no.
+
+ Answer.Has_Fraction := True;
+ Answer.End_Of_Fraction := J;
+
+ -- Could leave this at Invalid_Position, but this seems the
+ -- right way to indicate a null range...
+
+ Answer.Start_Of_Fraction := J + 1;
+ Answer.End_Of_Int := J - 1;
+
+ when others =>
+ raise Picture_Error; -- can this happen? probably not!
+ end case;
+ end loop;
+
+ if Answer.Start_Of_Int = Invalid_Position then
+ Answer.Start_Of_Int := Answer.End_Of_Int + 1;
+ end if;
+
+ -- No significant (intger) digits needs a null range.
+
+ return Answer;
+ end Parse_Number_String;
+
+ ----------------
+ -- Pic_String --
+ ----------------
+
+ -- The following ensures that we return B and not b being careful not
+ -- to break things which expect lower case b for blank. See CXF3A02.
+
+ function Pic_String (Pic : in Picture) return String is
+ Temp : String (1 .. Pic.Contents.Picture.Length) :=
+ Pic.Contents.Picture.Expanded;
+ begin
+ for J in Temp'Range loop
+ if Temp (J) = 'b' then Temp (J) := 'B'; end if;
+ end loop;
+
+ return Temp;
+ end Pic_String;
+
+ ------------------
+ -- Precalculate --
+ ------------------
+
+ procedure Precalculate (Pic : in out Format_Record) is
+
+ Computed_BWZ : Boolean := True;
+
+ type Legality is (Okay, Reject);
+ State : Legality := Reject;
+ -- Start in reject, which will reject null strings.
+
+ Index : Pic_Index := Pic.Picture.Expanded'First;
+
+ function At_End return Boolean;
+ pragma Inline (At_End);
+
+ procedure Set_State (L : Legality);
+ pragma Inline (Set_State);
+
+ function Look return Character;
+ pragma Inline (Look);
+
+ function Is_Insert return Boolean;
+ pragma Inline (Is_Insert);
+
+ procedure Skip;
+ pragma Inline (Skip);
+
+ procedure Trailing_Currency;
+ procedure Trailing_Bracket;
+ procedure Number_Fraction;
+ procedure Number_Completion;
+ procedure Number_Fraction_Or_Bracket;
+ procedure Number_Fraction_Or_Z_Fill;
+ procedure Zero_Suppression;
+ procedure Floating_Bracket;
+ procedure Number_Fraction_Or_Star_Fill;
+ procedure Star_Suppression;
+ procedure Number_Fraction_Or_Dollar;
+ procedure Leading_Dollar;
+ procedure Number_Fraction_Or_Pound;
+ procedure Leading_Pound;
+ procedure Picture;
+ procedure Floating_Plus;
+ procedure Floating_Minus;
+ procedure Picture_Plus;
+ procedure Picture_Minus;
+ procedure Picture_Bracket;
+ procedure Number;
+ procedure Optional_RHS_Sign;
+ procedure Picture_String;
+
+ ------------
+ -- At_End --
+ ------------
+
+ function At_End return Boolean is
+ begin
+ return Index > Pic.Picture.Length;
+ end At_End;
+
+ ----------------------
+ -- Floating_Bracket --
+ ----------------------
+
+ -- Note that Floating_Bracket is only called with an acceptable
+ -- prefix. But we don't set Okay, because we must end with a '>'.
+
+ procedure Floating_Bracket is
+ begin
+ Pic.Floater := '<';
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+
+ -- First bracket wasn't counted...
+
+ Skip; -- known '<'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+
+ when '$' =>
+ Leading_Dollar;
+
+ when '#' =>
+ Leading_Pound;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Bracket;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Floating_Bracket;
+
+ --------------------
+ -- Floating_Minus --
+ --------------------
+
+ procedure Floating_Minus is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '-' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip; -- Radix
+
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ if At_End then
+ return;
+ end if;
+
+ if Look = '-' then
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '-' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ else
+ Number_Completion;
+ end if;
+
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Floating_Minus;
+
+ -------------------
+ -- Floating_Plus --
+ -------------------
+
+ procedure Floating_Plus is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '+' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip; -- Radix
+
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ if At_End then
+ return;
+ end if;
+
+ if Look = '+' then
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '+' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ else
+ Number_Completion;
+ end if;
+
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Floating_Plus;
+
+ ---------------
+ -- Is_Insert --
+ ---------------
+
+ function Is_Insert return Boolean is
+ begin
+ if At_End then
+ return False;
+ end if;
+
+ case Pic.Picture.Expanded (Index) is
+
+ when '_' | '0' | '/' => return True;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b'; -- canonical
+ return True;
+
+ when others => return False;
+ end case;
+ end Is_Insert;
+
+ --------------------
+ -- Leading_Dollar --
+ --------------------
+
+ -- Note that Leading_Dollar can be called in either State.
+ -- It will set state to Okay only if a 9 or (second) $
+ -- is encountered.
+
+ -- Also notice the tricky bit with State and Zero_Suppression.
+ -- Zero_Suppression is Picture_Error if a '$' or a '9' has been
+ -- encountered, exactly the cases where State has been set.
+
+ procedure Leading_Dollar is
+ begin
+ -- Treat as a floating dollar, and unwind otherwise.
+
+ Pic.Floater := '$';
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- currency place.
+
+ Skip; -- known '$'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ -- A trailing insertion character is not part of the
+ -- floating currency, so need to look ahead.
+
+ if Look /= '$' then
+ Pic.End_Float := Pic.End_Float - 1;
+ end if;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ if State = Okay then
+ raise Picture_Error;
+ else
+ -- Will overwrite Floater and Start_Float
+
+ Zero_Suppression;
+ end if;
+
+ when '*' =>
+ if State = Okay then
+ raise Picture_Error;
+ else
+ -- Will overwrite Floater and Start_Float
+
+ Star_Suppression;
+ end if;
+
+ when '$' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.End_Currency := Index;
+ Set_State (Okay); Skip;
+
+ when '9' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- A single dollar does not a floating make.
+
+ Number_Completion;
+ return;
+
+ when 'V' | 'v' | '.' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Only one dollar before the sign is okay,
+ -- but doesn't float.
+
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Dollar;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Leading_Dollar;
+
+ -------------------
+ -- Leading_Pound --
+ -------------------
+
+ -- This one is complex! A Leading_Pound can be fixed or floating,
+ -- but in some cases the decision has to be deferred until we leave
+ -- this procedure. Also note that Leading_Pound can be called in
+ -- either State.
+
+ -- It will set state to Okay only if a 9 or (second) # is
+ -- encountered.
+
+ -- One Last note: In ambiguous cases, the currency is treated as
+ -- floating unless there is only one '#'.
+
+ procedure Leading_Pound is
+
+ Inserts : Boolean := False;
+ -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
+
+ Must_Float : Boolean := False;
+ -- Set to true if a '#' occurs after an insert.
+
+ begin
+ -- Treat as a floating currency. If it isn't, this will be
+ -- overwritten later.
+
+ Pic.Floater := '#';
+
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- currency place.
+
+ Pic.Max_Currency_Digits := 1; -- we've seen one.
+
+ Skip; -- known '#'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Inserts := True;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Pic.End_Float := Index;
+ Inserts := True;
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ if Must_Float then
+ raise Picture_Error;
+ else
+ Pic.Max_Leading_Digits := 0;
+
+ -- Will overwrite Floater and Start_Float
+
+ Zero_Suppression;
+ end if;
+
+ when '*' =>
+ if Must_Float then
+ raise Picture_Error;
+ else
+ Pic.Max_Leading_Digits := 0;
+
+ -- Will overwrite Floater and Start_Float
+
+ Star_Suppression;
+ end if;
+
+ when '#' =>
+ if Inserts then
+ Must_Float := True;
+ end if;
+
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.End_Currency := Index;
+ Set_State (Okay);
+ Skip;
+
+ when '9' =>
+ if State /= Okay then
+
+ -- A single '#' doesn't float.
+
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Number_Completion;
+ return;
+
+ when 'V' | 'v' | '.' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Only one pound before the sign is okay,
+ -- but doesn't float.
+
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Pound;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Leading_Pound;
+
+ ----------
+ -- Look --
+ ----------
+
+ function Look return Character is
+ begin
+ if At_End then
+ raise Picture_Error;
+ end if;
+
+ return Pic.Picture.Expanded (Index);
+ end Look;
+
+ ------------
+ -- Number --
+ ------------
+
+ procedure Number is
+ begin
+ loop
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+ Skip;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+
+ if At_End then
+ return;
+ end if;
+
+ -- Will return in Okay state if a '9' was seen.
+
+ end loop;
+ end Number;
+
+ -----------------------
+ -- Number_Completion --
+ -----------------------
+
+ procedure Number_Completion is
+ begin
+ while not At_End loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+ Skip;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Number_Completion;
+
+ ---------------------
+ -- Number_Fraction --
+ ---------------------
+
+ procedure Number_Fraction is
+ begin
+ -- Note that number fraction can be called in either State.
+ -- It will set state to Valid only if a 9 is encountered.
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Set_State (Okay); Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Number_Fraction;
+
+ --------------------------------
+ -- Number_Fraction_Or_Bracket --
+ --------------------------------
+
+ procedure Number_Fraction_Or_Bracket is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' => Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Bracket;
+
+ -------------------------------
+ -- Number_Fraction_Or_Dollar --
+ -------------------------------
+
+ procedure Number_Fraction_Or_Dollar is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Dollar;
+
+ ------------------------------
+ -- Number_Fraction_Or_Pound --
+ ------------------------------
+
+ procedure Number_Fraction_Or_Pound is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '#' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '#' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+
+ end case;
+ end loop;
+ end Number_Fraction_Or_Pound;
+
+ ----------------------------------
+ -- Number_Fraction_Or_Star_Fill --
+ ----------------------------------
+
+ procedure Number_Fraction_Or_Star_Fill is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.Star_Fill := True;
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.Star_Fill := True;
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+
+ end case;
+ end loop;
+ end Number_Fraction_Or_Star_Fill;
+
+ -------------------------------
+ -- Number_Fraction_Or_Z_Fill --
+ -------------------------------
+
+ procedure Number_Fraction_Or_Z_Fill is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Z_Fill;
+
+ -----------------------
+ -- Optional_RHS_Sign --
+ -----------------------
+
+ procedure Optional_RHS_Sign is
+ begin
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '+' | '-' =>
+ Pic.Sign_Position := Index;
+ Skip;
+ return;
+
+ when 'C' | 'c' =>
+ Pic.Sign_Position := Index;
+ Pic.Picture.Expanded (Index) := 'C';
+ Skip;
+
+ if Look = 'R' or Look = 'r' then
+ Pic.Second_Sign := Index;
+ Pic.Picture.Expanded (Index) := 'R';
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ return;
+
+ when 'D' | 'd' =>
+ Pic.Sign_Position := Index;
+ Pic.Picture.Expanded (Index) := 'D';
+ Skip;
+
+ if Look = 'B' or Look = 'b' then
+ Pic.Second_Sign := Index;
+ Pic.Picture.Expanded (Index) := 'B';
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ return;
+
+ when '>' =>
+ if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then
+ Pic.Second_Sign := Index;
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ when others =>
+ return;
+
+ end case;
+ end Optional_RHS_Sign;
+
+ -------------
+ -- Picture --
+ -------------
+
+ -- Note that Picture can be called in either State.
+
+ -- It will set state to Valid only if a 9 is encountered or floating
+ -- currency is called.
+
+ procedure Picture is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Leading_Dollar;
+ return;
+
+ when '#' =>
+ Leading_Pound;
+ return;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Set_State (Okay);
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Skip;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ Trailing_Currency;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture;
+
+ ---------------------
+ -- Picture_Bracket --
+ ---------------------
+
+ procedure Picture_Bracket is
+ begin
+ Pic.Sign_Position := Index;
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '<';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Bracket
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Set_State (Okay); -- "<<>" is enough.
+ Floating_Bracket;
+ Trailing_Currency;
+ Trailing_Bracket;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Trailing_Bracket;
+ Set_State (Okay);
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit
+
+ Picture;
+ Trailing_Bracket;
+ return;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+ end loop;
+ end Picture_Bracket;
+
+ -------------------
+ -- Picture_Minus --
+ -------------------
+
+ procedure Picture_Minus is
+ begin
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '-';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Minus
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '-' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+ Set_State (Okay); -- "-- " is enough.
+ Floating_Minus;
+ Trailing_Currency;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Set_State (Okay);
+ return;
+
+ when 'Z' | 'z' =>
+
+ -- Can't have Z and a floating sign.
+
+ if State = Okay then
+ Set_State (Reject);
+ end if;
+
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit.
+
+ Picture;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture_Minus;
+
+ ------------------
+ -- Picture_Plus --
+ ------------------
+
+ procedure Picture_Plus is
+ begin
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '+';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Plus
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '+' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+ Set_State (Okay); -- "++" is enough.
+ Floating_Plus;
+ Trailing_Currency;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Set_State (Okay);
+ return;
+
+ when 'Z' | 'z' =>
+ if State = Okay then
+ Set_State (Reject);
+ end if;
+
+ -- Can't have Z and a floating sign.
+
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ -- '+Z' is acceptable
+
+ Set_State (Okay);
+
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit.
+
+ Picture;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture_Plus;
+
+ --------------------
+ -- Picture_String --
+ --------------------
+
+ procedure Picture_String is
+ begin
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ case Look is
+
+ when '$' | '#' =>
+ Picture;
+ Optional_RHS_Sign;
+
+ when '+' =>
+ Picture_Plus;
+
+ when '-' =>
+ Picture_Minus;
+
+ when '<' =>
+ Picture_Bracket;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when '*' =>
+ Star_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when '9' | '.' | 'V' | 'v' =>
+ Number;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+
+ -- Blank when zero either if the PIC does not contain a '9' or if
+ -- requested by the user and no '*'
+
+ Pic.Blank_When_Zero :=
+ (Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill;
+
+ -- Star fill if '*' and no '9'.
+
+ Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ;
+
+ if not At_End then
+ Set_State (Reject);
+ end if;
+
+ end Picture_String;
+
+ ---------------
+ -- Set_State --
+ ---------------
+
+ procedure Set_State (L : Legality) is
+ begin
+ State := L;
+ end Set_State;
+
+ ----------
+ -- Skip --
+ ----------
+
+ procedure Skip is
+ begin
+ Index := Index + 1;
+ end Skip;
+
+ ----------------------
+ -- Star_Suppression --
+ ----------------------
+
+ procedure Star_Suppression is
+ begin
+ Pic.Floater := '*';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+
+ -- Even a single * is a valid picture
+
+ Pic.Star_Fill := True;
+ Skip; -- Known *
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay); Skip;
+
+ when '9' =>
+ Set_State (Okay);
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Star_Fill;
+ return;
+
+ when '#' | '$' =>
+ Trailing_Currency;
+ Set_State (Okay);
+ return;
+
+ when others => raise Picture_Error;
+ end case;
+ end loop;
+ end Star_Suppression;
+
+ ----------------------
+ -- Trailing_Bracket --
+ ----------------------
+
+ procedure Trailing_Bracket is
+ begin
+ if Look = '>' then
+ Pic.Second_Sign := Index;
+ Skip;
+ else
+ raise Picture_Error;
+ end if;
+ end Trailing_Bracket;
+
+ -----------------------
+ -- Trailing_Currency --
+ -----------------------
+
+ procedure Trailing_Currency is
+ begin
+ if At_End then
+ return;
+ end if;
+
+ if Look = '$' then
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Skip;
+
+ else
+ while not At_End and then Look = '#' loop
+ if Pic.Start_Currency = Invalid_Position then
+ Pic.Start_Currency := Index;
+ end if;
+
+ Pic.End_Currency := Index;
+ Skip;
+ end loop;
+ end if;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' => Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others => return;
+ end case;
+ end loop;
+ end Trailing_Currency;
+
+ ----------------------
+ -- Zero_Suppression --
+ ----------------------
+
+ procedure Zero_Suppression is
+ begin
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Skip; -- Known Z
+
+ loop
+ -- Even a single Z is a valid picture
+
+ if At_End then
+ Set_State (Okay);
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Set_State (Okay);
+ Skip;
+
+ when '9' =>
+ Set_State (Okay);
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Z_Fill;
+ return;
+
+ when '#' | '$' =>
+ Trailing_Currency;
+ Set_State (Okay);
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Zero_Suppression;
+
+ -- Start of processing for Precalculate
+
+ begin
+ Picture_String;
+
+ if State = Reject then
+ raise Picture_Error;
+ end if;
+
+ exception
+
+ when Constraint_Error =>
+
+ -- To deal with special cases like null strings.
+
+ raise Picture_Error;
+
+ end Precalculate;
+
+ ----------------
+ -- To_Picture --
+ ----------------
+
+ function To_Picture
+ (Pic_String : String;
+ Blank_When_Zero : Boolean := False) return Picture
+ is
+ Result : Picture;
+
+ begin
+ declare
+ Item : constant String := Expand (Pic_String);
+
+ begin
+ Result.Contents.Picture := (Item'Length, Item);
+ Result.Contents.Original_BWZ := Blank_When_Zero;
+ Result.Contents.Blank_When_Zero := Blank_When_Zero;
+ Precalculate (Result.Contents);
+ return Result;
+ end;
+
+ exception
+ when others =>
+ raise Picture_Error;
+
+ end To_Picture;
+
+ -------------
+ -- To_Wide --
+ -------------
+
+ function To_Wide (C : Character) return Wide_Wide_Character is
+ begin
+ return Wide_Wide_Character'Val (Character'Pos (C));
+ end To_Wide;
+
+ -----------
+ -- Valid --
+ -----------
+
+ function Valid
+ (Pic_String : String;
+ Blank_When_Zero : Boolean := False) return Boolean
+ is
+ begin
+ declare
+ Expanded_Pic : constant String := Expand (Pic_String);
+ -- Raises Picture_Error if Item not well-formed
+
+ Format_Rec : Format_Record;
+
+ begin
+ Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
+ Format_Rec.Blank_When_Zero := Blank_When_Zero;
+ Format_Rec.Original_BWZ := Blank_When_Zero;
+ Precalculate (Format_Rec);
+
+ -- False only if Blank_When_0 is True but the pic string
+ -- has a '*'
+
+ return not Blank_When_Zero or
+ Strings_Fixed.Index (Expanded_Pic, "*") = 0;
+ end;
+
+ exception
+ when others => return False;
+ end Valid;
+
+end Ada.Wide_Wide_Text_IO.Editing;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Wide_Wide_Text_IO.Editing is
+
+ type Picture is private;
+
+ function Valid
+ (Pic_String : String;
+ Blank_When_Zero : Boolean := False) return Boolean;
+
+ function To_Picture
+ (Pic_String : String;
+ Blank_When_Zero : Boolean := False) return Picture;
+
+ function Pic_String (Pic : in Picture) return String;
+ function Blank_When_Zero (Pic : in Picture) return Boolean;
+
+ Max_Picture_Length : constant := 64;
+
+ Picture_Error : exception;
+
+ Default_Currency : constant Wide_Wide_String := "$";
+ Default_Fill : constant Wide_Wide_Character := ' ';
+ Default_Separator : constant Wide_Wide_Character := ',';
+ Default_Radix_Mark : constant Wide_Wide_Character := '.';
+
+ generic
+ type Num is delta <> digits <>;
+ Default_Currency : Wide_Wide_String :=
+ Wide_Wide_Text_IO.Editing.Default_Currency;
+ Default_Fill : Wide_Wide_Character :=
+ Wide_Wide_Text_IO.Editing.Default_Fill;
+ Default_Separator : Wide_Wide_Character :=
+ Wide_Wide_Text_IO.Editing.Default_Separator;
+ Default_Radix_Mark : Wide_Wide_Character :=
+ Wide_Wide_Text_IO.Editing.Default_Radix_Mark;
+
+ package Decimal_Output is
+
+ function Length
+ (Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency) return Natural;
+
+ function Valid
+ (Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency) return Boolean;
+
+ function Image
+ (Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency;
+ Fill : Wide_Wide_Character := Default_Fill;
+ Separator : Wide_Wide_Character := Default_Separator;
+ Radix_Mark : Wide_Wide_Character := Default_Radix_Mark)
+ return Wide_Wide_String;
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency;
+ Fill : Wide_Wide_Character := Default_Fill;
+ Separator : Wide_Wide_Character := Default_Separator;
+ Radix_Mark : Wide_Wide_Character := Default_Radix_Mark);
+
+ procedure Put
+ (Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency;
+ Fill : Wide_Wide_Character := Default_Fill;
+ Separator : Wide_Wide_Character := Default_Separator;
+ Radix_Mark : Wide_Wide_Character := Default_Radix_Mark);
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Pic : Picture;
+ Currency : Wide_Wide_String := Default_Currency;
+ Fill : Wide_Wide_Character := Default_Fill;
+ Separator : Wide_Wide_Character := Default_Separator;
+ Radix_Mark : Wide_Wide_Character := Default_Radix_Mark);
+
+ end Decimal_Output;
+
+private
+ MAX_PICSIZE : constant := 50;
+ MAX_MONEYSIZE : constant := 10;
+ Invalid_Position : constant := -1;
+
+ subtype Pic_Index is Natural range 0 .. MAX_PICSIZE;
+
+ type Picture_Record (Length : Pic_Index := 0) is record
+ Expanded : String (1 .. Length);
+ end record;
+
+ type Format_Record is record
+ Picture : Picture_Record;
+ -- Read only
+
+ Blank_When_Zero : Boolean;
+ -- Read/write
+
+ Original_BWZ : Boolean;
+
+ -- The following components get written
+
+ Star_Fill : Boolean := False;
+
+ Radix_Position : Integer := Invalid_Position;
+
+ Sign_Position,
+ Second_Sign : Integer := Invalid_Position;
+
+ Start_Float,
+ End_Float : Integer := Invalid_Position;
+
+ Start_Currency,
+ End_Currency : Integer := Invalid_Position;
+
+ Max_Leading_Digits : Integer := 0;
+
+ Max_Trailing_Digits : Integer := 0;
+
+ Max_Currency_Digits : Integer := 0;
+
+ Floater : Wide_Wide_Character := '!';
+ -- Initialized to illegal value
+
+ end record;
+
+ type Picture is record
+ Contents : Format_Record;
+ end record;
+
+ type Number_Attributes is record
+ Negative : Boolean := False;
+
+ Has_Fraction : Boolean := False;
+
+ Start_Of_Int,
+ End_Of_Int,
+ Start_Of_Fraction,
+ End_Of_Fraction : Integer := Invalid_Position; -- invalid value
+ end record;
+
+ function Parse_Number_String (Str : String) return Number_Attributes;
+ -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no
+ -- trailing blanks...)
+
+ procedure Precalculate (Pic : in out Format_Record);
+ -- Precalculates fields from the user supplied data
+
+ function Format_Number
+ (Pic : Format_Record;
+ Number : String;
+ Currency_Symbol : Wide_Wide_String;
+ Fill_Character : Wide_Wide_Character;
+ Separator_Character : Wide_Wide_Character;
+ Radix_Point : Wide_Wide_Character) return Wide_Wide_String;
+ -- Formats number according to Pic
+
+ function Expand (Picture : in String) return String;
+
+end Ada.Wide_Wide_Text_IO.Editing;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X--
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.WCh_Con; use System.WCh_Con;
+
+package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Store_Char
+ (WC : Wide_Wide_Character;
+ Buf : out Wide_Wide_String;
+ Ptr : in out Integer);
+ -- Store a single character in buffer, checking for overflow.
+
+ -- These definitions replace the ones in Ada.Characters.Handling, which
+ -- do not seem to work for some strange not understood reason ??? at
+ -- least in the OS/2 version.
+
+ function To_Lower (C : Character) return Character;
+
+ ------------------
+ -- Get_Enum_Lit --
+ ------------------
+
+ procedure Get_Enum_Lit
+ (File : File_Type;
+ Buf : out Wide_Wide_String;
+ Buflen : out Natural)
+ is
+ ch : int;
+ WC : Wide_Wide_Character;
+
+ begin
+ Buflen := 0;
+ Load_Skip (TFT (File));
+ ch := Nextc (TFT (File));
+
+ -- Character literal case. If the initial character is a quote, then
+ -- we read as far as we can without backup (see ACVC test CE3905L)
+
+ if ch = Character'Pos (''') then
+ Get (File, WC);
+ Store_Char (WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ if ch = LM or else ch = EOF then
+ return;
+ end if;
+
+ Get (File, WC);
+ Store_Char (WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ if ch /= Character'Pos (''') then
+ return;
+ end if;
+
+ Get (File, WC);
+ Store_Char (WC, Buf, Buflen);
+
+ -- Similarly for identifiers, read as far as we can, in particular,
+ -- do read a trailing underscore (again see ACVC test CE3905L to
+ -- understand why we do this, although it seems somewhat peculiar).
+
+ else
+ -- Identifier must start with a letter. Any wide character value
+ -- outside the normal Latin-1 range counts as a letter for this.
+
+ if ch < 255 and then not Is_Letter (Character'Val (ch)) then
+ return;
+ end if;
+
+ -- If we do have a letter, loop through the characters quitting on
+ -- the first non-identifier character (note that this includes the
+ -- cases of hitting a line mark or page mark).
+
+ loop
+ Get (File, WC);
+ Store_Char (WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ exit when ch = EOF;
+
+ if ch = Character'Pos ('_') then
+ exit when Buf (Buflen) = '_';
+
+ elsif ch = Character'Pos (ASCII.ESC) then
+ null;
+
+ elsif File.WC_Method in WC_Upper_Half_Encoding_Method
+ and then ch > 127
+ then
+ null;
+
+ else
+ exit when not Is_Letter (Character'Val (ch))
+ and then
+ not Is_Digit (Character'Val (ch));
+ end if;
+ end loop;
+ end if;
+ end Get_Enum_Lit;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Wide_Wide_String;
+ Width : Field;
+ Set : Type_Set)
+ is
+ Actual_Width : constant Integer :=
+ Integer'Max (Integer (Width), Item'Length);
+
+ begin
+ Check_On_One_Line (TFT (File), Actual_Width);
+
+ if Set = Lower_Case and then Item (1) /= ''' then
+ declare
+ Iteml : Wide_Wide_String (Item'First .. Item'Last);
+
+ begin
+ for J in Item'Range loop
+ if Is_Character (Item (J)) then
+ Iteml (J) :=
+ To_Wide_Wide_Character
+ (To_Lower (To_Character (Item (J))));
+ else
+ Iteml (J) := Item (J);
+ end if;
+ end loop;
+
+ Put (File, Iteml);
+ end;
+
+ else
+ Put (File, Item);
+ end if;
+
+ for J in 1 .. Actual_Width - Item'Length loop
+ Put (File, ' ');
+ end loop;
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out Wide_Wide_String;
+ Item : Wide_Wide_String;
+ Set : Type_Set)
+ is
+ Ptr : Natural;
+
+ begin
+ if Item'Length > To'Length then
+ raise Layout_Error;
+
+ else
+ Ptr := To'First;
+ for J in Item'Range loop
+ if Set = Lower_Case
+ and then Item (1) /= '''
+ and then Is_Character (Item (J))
+ then
+ To (Ptr) :=
+ To_Wide_Wide_Character (To_Lower (To_Character (Item (J))));
+ else
+ To (Ptr) := Item (J);
+ end if;
+
+ Ptr := Ptr + 1;
+ end loop;
+
+ while Ptr <= To'Last loop
+ To (Ptr) := ' ';
+ Ptr := Ptr + 1;
+ end loop;
+ end if;
+ end Puts;
+
+ -------------------
+ -- Scan_Enum_Lit --
+ -------------------
+
+ procedure Scan_Enum_Lit
+ (From : Wide_Wide_String;
+ Start : out Natural;
+ Stop : out Natural)
+ is
+ WC : Wide_Wide_Character;
+
+ -- Processing for Scan_Enum_Lit
+
+ begin
+ Start := From'First;
+
+ loop
+ if Start > From'Last then
+ raise End_Error;
+
+ elsif Is_Character (From (Start))
+ and then not Is_Blank (To_Character (From (Start)))
+ then
+ exit;
+
+ else
+ Start := Start + 1;
+ end if;
+ end loop;
+
+ -- Character literal case. If the initial character is a quote, then
+ -- we read as far as we can without backup (see ACVC test CE3905L
+ -- which is for the analogous case for reading from a file).
+
+ if From (Start) = ''' then
+ Stop := Start;
+
+ if Stop = From'Last then
+ raise Data_Error;
+ else
+ Stop := Stop + 1;
+ end if;
+
+ if From (Stop) in ' ' .. '~'
+ or else From (Stop) >= Wide_Wide_Character'Val (16#80#)
+ then
+ if Stop = From'Last then
+ raise Data_Error;
+ else
+ Stop := Stop + 1;
+
+ if From (Stop) = ''' then
+ return;
+ end if;
+ end if;
+ end if;
+
+ raise Data_Error;
+
+ -- Similarly for identifiers, read as far as we can, in particular,
+ -- do read a trailing underscore (again see ACVC test CE3905L to
+ -- understand why we do this, although it seems somewhat peculiar).
+
+ else
+ -- Identifier must start with a letter, any wide character outside
+ -- the normal Latin-1 range is considered a letter for this test.
+
+ if Is_Character (From (Start))
+ and then not Is_Letter (To_Character (From (Start)))
+ then
+ raise Data_Error;
+ end if;
+
+ -- If we do have a letter, loop through the characters quitting on
+ -- the first non-identifier character (note that this includes the
+ -- cases of hitting a line mark or page mark).
+
+ Stop := Start + 1;
+ while Stop < From'Last loop
+ WC := From (Stop + 1);
+
+ exit when
+ Is_Character (WC)
+ and then
+ not Is_Letter (To_Character (WC))
+ and then
+ not Is_Letter (To_Character (WC))
+ and then
+ (WC /= '_' or else From (Stop - 1) = '_');
+
+ Stop := Stop + 1;
+ end loop;
+ end if;
+
+ end Scan_Enum_Lit;
+
+ ----------------
+ -- Store_Char --
+ ----------------
+
+ procedure Store_Char
+ (WC : Wide_Wide_Character;
+ Buf : out Wide_Wide_String;
+ Ptr : in out Integer)
+ is
+ begin
+ if Ptr = Buf'Last then
+ raise Data_Error;
+ else
+ Ptr := Ptr + 1;
+ Buf (Ptr) := WC;
+ end if;
+ end Store_Char;
+
+ --------------
+ -- To_Lower --
+ --------------
+
+ function To_Lower (C : Character) return Character is
+ begin
+ if C in 'A' .. 'Z' then
+ return Character'Val (Character'Pos (C) + 32);
+ else
+ return C;
+ end if;
+ end To_Lower;
+
+end Ada.Wide_Wide_Text_IO.Enumeration_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X--
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Wide_Text_IO.Enumeration_IO
+-- that are shared among separate instantiations.
+
+private package Ada.Wide_Wide_Text_IO.Enumeration_Aux is
+
+ procedure Get_Enum_Lit
+ (File : File_Type;
+ Buf : out Wide_Wide_String;
+ Buflen : out Natural);
+ -- Reads an enumeration literal value from the file, folds to upper case,
+ -- and stores the result in Buf, setting Buflen to the number of stored
+ -- characters (Buf has a lower bound of 1). If more than Buflen characters
+ -- are present in the literal, Data_Error is raised.
+
+ procedure Scan_Enum_Lit
+ (From : Wide_Wide_String;
+ Start : out Natural;
+ Stop : out Natural);
+ -- Scans an enumeration literal at the start of From, skipping any leading
+ -- spaces. Sets Start to the first character, Stop to the last character.
+ -- Raises End_Error if no enumeration literal is found.
+
+ procedure Put
+ (File : File_Type;
+ Item : Wide_Wide_String;
+ Width : Field;
+ Set : Type_Set);
+ -- Outputs the enumeration literal image stored in Item to the given File,
+ -- using the given Width and Set parameters (Item is always in upper case).
+
+ procedure Puts
+ (To : out Wide_Wide_String;
+ Item : Wide_Wide_String;
+ Set : Type_Set);
+ -- Stores the enumeration literal image stored in Item to the string To,
+ -- padding with trailing spaces if necessary to fill To. Set is used to
+
+end Ada.Wide_Wide_Text_IO.Enumeration_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Enumeration_Aux;
+
+package body Ada.Wide_Wide_Text_IO.Enumeration_IO is
+
+ package Aux renames Ada.Wide_Wide_Text_IO.Enumeration_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get (File : File_Type; Item : out Enum) is
+ Buf : Wide_Wide_String (1 .. Enum'Width);
+ Buflen : Natural;
+
+ begin
+ Aux.Get_Enum_Lit (File, Buf, Buflen);
+ Item := Enum'Wide_Wide_Value (Buf (1 .. Buflen));
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get (Item : out Enum) is
+ begin
+ Get (Current_Input, Item);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Enum;
+ Last : out Positive)
+ is
+ Start : Natural;
+
+ begin
+ Aux.Scan_Enum_Lit (From, Start, Last);
+ Item := Enum'Wide_Wide_Value (From (Start .. Last));
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Enum;
+ Width : Field := Default_Width;
+ Set : Type_Set := Default_Setting)
+ is
+ Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item);
+
+ begin
+ Aux.Put (File, Image, Width, Set);
+ end Put;
+
+ procedure Put
+ (Item : Enum;
+ Width : Field := Default_Width;
+ Set : Type_Set := Default_Setting)
+ is
+ begin
+ Put (Current_Output, Item, Width, Set);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Enum;
+ Set : Type_Set := Default_Setting)
+ is
+ Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item);
+
+ begin
+ Aux.Puts (To, Image, Set);
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Enumeration_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Enumeration_IO is a
+-- subpackage of Wide_Wide_Text_IO. In GNAT we make it a child package to
+-- avoid loading the necessary code if Enumeration_IO is not instantiated.
+-- See the routine Rtsfind.Text_IO_Kludge for a description of how we patch
+-- up the difference in semantics so that it is invisible to the Ada
+-- programmer.
+
+private generic
+ type Enum is (<>);
+
+package Ada.Wide_Wide_Text_IO.Enumeration_IO is
+
+ Default_Width : Field := 0;
+ Default_Setting : Type_Set := Upper_Case;
+
+ procedure Get (File : File_Type; Item : out Enum);
+ procedure Get (Item : out Enum);
+
+ procedure Put
+ (File : File_Type;
+ Item : Enum;
+ Width : Field := Default_Width;
+ Set : Type_Set := Default_Setting);
+
+ procedure Put
+ (Item : Enum;
+ Width : Field := Default_Width;
+ Set : Type_Set := Default_Setting);
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Enum;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Enum;
+ Set : Type_Set := Default_Setting);
+
+end Ada.Wide_Wide_Text_IO.Enumeration_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Streams; use Ada.Streams;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+
+with System;
+with System.CRTL;
+with System.File_IO;
+with System.WCh_Cnv; use System.WCh_Cnv;
+with System.WCh_Con; use System.WCh_Con;
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+pragma Elaborate_All (System.File_IO);
+-- Needed because of calls to Chain_File in package body elaboration
+
+package body Ada.Wide_Wide_Text_IO is
+
+ package FIO renames System.File_IO;
+
+ subtype AP is FCB.AFCB_Ptr;
+
+ function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
+ function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
+ use type FCB.File_Mode;
+
+ use type System.CRTL.size_t;
+
+ WC_Encoding : Character;
+ pragma Import (C, WC_Encoding, "__gl_wc_encoding");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Getc_Immed (File : File_Type) return int;
+ -- This routine is identical to Getc, except that the read is done in
+ -- Get_Immediate mode (i.e. without waiting for a line return).
+
+ function Get_Wide_Wide_Char_Immed
+ (C : Character;
+ File : File_Type) return Wide_Wide_Character;
+ -- This routine is identical to Get_Wide_Wide_Char, except that the reads
+ -- are done in Get_Immediate mode (i.e. without waiting for a line return).
+
+ procedure Set_WCEM (File : in out File_Type);
+ -- Called by Open and Create to set the wide character encoding method
+ -- for the file, processing a WCEM form parameter if one is present.
+ -- File is IN OUT because it may be closed in case of an error.
+
+ -------------------
+ -- AFCB_Allocate --
+ -------------------
+
+ function AFCB_Allocate
+ (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr
+ is
+ pragma Unreferenced (Control_Block);
+ begin
+ return new Wide_Wide_Text_AFCB;
+ end AFCB_Allocate;
+
+ ----------------
+ -- AFCB_Close --
+ ----------------
+
+ procedure AFCB_Close (File : access Wide_Wide_Text_AFCB) is
+ begin
+ -- If the file being closed is one of the current files, then close
+ -- the corresponding current file. It is not clear that this action
+ -- is required (RM A.10.3(23)) but it seems reasonable, and besides
+ -- ACVC test CE3208A expects this behavior.
+
+ if File_Type (File) = Current_In then
+ Current_In := null;
+ elsif File_Type (File) = Current_Out then
+ Current_Out := null;
+ elsif File_Type (File) = Current_Err then
+ Current_Err := null;
+ end if;
+
+ Terminate_Line (File_Type (File));
+ end AFCB_Close;
+
+ ---------------
+ -- AFCB_Free --
+ ---------------
+
+ procedure AFCB_Free (File : access Wide_Wide_Text_AFCB) is
+ type FCB_Ptr is access all Wide_Wide_Text_AFCB;
+ FT : FCB_Ptr := FCB_Ptr (File);
+
+ procedure Free is new
+ Unchecked_Deallocation (Wide_Wide_Text_AFCB, FCB_Ptr);
+
+ begin
+ Free (FT);
+ end AFCB_Free;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out File_Type) is
+ begin
+ FIO.Close (AP (File));
+ end Close;
+
+ ---------
+ -- Col --
+ ---------
+
+ -- Note: we assume that it is impossible in practice for the column
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Col (File : File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Col;
+ end Col;
+
+ function Col return Positive_Count is
+ begin
+ return Col (Current_Out);
+ end Col;
+
+ ------------
+ -- Create --
+ ------------
+
+ procedure Create
+ (File : in out File_Type;
+ Mode : File_Mode := Out_File;
+ Name : String := "";
+ Form : String := "")
+ is
+ Dummy_File_Control_Block : Wide_Wide_Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => Dummy_File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'W',
+ Creat => True,
+ Text => True);
+ Set_WCEM (File);
+ end Create;
+
+ -------------------
+ -- Current_Error --
+ -------------------
+
+ function Current_Error return File_Type is
+ begin
+ return Current_Err;
+ end Current_Error;
+
+ function Current_Error return File_Access is
+ begin
+ return Current_Err'Access;
+ end Current_Error;
+
+ -------------------
+ -- Current_Input --
+ -------------------
+
+ function Current_Input return File_Type is
+ begin
+ return Current_In;
+ end Current_Input;
+
+ function Current_Input return File_Access is
+ begin
+ return Current_In'Access;
+ end Current_Input;
+
+ --------------------
+ -- Current_Output --
+ --------------------
+
+ function Current_Output return File_Type is
+ begin
+ return Current_Out;
+ end Current_Output;
+
+ function Current_Output return File_Access is
+ begin
+ return Current_Out'Access;
+ end Current_Output;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (File : in out File_Type) is
+ begin
+ FIO.Delete (AP (File));
+ end Delete;
+
+ -----------------
+ -- End_Of_File --
+ -----------------
+
+ function End_Of_File (File : File_Type) return Boolean is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_Wide_Wide_Character then
+ return False;
+
+ elsif File.Before_LM then
+
+ if File.Before_LM_PM then
+ return Nextc (File) = EOF;
+ end if;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch /= LM then
+ Ungetc (ch, File);
+ return False;
+
+ else -- ch = LM
+ File.Before_LM := True;
+ end if;
+ end if;
+
+ -- Here we are just past the line mark with Before_LM set so that we
+ -- do not have to try to back up past the LM, thus avoiding the need
+ -- to back up more than one character.
+
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Before_LM_PM := True;
+ return Nextc (File) = EOF;
+
+ -- Here if neither EOF nor PM followed end of line
+
+ else
+ Ungetc (ch, File);
+ return False;
+ end if;
+
+ end End_Of_File;
+
+ function End_Of_File return Boolean is
+ begin
+ return End_Of_File (Current_In);
+ end End_Of_File;
+
+ -----------------
+ -- End_Of_Line --
+ -----------------
+
+ function End_Of_Line (File : File_Type) return Boolean is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_Wide_Wide_Character then
+ return False;
+
+ elsif File.Before_LM then
+ return True;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ else
+ Ungetc (ch, File);
+ return (ch = LM);
+ end if;
+ end if;
+ end End_Of_Line;
+
+ function End_Of_Line return Boolean is
+ begin
+ return End_Of_Line (Current_In);
+ end End_Of_Line;
+
+ -----------------
+ -- End_Of_Page --
+ -----------------
+
+ function End_Of_Page (File : File_Type) return Boolean is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if not File.Is_Regular_File then
+ return False;
+
+ elsif File.Before_Wide_Wide_Character then
+ return False;
+
+ elsif File.Before_LM then
+ if File.Before_LM_PM then
+ return True;
+ end if;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch /= LM then
+ Ungetc (ch, File);
+ return False;
+
+ else -- ch = LM
+ File.Before_LM := True;
+ end if;
+ end if;
+
+ -- Here we are just past the line mark with Before_LM set so that we
+ -- do not have to try to back up past the LM, thus avoiding the need
+ -- to back up more than one character.
+
+ ch := Nextc (File);
+
+ return ch = PM or else ch = EOF;
+ end End_Of_Page;
+
+ function End_Of_Page return Boolean is
+ begin
+ return End_Of_Page (Current_In);
+ end End_Of_Page;
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush (File : File_Type) is
+ begin
+ FIO.Flush (AP (File));
+ end Flush;
+
+ procedure Flush is
+ begin
+ Flush (Current_Out);
+ end Flush;
+
+ ----------
+ -- Form --
+ ----------
+
+ function Form (File : File_Type) return String is
+ begin
+ return FIO.Form (AP (File));
+ end Form;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Wide_Wide_Character)
+ is
+ C : Character;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_Wide_Wide_Character then
+ File.Before_Wide_Wide_Character := False;
+ Item := File.Saved_Wide_Wide_Character;
+
+ else
+ Get_Character (File, C);
+ Item := Get_Wide_Wide_Char (C, File);
+ end if;
+ end Get;
+
+ procedure Get (Item : out Wide_Wide_Character) is
+ begin
+ Get (Current_In, Item);
+ end Get;
+
+ procedure Get
+ (File : File_Type;
+ Item : out Wide_Wide_String)
+ is
+ begin
+ for J in Item'Range loop
+ Get (File, Item (J));
+ end loop;
+ end Get;
+
+ procedure Get (Item : out Wide_Wide_String) is
+ begin
+ Get (Current_In, Item);
+ end Get;
+
+ -------------------
+ -- Get_Character --
+ -------------------
+
+ procedure Get_Character
+ (File : File_Type;
+ Item : out Character)
+ is
+ ch : int;
+
+ begin
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ File.Col := 1;
+
+ if File.Before_LM_PM then
+ File.Line := 1;
+ File.Page := File.Page + 1;
+ File.Before_LM_PM := False;
+
+ else
+ File.Line := File.Line + 1;
+ end if;
+ end if;
+
+ loop
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+
+ elsif ch = LM then
+ File.Line := File.Line + 1;
+ File.Col := 1;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+
+ else
+ Item := Character'Val (ch);
+ File.Col := File.Col + 1;
+ return;
+ end if;
+ end loop;
+ end Get_Character;
+
+ -------------------
+ -- Get_Immediate --
+ -------------------
+
+ procedure Get_Immediate
+ (File : File_Type;
+ Item : out Wide_Wide_Character)
+ is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_Wide_Wide_Character then
+ File.Before_Wide_Wide_Character := False;
+ Item := File.Saved_Wide_Wide_Character;
+
+ elsif File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ Item := Wide_Wide_Character'Val (LM);
+
+ else
+ ch := Getc_Immed (File);
+
+ if ch = EOF then
+ raise End_Error;
+ else
+ Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File);
+ end if;
+ end if;
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (Item : out Wide_Wide_Character)
+ is
+ begin
+ Get_Immediate (Current_In, Item);
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (File : File_Type;
+ Item : out Wide_Wide_Character;
+ Available : out Boolean)
+ is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+ Available := True;
+
+ if File.Before_Wide_Wide_Character then
+ File.Before_Wide_Wide_Character := False;
+ Item := File.Saved_Wide_Wide_Character;
+
+ elsif File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ Item := Wide_Wide_Character'Val (LM);
+
+ else
+ ch := Getc_Immed (File);
+
+ if ch = EOF then
+ raise End_Error;
+ else
+ Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File);
+ end if;
+ end if;
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (Item : out Wide_Wide_Character;
+ Available : out Boolean)
+ is
+ begin
+ Get_Immediate (Current_In, Item, Available);
+ end Get_Immediate;
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ procedure Get_Line
+ (File : File_Type;
+ Item : out Wide_Wide_String;
+ Last : out Natural)
+ is
+ begin
+ FIO.Check_Read_Status (AP (File));
+ Last := Item'First - 1;
+
+ -- Immediate exit for null string, this is a case in which we do not
+ -- need to test for end of file and we do not skip a line mark under
+ -- any circumstances.
+
+ if Last >= Item'Last then
+ return;
+ end if;
+
+ -- Here we have at least one character, if we are immediately before
+ -- a line mark, then we will just skip past it storing no characters.
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+
+ -- Otherwise we need to read some characters
+
+ else
+ -- If we are at the end of file now, it means we are trying to
+ -- skip a file terminator and we raise End_Error (RM A.10.7(20))
+
+ if Nextc (File) = EOF then
+ raise End_Error;
+ end if;
+
+ -- Loop through characters in string
+
+ loop
+ -- Exit the loop if read is terminated by encountering line mark
+ -- Note that the use of Skip_Line here ensures we properly deal
+ -- with setting the page and line numbers.
+
+ if End_Of_Line (File) then
+ Skip_Line (File);
+ return;
+ end if;
+
+ -- Otherwise store the character, note that we know that ch is
+ -- something other than LM or EOF. It could possibly be a page
+ -- mark if there is a stray page mark in the middle of a line,
+ -- but this is not an official page mark in any case, since
+ -- official page marks can only follow a line mark. The whole
+ -- page business is pretty much nonsense anyway, so we do not
+ -- want to waste time trying to make sense out of non-standard
+ -- page marks in the file! This means that the behavior of
+ -- Get_Line is different from repeated Get of a character, but
+ -- that's too bad. We only promise that page numbers etc make
+ -- sense if the file is formatted in a standard manner.
+
+ -- Note: we do not adjust the column number because it is quicker
+ -- to adjust it once at the end of the operation than incrementing
+ -- it each time around the loop.
+
+ Last := Last + 1;
+ Get (File, Item (Last));
+
+ -- All done if the string is full, this is the case in which
+ -- we do not skip the following line mark. We need to adjust
+ -- the column number in this case.
+
+ if Last = Item'Last then
+ File.Col := File.Col + Count (Item'Length);
+ return;
+ end if;
+
+ -- Exit from the loop if we are at the end of file. This happens
+ -- if we have a last line that is not terminated with a line mark.
+ -- In this case we consider that there is an implied line mark;
+ -- this is a non-standard file, but we will treat it nicely.
+
+ exit when Nextc (File) = EOF;
+ end loop;
+ end if;
+ end Get_Line;
+
+ procedure Get_Line
+ (Item : out Wide_Wide_String;
+ Last : out Natural)
+ is
+ begin
+ Get_Line (Current_In, Item, Last);
+ end Get_Line;
+
+ function Get_Line (File : File_Type) return Wide_Wide_String is
+ Buffer : Wide_Wide_String (1 .. 500);
+ Last : Natural;
+
+ function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String;
+ -- This is a recursive function that reads the rest of the line and
+ -- returns it. S is the part read so far.
+
+ --------------
+ -- Get_Rest --
+ --------------
+
+ function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String is
+
+ -- Each time we allocate a buffer the same size as what we have
+ -- read so far. This limits us to a logarithmic number of calls
+ -- to Get_Rest and also ensures only a linear use of stack space.
+
+ Buffer : Wide_Wide_String (1 .. S'Length);
+ Last : Natural;
+
+ begin
+ Get_Line (File, Buffer, Last);
+
+ declare
+ R : constant Wide_Wide_String := S & Buffer (1 .. Last);
+ begin
+ if Last < Buffer'Last then
+ return R;
+ else
+ return Get_Rest (R);
+ end if;
+ end;
+ end Get_Rest;
+
+ -- Start of processing for Get_Line
+
+ begin
+ Get_Line (File, Buffer, Last);
+
+ if Last < Buffer'Last then
+ return Buffer (1 .. Last);
+ else
+ return Get_Rest (Buffer (1 .. Last));
+ end if;
+ end Get_Line;
+
+ function Get_Line return Wide_Wide_String is
+ begin
+ return Get_Line (Current_In);
+ end Get_Line;
+
+ ------------------------
+ -- Get_Wide_Wide_Char --
+ ------------------------
+
+ function Get_Wide_Wide_Char
+ (C : Character;
+ File : File_Type) return Wide_Wide_Character
+ is
+ function In_Char return Character;
+ -- Function used to obtain additional characters it the wide character
+ -- sequence is more than one character long.
+
+ function WC_In is new Char_Sequence_To_UTF_32 (In_Char);
+
+ -------------
+ -- In_Char --
+ -------------
+
+ function In_Char return Character is
+ ch : constant Integer := Getc (File);
+ begin
+ if ch = EOF then
+ raise End_Error;
+ else
+ return Character'Val (ch);
+ end if;
+ end In_Char;
+
+ -- Start of processing for Get_Wide_Wide_Char
+
+ begin
+ return Wide_Wide_Character'Val (WC_In (C, File.WC_Method));
+ end Get_Wide_Wide_Char;
+
+ ------------------------------
+ -- Get_Wide_Wide_Char_Immed --
+ ------------------------------
+
+ function Get_Wide_Wide_Char_Immed
+ (C : Character;
+ File : File_Type) return Wide_Wide_Character
+ is
+ function In_Char return Character;
+ -- Function used to obtain additional characters it the wide character
+ -- sequence is more than one character long.
+
+ function WC_In is new Char_Sequence_To_UTF_32 (In_Char);
+
+ -------------
+ -- In_Char --
+ -------------
+
+ function In_Char return Character is
+ ch : constant Integer := Getc_Immed (File);
+ begin
+ if ch = EOF then
+ raise End_Error;
+ else
+ return Character'Val (ch);
+ end if;
+ end In_Char;
+
+ -- Start of processing for Get_Wide_Wide_Char_Immed
+
+ begin
+ return Wide_Wide_Character'Val (WC_In (C, File.WC_Method));
+ end Get_Wide_Wide_Char_Immed;
+
+ ----------
+ -- Getc --
+ ----------
+
+ function Getc (File : File_Type) return int is
+ ch : int;
+
+ begin
+ ch := fgetc (File.Stream);
+
+ if ch = EOF and then ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ else
+ return ch;
+ end if;
+ end Getc;
+
+ ----------------
+ -- Getc_Immed --
+ ----------------
+
+ function Getc_Immed (File : File_Type) return int is
+ ch : int;
+ end_of_file : int;
+
+ procedure getc_immediate
+ (stream : FILEs; ch : out int; end_of_file : out int);
+ pragma Import (C, getc_immediate, "getc_immediate");
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ ch := LM;
+
+ else
+ getc_immediate (File.Stream, ch, end_of_file);
+
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ elsif end_of_file /= 0 then
+ return EOF;
+ end if;
+ end if;
+
+ return ch;
+ end Getc_Immed;
+
+ -------------
+ -- Is_Open --
+ -------------
+
+ function Is_Open (File : File_Type) return Boolean is
+ begin
+ return FIO.Is_Open (AP (File));
+ end Is_Open;
+
+ ----------
+ -- Line --
+ ----------
+
+ -- Note: we assume that it is impossible in practice for the line
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Line (File : File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Line;
+ end Line;
+
+ function Line return Positive_Count is
+ begin
+ return Line (Current_Out);
+ end Line;
+
+ -----------------
+ -- Line_Length --
+ -----------------
+
+ function Line_Length (File : File_Type) return Count is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ return File.Line_Length;
+ end Line_Length;
+
+ function Line_Length return Count is
+ begin
+ return Line_Length (Current_Out);
+ end Line_Length;
+
+ ----------------
+ -- Look_Ahead --
+ ----------------
+
+ procedure Look_Ahead
+ (File : File_Type;
+ Item : out Wide_Wide_Character;
+ End_Of_Line : out Boolean)
+ is
+ ch : int;
+
+ -- Start of processing for Look_Ahead
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If we are logically before a line mark, we can return immediately
+
+ if File.Before_LM then
+ End_Of_Line := True;
+ Item := Wide_Wide_Character'Val (0);
+
+ -- If we are before a wide character, just return it (this happens
+ -- if there are two calls to Look_Ahead in a row).
+
+ elsif File.Before_Wide_Wide_Character then
+ End_Of_Line := False;
+ Item := File.Saved_Wide_Wide_Character;
+
+ -- otherwise we must read a character from the input stream
+
+ else
+ ch := Getc (File);
+
+ if ch = LM
+ or else ch = EOF
+ or else (ch = EOF and then File.Is_Regular_File)
+ then
+ End_Of_Line := True;
+ Ungetc (ch, File);
+ Item := Wide_Wide_Character'Val (0);
+
+ -- If the character is in the range 16#0000# to 16#007F# it stands
+ -- for itself and occupies a single byte, so we can unget it with
+ -- no difficulty.
+
+ elsif ch <= 16#0080# then
+ End_Of_Line := False;
+ Ungetc (ch, File);
+ Item := Wide_Wide_Character'Val (ch);
+
+ -- For a character above this range, we read the character, using
+ -- the Get_Wide_Wide_Char routine. It may well occupy more than one
+ -- byte so we can't put it back with ungetc. Instead we save it in
+ -- the control block, setting a flag that everyone interested in
+ -- reading characters must test before reading the stream.
+
+ else
+ Item := Get_Wide_Wide_Char (Character'Val (ch), File);
+ End_Of_Line := False;
+ File.Saved_Wide_Wide_Character := Item;
+ File.Before_Wide_Wide_Character := True;
+ end if;
+ end if;
+ end Look_Ahead;
+
+ procedure Look_Ahead
+ (Item : out Wide_Wide_Character;
+ End_Of_Line : out Boolean)
+ is
+ begin
+ Look_Ahead (Current_In, Item, End_Of_Line);
+ end Look_Ahead;
+
+ ----------
+ -- Mode --
+ ----------
+
+ function Mode (File : File_Type) return File_Mode is
+ begin
+ return To_TIO (FIO.Mode (AP (File)));
+ end Mode;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name (File : File_Type) return String is
+ begin
+ return FIO.Name (AP (File));
+ end Name;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line
+ (File : File_Type;
+ Spacing : Positive_Count := 1)
+ is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if Spacing not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+
+ for K in 1 .. Spacing loop
+ Putc (LM, File);
+ File.Line := File.Line + 1;
+
+ if File.Page_Length /= 0
+ and then File.Line > File.Page_Length
+ then
+ Putc (PM, File);
+ File.Line := 1;
+ File.Page := File.Page + 1;
+ end if;
+ end loop;
+
+ File.Col := 1;
+ end New_Line;
+
+ procedure New_Line (Spacing : Positive_Count := 1) is
+ begin
+ New_Line (Current_Out, Spacing);
+ end New_Line;
+
+ --------------
+ -- New_Page --
+ --------------
+
+ procedure New_Page (File : File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ if File.Col /= 1 or else File.Line = 1 then
+ Putc (LM, File);
+ end if;
+
+ Putc (PM, File);
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ end New_Page;
+
+ procedure New_Page is
+ begin
+ New_Page (Current_Out);
+ end New_Page;
+
+ -----------
+ -- Nextc --
+ -----------
+
+ function Nextc (File : File_Type) return int is
+ ch : int;
+
+ begin
+ ch := fgetc (File.Stream);
+
+ if ch = EOF then
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ end if;
+
+ else
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+
+ return ch;
+ end Nextc;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : File_Mode;
+ Name : String;
+ Form : String := "")
+ is
+ Dummy_File_Control_Block : Wide_Wide_Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => Dummy_File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'W',
+ Creat => False,
+ Text => True);
+ Set_WCEM (File);
+ end Open;
+
+ ----------
+ -- Page --
+ ----------
+
+ -- Note: we assume that it is impossible in practice for the page
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Page (File : File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Page;
+ end Page;
+
+ function Page return Positive_Count is
+ begin
+ return Page (Current_Out);
+ end Page;
+
+ -----------------
+ -- Page_Length --
+ -----------------
+
+ function Page_Length (File : File_Type) return Count is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ return File.Page_Length;
+ end Page_Length;
+
+ function Page_Length return Count is
+ begin
+ return Page_Length (Current_Out);
+ end Page_Length;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Wide_Wide_Character)
+ is
+ procedure Out_Char (C : Character);
+ -- Procedure to output one character of a wide character sequence
+
+ procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char);
+
+ --------------
+ -- Out_Char --
+ --------------
+
+ procedure Out_Char (C : Character) is
+ begin
+ Putc (Character'Pos (C), File);
+ end Out_Char;
+
+ -- Start of processing for Put
+
+ begin
+ WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method);
+ File.Col := File.Col + 1;
+ end Put;
+
+ procedure Put (Item : Wide_Wide_Character) is
+ begin
+ Put (Current_Out, Item);
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Wide_Wide_String)
+ is
+ begin
+ for J in Item'Range loop
+ Put (File, Item (J));
+ end loop;
+ end Put;
+
+ procedure Put (Item : Wide_Wide_String) is
+ begin
+ Put (Current_Out, Item);
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line
+ (File : File_Type;
+ Item : Wide_Wide_String)
+ is
+ begin
+ Put (File, Item);
+ New_Line (File);
+ end Put_Line;
+
+ procedure Put_Line (Item : Wide_Wide_String) is
+ begin
+ Put (Current_Out, Item);
+ New_Line (Current_Out);
+ end Put_Line;
+
+ ----------
+ -- Putc --
+ ----------
+
+ procedure Putc (ch : int; File : File_Type) is
+ begin
+ if fputc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end Putc;
+
+ ----------
+ -- Read --
+ ----------
+
+ -- This is the primitive Stream Read routine, used when a Text_IO file
+ -- is treated directly as a stream using Text_IO.Streams.Stream.
+
+ procedure Read
+ (File : in out Wide_Wide_Text_AFCB;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ Discard_ch : int;
+ pragma Unreferenced (Discard_ch);
+
+ begin
+ -- Need to deal with Before_Wide_Wide_Character ???
+
+ if File.Mode /= FCB.In_File then
+ raise Mode_Error;
+ end if;
+
+ -- Deal with case where our logical and physical position do not match
+ -- because of being after an LM or LM-PM sequence when in fact we are
+ -- logically positioned before it.
+
+ if File.Before_LM then
+
+ -- If we are before a PM, then it is possible for a stream read
+ -- to leave us after the LM and before the PM, which is a bit
+ -- odd. The easiest way to deal with this is to unget the PM,
+ -- so we are indeed positioned between the characters. This way
+ -- further stream read operations will work correctly, and the
+ -- effect on text processing is a little weird, but what can
+ -- be expected if stream and text input are mixed this way?
+
+ if File.Before_LM_PM then
+ Discard_ch := ungetc (PM, File.Stream);
+ File.Before_LM_PM := False;
+ end if;
+
+ File.Before_LM := False;
+
+ Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
+
+ if Item'Length = 1 then
+ Last := Item'Last;
+
+ else
+ Last :=
+ Item'First +
+ Stream_Element_Offset
+ (fread (buffer => Item'Address,
+ index => size_t (Item'First + 1),
+ size => 1,
+ count => Item'Length - 1,
+ stream => File.Stream));
+ end if;
+
+ return;
+ end if;
+
+ -- Now we do the read. Since this is a text file, it is normally in
+ -- text mode, but stream data must be read in binary mode, so we
+ -- temporarily set binary mode for the read, resetting it after.
+ -- These calls have no effect in a system (like Unix) where there is
+ -- no distinction between text and binary files.
+
+ set_binary_mode (fileno (File.Stream));
+
+ Last :=
+ Item'First +
+ Stream_Element_Offset
+ (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
+
+ if Last < Item'Last then
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ end if;
+ end if;
+
+ set_text_mode (fileno (File.Stream));
+ end Read;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset
+ (File : in out File_Type;
+ Mode : File_Mode)
+ is
+ begin
+ -- Don't allow change of mode for current file (RM A.10.2(5))
+
+ if (File = Current_In or else
+ File = Current_Out or else
+ File = Current_Error)
+ and then To_FCB (Mode) /= File.Mode
+ then
+ raise Mode_Error;
+ end if;
+
+ Terminate_Line (File);
+ FIO.Reset (AP (File), To_FCB (Mode));
+ File.Page := 1;
+ File.Line := 1;
+ File.Col := 1;
+ File.Line_Length := 0;
+ File.Page_Length := 0;
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ end Reset;
+
+ procedure Reset (File : in out File_Type) is
+ begin
+ Terminate_Line (File);
+ FIO.Reset (AP (File));
+ File.Page := 1;
+ File.Line := 1;
+ File.Col := 1;
+ File.Line_Length := 0;
+ File.Page_Length := 0;
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ end Reset;
+
+ -------------
+ -- Set_Col --
+ -------------
+
+ procedure Set_Col
+ (File : File_Type;
+ To : Positive_Count)
+ is
+ ch : int;
+
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_File_Open (AP (File));
+
+ if To = File.Col then
+ return;
+ end if;
+
+ if Mode (File) >= Out_File then
+ if File.Line_Length /= 0 and then To > File.Line_Length then
+ raise Layout_Error;
+ end if;
+
+ if To < File.Col then
+ New_Line (File);
+ end if;
+
+ while File.Col < To loop
+ Put (File, ' ');
+ end loop;
+
+ else
+ loop
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+
+ elsif ch = LM then
+ File.Line := File.Line + 1;
+ File.Col := 1;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+
+ elsif To = File.Col then
+ Ungetc (ch, File);
+ return;
+
+ else
+ File.Col := File.Col + 1;
+ end if;
+ end loop;
+ end if;
+ end Set_Col;
+
+ procedure Set_Col (To : Positive_Count) is
+ begin
+ Set_Col (Current_Out, To);
+ end Set_Col;
+
+ ---------------
+ -- Set_Error --
+ ---------------
+
+ procedure Set_Error (File : File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ Current_Err := File;
+ end Set_Error;
+
+ ---------------
+ -- Set_Input --
+ ---------------
+
+ procedure Set_Input (File : File_Type) is
+ begin
+ FIO.Check_Read_Status (AP (File));
+ Current_In := File;
+ end Set_Input;
+
+ --------------
+ -- Set_Line --
+ --------------
+
+ procedure Set_Line
+ (File : File_Type;
+ To : Positive_Count)
+ is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_File_Open (AP (File));
+
+ if To = File.Line then
+ return;
+ end if;
+
+ if Mode (File) >= Out_File then
+ if File.Page_Length /= 0 and then To > File.Page_Length then
+ raise Layout_Error;
+ end if;
+
+ if To < File.Line then
+ New_Page (File);
+ end if;
+
+ while File.Line < To loop
+ New_Line (File);
+ end loop;
+
+ else
+ while To /= File.Line loop
+ Skip_Line (File);
+ end loop;
+ end if;
+ end Set_Line;
+
+ procedure Set_Line (To : Positive_Count) is
+ begin
+ Set_Line (Current_Out, To);
+ end Set_Line;
+
+ ---------------------
+ -- Set_Line_Length --
+ ---------------------
+
+ procedure Set_Line_Length (File : File_Type; To : Count) is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+ File.Line_Length := To;
+ end Set_Line_Length;
+
+ procedure Set_Line_Length (To : Count) is
+ begin
+ Set_Line_Length (Current_Out, To);
+ end Set_Line_Length;
+
+ ----------------
+ -- Set_Output --
+ ----------------
+
+ procedure Set_Output (File : File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ Current_Out := File;
+ end Set_Output;
+
+ ---------------------
+ -- Set_Page_Length --
+ ---------------------
+
+ procedure Set_Page_Length (File : File_Type; To : Count) is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+ File.Page_Length := To;
+ end Set_Page_Length;
+
+ procedure Set_Page_Length (To : Count) is
+ begin
+ Set_Page_Length (Current_Out, To);
+ end Set_Page_Length;
+
+ --------------
+ -- Set_WCEM --
+ --------------
+
+ procedure Set_WCEM (File : in out File_Type) is
+ Start : Natural;
+ Stop : Natural;
+
+ begin
+ File.WC_Method := WCEM_Brackets;
+ FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
+
+ if Start = 0 then
+ File.WC_Method := WCEM_Brackets;
+
+ elsif Start /= 0 then
+ if Stop = Start then
+ for J in WC_Encoding_Letters'Range loop
+ if File.Form (Start) = WC_Encoding_Letters (J) then
+ File.WC_Method := J;
+ return;
+ end if;
+ end loop;
+ end if;
+
+ Close (File);
+ Raise_Exception (Use_Error'Identity, "invalid WCEM form parameter");
+ end if;
+ end Set_WCEM;
+
+ ---------------
+ -- Skip_Line --
+ ---------------
+
+ procedure Skip_Line
+ (File : File_Type;
+ Spacing : Positive_Count := 1)
+ is
+ ch : int;
+
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if Spacing not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Read_Status (AP (File));
+
+ for L in 1 .. Spacing loop
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+
+ else
+ ch := Getc (File);
+
+ -- If at end of file now, then immediately raise End_Error. Note
+ -- that we can never be positioned between a line mark and a page
+ -- mark, so if we are at the end of file, we cannot logically be
+ -- before the implicit page mark that is at the end of the file.
+
+ -- For the same reason, we do not need an explicit check for a
+ -- page mark. If there is a FF in the middle of a line, the file
+ -- is not in canonical format and we do not care about the page
+ -- numbers for files other than ones in canonical format.
+
+ if ch = EOF then
+ raise End_Error;
+ end if;
+
+ -- If not at end of file, then loop till we get to an LM or EOF.
+ -- The latter case happens only in non-canonical files where the
+ -- last line is not terminated by LM, but we don't want to blow
+ -- up for such files, so we assume an implicit LM in this case.
+
+ loop
+ exit when ch = LM or ch = EOF;
+ ch := Getc (File);
+ end loop;
+ end if;
+
+ -- We have got past a line mark, now, for a regular file only,
+ -- see if a page mark immediately follows this line mark and
+ -- if so, skip past the page mark as well. We do not do this
+ -- for non-regular files, since it would cause an undesirable
+ -- wait for an additional character.
+
+ File.Col := 1;
+ File.Line := File.Line + 1;
+
+ if File.Before_LM_PM then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Before_LM_PM := False;
+
+ elsif File.Is_Regular_File then
+ ch := Getc (File);
+
+ -- Page mark can be explicit, or implied at the end of the file
+
+ if (ch = PM or else ch = EOF)
+ and then File.Is_Regular_File
+ then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ else
+ Ungetc (ch, File);
+ end if;
+ end if;
+
+ end loop;
+
+ File.Before_Wide_Wide_Character := False;
+ end Skip_Line;
+
+ procedure Skip_Line (Spacing : Positive_Count := 1) is
+ begin
+ Skip_Line (Current_In, Spacing);
+ end Skip_Line;
+
+ ---------------
+ -- Skip_Page --
+ ---------------
+
+ procedure Skip_Page (File : File_Type) is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If at page mark already, just skip it
+
+ if File.Before_LM_PM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ return;
+ end if;
+
+ -- This is a bit tricky, if we are logically before an LM then
+ -- it is not an error if we are at an end of file now, since we
+ -- are not really at it.
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ ch := Getc (File);
+
+ -- Otherwise we do raise End_Error if we are at the end of file now
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+ end if;
+ end if;
+
+ -- Now we can just rumble along to the next page mark, or to the
+ -- end of file, if that comes first. The latter case happens when
+ -- the page mark is implied at the end of file.
+
+ loop
+ exit when ch = EOF
+ or else (ch = PM and then File.Is_Regular_File);
+ ch := Getc (File);
+ end loop;
+
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ File.Before_Wide_Wide_Character := False;
+ end Skip_Page;
+
+ procedure Skip_Page is
+ begin
+ Skip_Page (Current_In);
+ end Skip_Page;
+
+ --------------------
+ -- Standard_Error --
+ --------------------
+
+ function Standard_Error return File_Type is
+ begin
+ return Standard_Err;
+ end Standard_Error;
+
+ function Standard_Error return File_Access is
+ begin
+ return Standard_Err'Access;
+ end Standard_Error;
+
+ --------------------
+ -- Standard_Input --
+ --------------------
+
+ function Standard_Input return File_Type is
+ begin
+ return Standard_In;
+ end Standard_Input;
+
+ function Standard_Input return File_Access is
+ begin
+ return Standard_In'Access;
+ end Standard_Input;
+
+ ---------------------
+ -- Standard_Output --
+ ---------------------
+
+ function Standard_Output return File_Type is
+ begin
+ return Standard_Out;
+ end Standard_Output;
+
+ function Standard_Output return File_Access is
+ begin
+ return Standard_Out'Access;
+ end Standard_Output;
+
+ --------------------
+ -- Terminate_Line --
+ --------------------
+
+ procedure Terminate_Line (File : File_Type) is
+ begin
+ FIO.Check_File_Open (AP (File));
+
+ -- For file other than In_File, test for needing to terminate last line
+
+ if Mode (File) /= In_File then
+
+ -- If not at start of line definition need new line
+
+ if File.Col /= 1 then
+ New_Line (File);
+
+ -- For files other than standard error and standard output, we
+ -- make sure that an empty file has a single line feed, so that
+ -- it is properly formatted. We avoid this for the standard files
+ -- because it is too much of a nuisance to have these odd line
+ -- feeds when nothing has been written to the file.
+
+ elsif (File /= Standard_Err and then File /= Standard_Out)
+ and then (File.Line = 1 and then File.Page = 1)
+ then
+ New_Line (File);
+ end if;
+ end if;
+ end Terminate_Line;
+
+ ------------
+ -- Ungetc --
+ ------------
+
+ procedure Ungetc (ch : int; File : File_Type) is
+ begin
+ if ch /= EOF then
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+ end Ungetc;
+
+ -----------
+ -- Write --
+ -----------
+
+ -- This is the primitive Stream Write routine, used when a Text_IO file
+ -- is treated directly as a stream using Text_IO.Streams.Stream.
+
+ procedure Write
+ (File : in out Wide_Wide_Text_AFCB;
+ Item : Stream_Element_Array)
+ is
+ Siz : constant size_t := Item'Length;
+
+ begin
+ if File.Mode = FCB.In_File then
+ raise Mode_Error;
+ end if;
+
+ -- Now we do the write. Since this is a text file, it is normally in
+ -- text mode, but stream data must be written in binary mode, so we
+ -- temporarily set binary mode for the write, resetting it after.
+ -- These calls have no effect in a system (like Unix) where there is
+ -- no distinction between text and binary files.
+
+ set_binary_mode (fileno (File.Stream));
+
+ if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
+ raise Device_Error;
+ end if;
+
+ set_text_mode (fileno (File.Stream));
+ end Write;
+
+ -- Use "preallocated" strings to avoid calling "new" during the
+ -- elaboration of the run time. This is needed in the tasking case to
+ -- avoid calling Task_Lock too early. A filename is expected to end with
+ -- a null character in the runtime, here the null characters are added
+ -- just to have a correct filename length.
+
+ Err_Name : aliased String := "*stderr" & ASCII.Nul;
+ In_Name : aliased String := "*stdin" & ASCII.Nul;
+ Out_Name : aliased String := "*stdout" & ASCII.Nul;
+
+begin
+ -------------------------------
+ -- Initialize Standard Files --
+ -------------------------------
+
+ for J in WC_Encoding_Method loop
+ if WC_Encoding = WC_Encoding_Letters (J) then
+ Default_WCEM := J;
+ end if;
+ end loop;
+
+ -- Note: the names in these files are bogus, and probably it would be
+ -- better for these files to have no names, but the ACVC test insist!
+ -- We use names that are bound to fail in open etc.
+
+ Standard_Err.Stream := stderr;
+ Standard_Err.Name := Err_Name'Access;
+ Standard_Err.Form := Null_Str'Unrestricted_Access;
+ Standard_Err.Mode := FCB.Out_File;
+ Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0;
+ Standard_Err.Is_Temporary_File := False;
+ Standard_Err.Is_System_File := True;
+ Standard_Err.Is_Text_File := True;
+ Standard_Err.Access_Method := 'T';
+ Standard_Err.WC_Method := Default_WCEM;
+
+ Standard_In.Stream := stdin;
+ Standard_In.Name := In_Name'Access;
+ Standard_In.Form := Null_Str'Unrestricted_Access;
+ Standard_In.Mode := FCB.In_File;
+ Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0;
+ Standard_In.Is_Temporary_File := False;
+ Standard_In.Is_System_File := True;
+ Standard_In.Is_Text_File := True;
+ Standard_In.Access_Method := 'T';
+ Standard_In.WC_Method := Default_WCEM;
+
+ Standard_Out.Stream := stdout;
+ Standard_Out.Name := Out_Name'Access;
+ Standard_Out.Form := Null_Str'Unrestricted_Access;
+ Standard_Out.Mode := FCB.Out_File;
+ Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0;
+ Standard_Out.Is_Temporary_File := False;
+ Standard_Out.Is_System_File := True;
+ Standard_Out.Is_Text_File := True;
+ Standard_Out.Access_Method := 'T';
+ Standard_Out.WC_Method := Default_WCEM;
+
+ FIO.Chain_File (AP (Standard_In));
+ FIO.Chain_File (AP (Standard_Out));
+ FIO.Chain_File (AP (Standard_Err));
+
+ FIO.Make_Unbuffered (AP (Standard_Out));
+ FIO.Make_Unbuffered (AP (Standard_Err));
+
+end Ada.Wide_Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: the generic subpackages of Wide_Wide_Text_IO (Integer_IO, Float_IO,
+-- Fixed_IO, Modular_IO, Decimal_IO and Enumeration_IO) appear as private
+-- children in GNAT. These children are with'ed automatically if they are
+-- referenced, so this rearrangement is invisible to user programs, but has
+-- the advantage that only the needed parts of Wide_Wide_Text_IO are processed
+-- and loaded.
+
+with Ada.IO_Exceptions;
+with Ada.Streams;
+with System;
+with System.File_Control_Block;
+with System.WCh_Con;
+
+package Ada.Wide_Wide_Text_IO is
+
+ package WCh_Con renames System.WCh_Con;
+
+ type File_Type is limited private;
+ type File_Mode is (In_File, Out_File, Append_File);
+
+ -- The following representation clause allows the use of unchecked
+ -- conversion for rapid translation between the File_Mode type
+ -- used in this package and System.File_IO.
+
+ for File_Mode use
+ (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File)
+ Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File)
+ Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File)
+
+ type Count is range 0 .. Natural'Last;
+ -- The value of Count'Last must be large enough so that the assumption
+ -- enough so that the assumption that the Line, Column and Page
+ -- counts can never exceed this value is a valid assumption.
+
+ subtype Positive_Count is Count range 1 .. Count'Last;
+
+ Unbounded : constant Count := 0;
+ -- Line and page length
+
+ subtype Field is Integer range 0 .. 255;
+ -- Note: if for any reason, there is a need to increase this value,
+ -- then it will be necessary to change the corresponding value in
+ -- System.Img_Real in file s-imgrea.adb.
+
+ subtype Number_Base is Integer range 2 .. 16;
+
+ type Type_Set is (Lower_Case, Upper_Case);
+
+ ---------------------
+ -- File Management --
+ ---------------------
+
+ procedure Create
+ (File : in out File_Type;
+ Mode : File_Mode := Out_File;
+ Name : String := "";
+ Form : String := "");
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : File_Mode;
+ Name : String;
+ Form : String := "");
+
+ procedure Close (File : in out File_Type);
+ procedure Delete (File : in out File_Type);
+ procedure Reset (File : in out File_Type; Mode : File_Mode);
+ procedure Reset (File : in out File_Type);
+
+ function Mode (File : File_Type) return File_Mode;
+ function Name (File : File_Type) return String;
+ function Form (File : File_Type) return String;
+
+ function Is_Open (File : File_Type) return Boolean;
+
+ ------------------------------------------------------
+ -- Control of default input, output and error files --
+ ------------------------------------------------------
+
+ procedure Set_Input (File : File_Type);
+ procedure Set_Output (File : File_Type);
+ procedure Set_Error (File : File_Type);
+
+ function Standard_Input return File_Type;
+ function Standard_Output return File_Type;
+ function Standard_Error return File_Type;
+
+ function Current_Input return File_Type;
+ function Current_Output return File_Type;
+ function Current_Error return File_Type;
+
+ type File_Access is access constant File_Type;
+
+ function Standard_Input return File_Access;
+ function Standard_Output return File_Access;
+ function Standard_Error return File_Access;
+
+ function Current_Input return File_Access;
+ function Current_Output return File_Access;
+ function Current_Error return File_Access;
+
+ --------------------
+ -- Buffer control --
+ --------------------
+
+ -- Note: The paramter file is in out in the RM, but as pointed out
+ -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight.
+
+ procedure Flush (File : File_Type);
+ procedure Flush;
+
+ --------------------------------------------
+ -- Specification of line and page lengths --
+ --------------------------------------------
+
+ procedure Set_Line_Length (File : File_Type; To : Count);
+ procedure Set_Line_Length (To : Count);
+
+ procedure Set_Page_Length (File : File_Type; To : Count);
+ procedure Set_Page_Length (To : Count);
+
+ function Line_Length (File : File_Type) return Count;
+ function Line_Length return Count;
+
+ function Page_Length (File : File_Type) return Count;
+ function Page_Length return Count;
+
+ ------------------------------------
+ -- Column, Line, and Page Control --
+ ------------------------------------
+
+ procedure New_Line (File : File_Type; Spacing : Positive_Count := 1);
+ procedure New_Line (Spacing : Positive_Count := 1);
+
+ procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1);
+ procedure Skip_Line (Spacing : Positive_Count := 1);
+
+ function End_Of_Line (File : File_Type) return Boolean;
+ function End_Of_Line return Boolean;
+
+ procedure New_Page (File : File_Type);
+ procedure New_Page;
+
+ procedure Skip_Page (File : File_Type);
+ procedure Skip_Page;
+
+ function End_Of_Page (File : File_Type) return Boolean;
+ function End_Of_Page return Boolean;
+
+ function End_Of_File (File : File_Type) return Boolean;
+ function End_Of_File return Boolean;
+
+ procedure Set_Col (File : File_Type; To : Positive_Count);
+ procedure Set_Col (To : Positive_Count);
+
+ procedure Set_Line (File : File_Type; To : Positive_Count);
+ procedure Set_Line (To : Positive_Count);
+
+ function Col (File : File_Type) return Positive_Count;
+ function Col return Positive_Count;
+
+ function Line (File : File_Type) return Positive_Count;
+ function Line return Positive_Count;
+
+ function Page (File : File_Type) return Positive_Count;
+ function Page return Positive_Count;
+
+ ----------------------------
+ -- Character Input-Output --
+ ----------------------------
+
+ procedure Get (File : File_Type; Item : out Wide_Wide_Character);
+ procedure Get (Item : out Wide_Wide_Character);
+ procedure Put (File : File_Type; Item : Wide_Wide_Character);
+ procedure Put (Item : Wide_Wide_Character);
+
+ procedure Look_Ahead
+ (File : File_Type;
+ Item : out Wide_Wide_Character;
+ End_Of_Line : out Boolean);
+
+ procedure Look_Ahead
+ (Item : out Wide_Wide_Character;
+ End_Of_Line : out Boolean);
+
+ procedure Get_Immediate
+ (File : File_Type;
+ Item : out Wide_Wide_Character);
+
+ procedure Get_Immediate
+ (Item : out Wide_Wide_Character);
+
+ procedure Get_Immediate
+ (File : File_Type;
+ Item : out Wide_Wide_Character;
+ Available : out Boolean);
+
+ procedure Get_Immediate
+ (Item : out Wide_Wide_Character;
+ Available : out Boolean);
+
+ -------------------------
+ -- String Input-Output --
+ -------------------------
+
+ procedure Get (File : File_Type; Item : out Wide_Wide_String);
+ procedure Get (Item : out Wide_Wide_String);
+ procedure Put (File : File_Type; Item : Wide_Wide_String);
+ procedure Put (Item : Wide_Wide_String);
+
+ procedure Get_Line
+ (File : File_Type;
+ Item : out Wide_Wide_String;
+ Last : out Natural);
+
+ function Get_Line (File : File_Type) return Wide_Wide_String;
+ pragma Ada_05 (Get_Line);
+
+ function Get_Line return Wide_Wide_String;
+ pragma Ada_05 (Get_Line);
+
+ procedure Get_Line
+ (Item : out Wide_Wide_String;
+ Last : out Natural);
+
+ procedure Put_Line
+ (File : File_Type;
+ Item : Wide_Wide_String);
+
+ procedure Put_Line
+ (Item : Wide_Wide_String);
+
+ ---------------------------------------
+ -- Generic packages for Input-Output --
+ ---------------------------------------
+
+ -- The generic packages:
+
+ -- Ada.Wide_Wide_Text_IO.Integer_IO
+ -- Ada.Wide_Wide_Text_IO.Modular_IO
+ -- Ada.Wide_Wide_Text_IO.Float_IO
+ -- Ada.Wide_Wide_Text_IO.Fixed_IO
+ -- Ada.Wide_Wide_Text_IO.Decimal_IO
+ -- Ada.Wide_Wide_Text_IO.Enumeration_IO
+
+ -- are implemented as separate child packages in GNAT, so the
+ -- spec and body of these packages are to be found in separate
+ -- child units. This implementation detail is hidden from the
+ -- Ada programmer by special circuitry in the compiler that
+ -- treats these child packages as though they were nested in
+ -- Text_IO. The advantage of this special processing is that
+ -- the subsidiary routines needed if these generics are used
+ -- are not loaded when they are not used.
+
+ ----------------
+ -- Exceptions --
+ ----------------
+
+ Status_Error : exception renames IO_Exceptions.Status_Error;
+ Mode_Error : exception renames IO_Exceptions.Mode_Error;
+ Name_Error : exception renames IO_Exceptions.Name_Error;
+ Use_Error : exception renames IO_Exceptions.Use_Error;
+ Device_Error : exception renames IO_Exceptions.Device_Error;
+ End_Error : exception renames IO_Exceptions.End_Error;
+ Data_Error : exception renames IO_Exceptions.Data_Error;
+ Layout_Error : exception renames IO_Exceptions.Layout_Error;
+
+private
+ -----------------------------------
+ -- Handling of Format Characters --
+ -----------------------------------
+
+ -- Line marks are represented by the single character ASCII.LF (16#0A#).
+ -- In DOS and similar systems, underlying file translation takes care
+ -- of translating this to and from the standard CR/LF sequences used in
+ -- these operating systems to mark the end of a line. On output there is
+ -- always a line mark at the end of the last line, but on input, this
+ -- line mark can be omitted, and is implied by the end of file.
+
+ -- Page marks are represented by the single character ASCII.FF (16#0C#),
+ -- The page mark at the end of the file may be omitted, and is normally
+ -- omitted on output unless an explicit New_Page call is made before
+ -- closing the file. No page mark is added when a file is appended to,
+ -- so, in accordance with the permission in (RM A.10.2(4)), there may
+ -- or may not be a page mark separating preexising text in the file
+ -- from the new text to be written.
+
+ -- A file mark is marked by the physical end of file. In DOS translation
+ -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the
+ -- physical end of file, so in effect this character is recognized as
+ -- marking the end of file in DOS and similar systems.
+
+ LM : constant := Character'Pos (ASCII.LF);
+ -- Used as line mark
+
+ PM : constant := Character'Pos (ASCII.FF);
+ -- Used as page mark, except at end of file where it is implied
+
+ -------------------------------------
+ -- Wide_Wide_Text_IO File Control Block --
+ -------------------------------------
+
+ Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8;
+ -- This gets modified during initialization (see body) using
+ -- the default value established in the call to Set_Globals.
+
+ package FCB renames System.File_Control_Block;
+
+ type Wide_Wide_Text_AFCB is new FCB.AFCB with record
+ Page : Count := 1;
+ Line : Count := 1;
+ Col : Count := 1;
+ Line_Length : Count := 0;
+ Page_Length : Count := 0;
+
+ Before_LM : Boolean := False;
+ -- This flag is used to deal with the anomolies introduced by the
+ -- peculiar definition of End_Of_File and End_Of_Page in Ada. These
+ -- functions require looking ahead more than one character. Since
+ -- there is no convenient way of backing up more than one character,
+ -- what we do is to leave ourselves positioned past the LM, but set
+ -- this flag, so that we know that from an Ada point of view we are
+ -- in front of the LM, not after it. A bit of a kludge, but it works!
+
+ Before_LM_PM : Boolean := False;
+ -- This flag similarly handles the case of being physically positioned
+ -- after a LM-PM sequence when logically we are before the LM-PM. This
+ -- flag can only be set if Before_LM is also set.
+
+ WC_Method : WCh_Con.WC_Encoding_Method := Default_WCEM;
+ -- Encoding method to be used for this file
+
+ Before_Wide_Wide_Character : Boolean := False;
+ -- This flag is set to indicate that a wide character in the input has
+ -- been read by Wide_Wide_Text_IO.Look_Ahead. If it is set to True,
+ -- then it means that the stream is logically positioned before the
+ -- character but is physically positioned after it. The character
+ -- involved must not be in the range 16#00#-16#7F#, i.e. if the flag is
+ -- set, then we know the next character has a code greater than 16#7F#,
+ -- and the value of this character is saved in
+ -- Saved_Wide_Wide_Character.
+
+ Saved_Wide_Wide_Character : Wide_Wide_Character;
+ -- This field is valid only if Before_Wide_Wide_Character is set. It
+ -- contains a wide character read by Look_Ahead. If Look_Ahead
+ -- reads a character in the range 16#0000# to 16#007F#, then it
+ -- can use ungetc to put it back, but ungetc cannot be called
+ -- more than once, so for characters above this range, we don't
+ -- try to back up the file. Instead we save the character in this
+ -- field and set the flag Before_Wide_Wide_Character to indicate that
+ -- we are logically positioned before this character even though
+ -- the stream is physically positioned after it.
+
+ end record;
+
+ type File_Type is access all Wide_Wide_Text_AFCB;
+
+ function AFCB_Allocate
+ (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr;
+
+ procedure AFCB_Close (File : access Wide_Wide_Text_AFCB);
+ procedure AFCB_Free (File : access Wide_Wide_Text_AFCB);
+
+ procedure Read
+ (File : in out Wide_Wide_Text_AFCB;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset);
+ -- Read operation used when Wide_Wide_Text_IO file is treated as a Stream
+
+ procedure Write
+ (File : in out Wide_Wide_Text_AFCB;
+ Item : Ada.Streams.Stream_Element_Array);
+ -- Write operation used when Wide_Wide_Text_IO file is treated as a Stream
+
+ ------------------------
+ -- The Standard Files --
+ ------------------------
+
+ Null_Str : aliased constant String := "";
+ -- Used as name and form of standard files
+
+ Standard_Err_AFCB : aliased Wide_Wide_Text_AFCB;
+ Standard_In_AFCB : aliased Wide_Wide_Text_AFCB;
+ Standard_Out_AFCB : aliased Wide_Wide_Text_AFCB;
+
+ Standard_Err : aliased File_Type := Standard_Err_AFCB'Access;
+ Standard_In : aliased File_Type := Standard_In_AFCB'Access;
+ Standard_Out : aliased File_Type := Standard_Out_AFCB'Access;
+ -- Standard files
+
+ Current_In : aliased File_Type := Standard_In;
+ Current_Out : aliased File_Type := Standard_Out;
+ Current_Err : aliased File_Type := Standard_Err;
+ -- Current files
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- These subprograms are in the private part of the spec so that they can
+ -- be shared by the routines in the body of Ada.Text_IO.Wide_Wide_Text_IO.
+
+ -- Note: we use Integer in these declarations instead of the more accurate
+ -- Interfaces.C_Streams.int, because we do not want to drag in the spec of
+ -- this interfaces package with the spec of Ada.Text_IO, and we know that
+ -- in fact these types are identical
+
+ function Getc (File : File_Type) return Integer;
+ -- Gets next character from file, which has already been checked for
+ -- being in read status, and returns the character read if no error
+ -- occurs. The result is EOF if the end of file was read.
+
+ procedure Get_Character
+ (File : File_Type;
+ Item : out Character);
+ -- This is essentially a copy of the normal Get routine from Text_IO. It
+ -- obtains a single character from the input file File, and places it in
+ -- Item. This character may be the leading character of a
+ -- Wide_Wide_Character sequence, but that is up to the caller to deal
+ -- with.
+
+ function Get_Wide_Wide_Char
+ (C : Character;
+ File : File_Type) return Wide_Wide_Character;
+ -- This function is shared by Get and Get_Immediate to extract a wide
+ -- character value from the given File. The first byte has already been
+ -- read and is passed in C. The wide character value is returned as the
+ -- result, and the file pointer is bumped past the character.
+
+ function Nextc (File : File_Type) return Integer;
+ -- Returns next character from file without skipping past it (i.e. it
+ -- is a combination of Getc followed by an Ungetc).
+
+ procedure Putc (ch : Integer; File : File_Type);
+ -- Outputs the given character to the file, which has already been
+ -- checked for being in output status. Device_Error is raised if the
+ -- character cannot be written.
+
+ procedure Terminate_Line (File : File_Type);
+ -- If the file is in Write_File or Append_File mode, and the current
+ -- line is not terminated, then a line terminator is written using
+ -- New_Line. Note that there is no Terminate_Page routine, because
+ -- the page mark at the end of the file is implied if necessary.
+
+ procedure Ungetc (ch : Integer; File : File_Type);
+ -- Pushes back character into stream, using ungetc. The caller has
+ -- checked that the file is in read status. Device_Error is raised
+ -- if the character cannot be pushed back. An attempt to push back
+ -- and end of file character (EOF) is ignored.
+
+end Ada.Wide_Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Float_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Fixed_IO is
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Aux.Get (TFT (File), Long_Long_Float (Item), Width);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ Aux.Gets (S, Long_Long_Float (Item), Last);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Fixed_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Fixed_IO is a subpackage of
+-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading
+-- the necessary code if Fixed_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is delta <>;
+
+package Ada.Wide_Wide_Text_IO.Fixed_IO is
+
+ Default_Fore : Field := Num'Fore;
+ Default_Aft : Field := Num'Aft;
+ Default_Exp : Field := 0;
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0);
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+end Ada.Wide_Wide_Text_IO.Fixed_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+
+with System.Img_Real; use System.Img_Real;
+with System.Val_Real; use System.Val_Real;
+
+package body Ada.Wide_Wide_Text_IO.Float_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Long_Long_Float;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Real (Buf, Ptr'Access, Stop);
+
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ procedure Gets
+ (From : String;
+ Item : out Long_Long_Float;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Real (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ raise Data_Error;
+ end Gets;
+
+ ---------------
+ -- Load_Real --
+ ---------------
+
+ procedure Load_Real
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Loaded : Boolean;
+
+ begin
+ -- Skip initial blanks and load possible sign
+
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ -- Case of .nnnn
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Otherwise must have digits to start
+
+ else
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Based cases
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+
+ -- Case of nnn#.xxx#
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+
+ -- Case of nnn#xxx.[xxx]# or nnn#xxx#
+
+ else
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ end if;
+
+ -- As usual, it seems strange to allow mixed base characters,
+ -- but that is what ACVC tests expect, see CE3804M, case (3).
+
+ Load (File, Buf, Ptr, '#', ':');
+ end if;
+
+ -- Case of nnn.[nnn] or nnn
+
+ else
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end Load_Real;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Long_Long_Float;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : Long_Long_Float;
+ Aft : Field;
+ Exp : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+
+ else
+ for J in 1 .. Ptr loop
+ To (To'Last - Ptr + J) := Buf (J);
+ end loop;
+
+ for J in To'First .. To'Last - Ptr loop
+ To (J) := ' ';
+ end loop;
+ end if;
+ end Puts;
+
+end Ada.Wide_Wide_Text_IO.Float_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Wide_Text_IO.Float_IO that
+-- are shared among separate instantiations of this package. The routines
+-- in this package are identical semantically to those in Float_IO itself,
+-- except that generic parameter Num has been replaced by Long_Long_Float,
+-- and the default parameters have been removed because they are supplied
+-- explicitly by the calls from within the generic template. Also used by
+-- Ada.Wide_Wide_Text_IO.Fixed_IO, and by Ada.Wide_Wide_Text_IO.Decimal_IO.
+
+private package Ada.Wide_Wide_Text_IO.Float_Aux is
+
+ procedure Load_Real
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load a possibly signed
+ -- real literal value from the input file into Buf, starting at Ptr + 1.
+
+ procedure Get
+ (File : File_Type;
+ Item : out Long_Long_Float;
+ Width : Field);
+
+ procedure Gets
+ (From : String;
+ Item : out Long_Long_Float;
+ Last : out Positive);
+
+ procedure Put
+ (File : File_Type;
+ Item : Long_Long_Float;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field);
+
+ procedure Puts
+ (To : out String;
+ Item : Long_Long_Float;
+ Aft : Field;
+ Exp : Field);
+
+end Ada.Wide_Wide_Text_IO.Float_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Float_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Float_IO is
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Aux.Get (TFT (File), Long_Long_Float (Item), Width);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ Aux.Gets (S, Long_Long_Float (Item), Last);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Float_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Float_IO is a subpackage
+-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading
+-- the necessary code if Float_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is digits <>;
+
+package Ada.Wide_Wide_Text_IO.Float_IO is
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Num'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0);
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+end Ada.Wide_Wide_Text_IO.Float_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . G E N E R I C _ A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.File_IO;
+with System.File_Control_Block;
+
+package body Ada.Wide_Wide_Text_IO.Generic_Aux is
+
+ package FIO renames System.File_IO;
+ package FCB renames System.File_Control_Block;
+ subtype AP is FCB.AFCB_Ptr;
+
+ ------------------------
+ -- Check_End_Of_Field --
+ ------------------------
+
+ procedure Check_End_Of_Field
+ (Buf : String;
+ Stop : Integer;
+ Ptr : Integer;
+ Width : Field)
+ is
+ begin
+ if Ptr > Stop then
+ return;
+
+ elsif Width = 0 then
+ raise Data_Error;
+
+ else
+ for J in Ptr .. Stop loop
+ if not Is_Blank (Buf (J)) then
+ raise Data_Error;
+ end if;
+ end loop;
+ end if;
+ end Check_End_Of_Field;
+
+ -----------------------
+ -- Check_On_One_Line --
+ -----------------------
+
+ procedure Check_On_One_Line
+ (File : File_Type;
+ Length : Integer)
+ is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ if File.Line_Length /= 0 then
+ if Count (Length) > File.Line_Length then
+ raise Layout_Error;
+ elsif File.Col + Count (Length) > File.Line_Length + 1 then
+ New_Line (File);
+ end if;
+ end if;
+ end Check_On_One_Line;
+
+ --------------
+ -- Is_Blank --
+ --------------
+
+ function Is_Blank (C : Character) return Boolean is
+ begin
+ return C = ' ' or else C = ASCII.HT;
+ end Is_Blank;
+
+ ----------
+ -- Load --
+ ----------
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character;
+ Loaded : out Boolean)
+ is
+ ch : int;
+
+ begin
+ if File.Before_Wide_Wide_Character then
+ Loaded := False;
+ return;
+
+ else
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char) then
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ else
+ Ungetc (ch, File);
+ Loaded := False;
+ end if;
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character)
+ is
+ ch : int;
+
+ begin
+ if File.Before_Wide_Wide_Character then
+ null;
+
+ else
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char) then
+ Store_Char (File, ch, Buf, Ptr);
+ else
+ Ungetc (ch, File);
+ end if;
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character;
+ Loaded : out Boolean)
+ is
+ ch : int;
+
+ begin
+ if File.Before_Wide_Wide_Character then
+ Loaded := False;
+ return;
+
+ else
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char1)
+ or else ch = Character'Pos (Char2)
+ then
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ else
+ Ungetc (ch, File);
+ Loaded := False;
+ end if;
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character)
+ is
+ ch : int;
+
+ begin
+ if File.Before_Wide_Wide_Character then
+ null;
+
+ else
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char1)
+ or else ch = Character'Pos (Char2)
+ then
+ Store_Char (File, ch, Buf, Ptr);
+ else
+ Ungetc (ch, File);
+ end if;
+ end if;
+ end Load;
+
+ -----------------
+ -- Load_Digits --
+ -----------------
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean)
+ is
+ ch : int;
+ After_Digit : Boolean;
+
+ begin
+ if File.Before_Wide_Wide_Character then
+ Loaded := False;
+ return;
+
+ else
+ ch := Getc (File);
+
+ if ch not in Character'Pos ('0') .. Character'Pos ('9') then
+ Loaded := False;
+
+ else
+ Loaded := True;
+ After_Digit := True;
+
+ loop
+ Store_Char (File, ch, Buf, Ptr);
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Ungetc (ch, File);
+ end if;
+ end Load_Digits;
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ ch : int;
+ After_Digit : Boolean;
+
+ begin
+ if File.Before_Wide_Wide_Character then
+ return;
+
+ else
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ loop
+ Store_Char (File, ch, Buf, Ptr);
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Ungetc (ch, File);
+ end if;
+ end Load_Digits;
+
+ --------------------------
+ -- Load_Extended_Digits --
+ --------------------------
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean)
+ is
+ ch : int;
+ After_Digit : Boolean := False;
+
+ begin
+ if File.Before_Wide_Wide_Character then
+ Loaded := False;
+ return;
+
+ else
+ Loaded := False;
+
+ loop
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9')
+ or else
+ ch in Character'Pos ('a') .. Character'Pos ('f')
+ or else
+ ch in Character'Pos ('A') .. Character'Pos ('F')
+ then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ end loop;
+
+ Ungetc (ch, File);
+ end if;
+ end Load_Extended_Digits;
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ Junk : Boolean;
+
+ begin
+ Load_Extended_Digits (File, Buf, Ptr, Junk);
+ end Load_Extended_Digits;
+
+ ---------------
+ -- Load_Skip --
+ ---------------
+
+ procedure Load_Skip (File : File_Type) is
+ C : Character;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- We need to explicitly test for the case of being before a wide
+ -- character (greater than 16#7F#). Since no such character can
+ -- ever legitimately be a valid numeric character, we can
+ -- immediately signal Data_Error.
+
+ if File.Before_Wide_Wide_Character then
+ raise Data_Error;
+ end if;
+
+ -- Otherwise loop till we find a non-blank character (note that as
+ -- usual in Wide_Wide_Text_IO, blank includes horizontal tab). Note that
+ -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately.
+
+ loop
+ Get_Character (File, C);
+ exit when not Is_Blank (C);
+ end loop;
+
+ Ungetc (Character'Pos (C), File);
+ File.Col := File.Col - 1;
+ end Load_Skip;
+
+ ----------------
+ -- Load_Width --
+ ----------------
+
+ procedure Load_Width
+ (File : File_Type;
+ Width : Field;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ ch : int;
+ WC : Wide_Wide_Character;
+
+ Bad_Wide_Wide_C : Boolean := False;
+ -- Set True if one of the characters read is not in range of type
+ -- Character. This is always a Data_Error, but we do not signal it
+ -- right away, since we have to read the full number of characters.
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If we are immediately before a line mark, then we have no characters.
+ -- This is always a data error, so we may as well raise it right away.
+
+ if File.Before_LM then
+ raise Data_Error;
+
+ else
+ for J in 1 .. Width loop
+ if File.Before_Wide_Wide_Character then
+ Bad_Wide_Wide_C := True;
+ Store_Char (File, 0, Buf, Ptr);
+ File.Before_Wide_Wide_Character := False;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ exit;
+
+ elsif ch = LM then
+ Ungetc (ch, File);
+ exit;
+
+ else
+ WC := Get_Wide_Wide_Char (Character'Val (ch), File);
+ ch := Wide_Wide_Character'Pos (WC);
+
+ if ch > 255 then
+ Bad_Wide_Wide_C := True;
+ ch := 0;
+ end if;
+
+ Store_Char (File, ch, Buf, Ptr);
+ end if;
+ end if;
+ end loop;
+
+ if Bad_Wide_Wide_C then
+ raise Data_Error;
+ end if;
+ end if;
+ end Load_Width;
+
+ --------------
+ -- Put_Item --
+ --------------
+
+ procedure Put_Item (File : File_Type; Str : String) is
+ begin
+ Check_On_One_Line (File, Str'Length);
+
+ for J in Str'Range loop
+ Put (File, Wide_Wide_Character'Val (Character'Pos (Str (J))));
+ end loop;
+ end Put_Item;
+
+ ----------------
+ -- Store_Char --
+ ----------------
+
+ procedure Store_Char
+ (File : File_Type;
+ ch : Integer;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ begin
+ File.Col := File.Col + 1;
+
+ if Ptr = Buf'Last then
+ raise Data_Error;
+ else
+ Ptr := Ptr + 1;
+ Buf (Ptr) := Character'Val (ch);
+ end if;
+ end Store_Char;
+
+ -----------------
+ -- String_Skip --
+ -----------------
+
+ procedure String_Skip (Str : String; Ptr : out Integer) is
+ begin
+ Ptr := Str'First;
+
+ loop
+ if Ptr > Str'Last then
+ raise End_Error;
+
+ elsif not Is_Blank (Str (Ptr)) then
+ return;
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+ end loop;
+ end String_Skip;
+
+ ------------
+ -- Ungetc --
+ ------------
+
+ procedure Ungetc (ch : int; File : File_Type) is
+ begin
+ if ch /= EOF then
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+ end Ungetc;
+
+end Ada.Wide_Wide_Text_IO.Generic_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . G E N E R I C _ A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains a set of auxiliary routines used by Wide_Wide_Text_IO
+-- generic children, including for reading and writing numeric strings.
+
+-- Note: although this is the Wide version of the package, the interface here
+-- is still in terms of Character and String rather than Wide_Wide_Character
+-- and Wide_Wide_String, since all numeric strings are composed entirely of
+-- characters in the range of type Standard.Character, and the basic
+-- conversion routines work with Character rather than Wide_Wide_Character.
+
+package Ada.Wide_Wide_Text_IO.Generic_Aux is
+
+ -- Note: for all the Load routines, File indicates the file to be read,
+ -- Buf is the string into which data is stored, Ptr is the index of the
+ -- last character stored so far, and is updated if additional characters
+ -- are stored. Data_Error is raised if the input overflows Buf. The only
+ -- Load routines that do a file status check are Load_Skip and Load_Width
+ -- so one of these two routines must be called first.
+
+ procedure Check_End_Of_Field
+ (Buf : String;
+ Stop : Integer;
+ Ptr : Integer;
+ Width : Field);
+ -- This routine is used after doing a get operations on a numeric value.
+ -- Buf is the string being scanned, and Stop is the last character of
+ -- the field being scanned. Ptr is as set by the call to the scan routine
+ -- that scanned out the numeric value, i.e. it points one past the last
+ -- character scanned, and Width is the width parameter from the Get call.
+ --
+ -- There are two cases, if Width is non-zero, then a check is made that
+ -- the remainder of the field is all blanks. If Width is zero, then it
+ -- means that the scan routine scanned out only part of the field. We
+ -- have already scanned out the field that the ACVC tests seem to expect
+ -- us to read (even if it does not follow the syntax of the type being
+ -- scanned, e.g. allowing negative exponents in integers, and underscores
+ -- at the end of the string), so we just raise Data_Error.
+
+ procedure Check_On_One_Line (File : File_Type; Length : Integer);
+ -- Check to see if item of length Integer characters can fit on
+ -- current line. Call New_Line if not, first checking that the
+ -- line length can accommodate Length characters, raise Layout_Error
+ -- if item is too large for a single line.
+
+ function Is_Blank (C : Character) return Boolean;
+ -- Determines if C is a blank (space or tab)
+
+ procedure Load_Width
+ (File : File_Type;
+ Width : Field;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Loads exactly Width characters, unless a line mark is encountered first
+
+ procedure Load_Skip (File : File_Type);
+ -- Skips leading blanks and line and page marks, if the end of file is
+ -- read without finding a non-blank character, then End_Error is raised.
+ -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)).
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character;
+ Loaded : out Boolean);
+ -- If next character is Char, loads it, otherwise no characters are loaded
+ -- Loaded is set to indicate whether or not the character was found.
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character;
+ Loaded : out Boolean);
+ -- If next character is Char1 or Char2, loads it, otherwise no characters
+ -- are loaded. Loaded is set to indicate whether or not one of the two
+ -- characters was found.
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean);
+ -- Loads a sequence of zero or more decimal digits. Loaded is set if
+ -- at least one digit is loaded.
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean);
+ -- Like Load_Digits, but also allows extended digits a-f and A-F
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Put_Item (File : File_Type; Str : String);
+ -- This routine is like Wide_Wide_Text_IO.Put, except that it checks for
+ -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used
+ -- for all output of numeric values and of enumeration values. Note that
+ -- the buffer is of type String. Put_Item deals with converting this to
+ -- Wide_Wide_Characters as required.
+
+ procedure Store_Char
+ (File : File_Type;
+ ch : Integer;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Store a single character in buffer, checking for overflow and
+ -- adjusting the column number in the file to reflect the fact
+ -- that a character has been acquired from the input stream.
+ -- The pos value of the character to store is in ch on entry.
+
+ procedure String_Skip (Str : String; Ptr : out Integer);
+ -- Used in the Get from string procedures to skip leading blanks in the
+ -- string. Ptr is set to the index of the first non-blank. If the string
+ -- is all blanks, then the excption End_Error is raised, Note that blank
+ -- is defined as a space or horizontal tab (RM A.10.6(5)).
+
+ procedure Ungetc (ch : Integer; File : File_Type);
+ -- Pushes back character into stream, using ungetc. The caller has
+ -- checked that the file is in read status. Device_Error is raised
+ -- if the character cannot be pushed back. An attempt to push back
+ -- an end of file (EOF) is ignored.
+
+private
+ pragma Inline (Is_Blank);
+
+end Ada.Wide_Wide_Text_IO.Generic_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
+
+package body Ada.Wide_Wide_Text_IO.Integer_Aux is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Load_Integer
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load an possibly signed
+ -- integer literal value from the input file into Buf, starting at Ptr + 1.
+ -- On return, Ptr is set to the last character stored.
+
+ -------------
+ -- Get_Int --
+ -------------
+
+ procedure Get_Int
+ (File : File_Type;
+ Item : out Integer;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer := 1;
+ Stop : Integer := 0;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Integer (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Integer (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ end Get_Int;
+
+ -------------
+ -- Get_LLI --
+ -------------
+
+ procedure Get_LLI
+ (File : File_Type;
+ Item : out Long_Long_Integer;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer := 1;
+ Stop : Integer := 0;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Integer (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ end Get_LLI;
+
+ --------------
+ -- Gets_Int --
+ --------------
+
+ procedure Gets_Int
+ (From : String;
+ Item : out Integer;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Integer (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ raise Data_Error;
+ end Gets_Int;
+
+ --------------
+ -- Gets_LLI --
+ --------------
+
+ procedure Gets_LLI
+ (From : String;
+ Item : out Long_Long_Integer;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ raise Data_Error;
+ end Gets_LLI;
+
+ ------------------
+ -- Load_Integer --
+ ------------------
+
+ procedure Load_Integer
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Integer;
+
+ -------------
+ -- Put_Int --
+ -------------
+
+ procedure Put_Int
+ (File : File_Type;
+ Item : Integer;
+ Width : Field;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Integer (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Integer (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Int;
+
+ -------------
+ -- Put_LLI --
+ -------------
+
+ procedure Put_LLI
+ (File : File_Type;
+ Item : Long_Long_Integer;
+ Width : Field;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Long_Long_Integer (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLI;
+
+ --------------
+ -- Puts_Int --
+ --------------
+
+ procedure Puts_Int
+ (To : out String;
+ Item : Integer;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_Int;
+
+ --------------
+ -- Puts_LLI --
+ --------------
+
+ procedure Puts_LLI
+ (To : out String;
+ Item : Long_Long_Integer;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLI;
+
+end Ada.Wide_Wide_Text_IO.Integer_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO
+-- that are shared among separate instantiations of this package. The
+-- routines in this package are identical semantically to those in Integer_IO
+-- itself, except that the generic parameter Num has been replaced by Integer
+-- or Long_Long_Integer, and the default parameters have been removed because
+-- they are supplied explicitly by the calls from within the generic template.
+
+private package Ada.Wide_Wide_Text_IO.Integer_Aux is
+
+ procedure Get_Int
+ (File : File_Type;
+ Item : out Integer;
+ Width : Field);
+
+ procedure Get_LLI
+ (File : File_Type;
+ Item : out Long_Long_Integer;
+ Width : Field);
+
+ procedure Gets_Int
+ (From : String;
+ Item : out Integer;
+ Last : out Positive);
+
+ procedure Gets_LLI
+ (From : String;
+ Item : out Long_Long_Integer;
+ Last : out Positive);
+
+ procedure Put_Int
+ (File : File_Type;
+ Item : Integer;
+ Width : Field;
+ Base : Number_Base);
+
+ procedure Put_LLI
+ (File : File_Type;
+ Item : Long_Long_Integer;
+ Width : Field;
+ Base : Number_Base);
+
+ procedure Puts_Int
+ (To : out String;
+ Item : Integer;
+ Base : Number_Base);
+
+ procedure Puts_LLI
+ (To : out String;
+ Item : Long_Long_Integer;
+ Base : Number_Base);
+
+end Ada.Wide_Wide_Text_IO.Integer_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Integer_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Integer_IO is
+
+ Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
+ -- Throughout this generic body, we distinguish between the case
+ -- where type Integer is acceptable, and where a Long_Long_Integer
+ -- is needed. This constant Boolean is used to test for these cases
+ -- and since it is a constant, only the code for the relevant case
+ -- will be included in the instance.
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Wide_Text_IO.Integer_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ if Need_LLI then
+ Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width);
+ else
+ Aux.Get_Int (TFT (File), Integer (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need_LLI then
+ Aux.Gets_LLI (S, Long_Long_Integer (Item), Last);
+ else
+ Aux.Gets_Int (S, Integer (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLI then
+ Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base);
+ else
+ Aux.Put_Int (TFT (File), Integer (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Output, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Base : Number_Base := Default_Base)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need_LLI then
+ Aux.Puts_LLI (S, Long_Long_Integer (Item), Base);
+ else
+ Aux.Puts_Int (S, Integer (Item), Base);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Integer_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Integer_IO is a subpackage
+-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading
+-- the necessary code if Integer_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is range <>;
+
+package Ada.Wide_Wide_Text_IO.Integer_IO is
+
+ Default_Width : Field := Num'Width;
+ Default_Base : Number_Base := 10;
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0);
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base);
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base);
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Base : Number_Base := Default_Base);
+
+end Ada.Wide_Wide_Text_IO.Integer_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
+
+package body Ada.Wide_Wide_Text_IO.Modular_Aux is
+
+ use System.Unsigned_Types;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Load_Modular
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load an possibly signed
+ -- modular literal value from the input file into Buf, starting at Ptr + 1.
+ -- Ptr is left set to the last character stored.
+
+ -------------
+ -- Get_LLU --
+ -------------
+
+ procedure Get_LLU
+ (File : File_Type;
+ Item : out Long_Long_Unsigned;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Modular (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ end Get_LLU;
+
+ -------------
+ -- Get_Uns --
+ -------------
+
+ procedure Get_Uns
+ (File : File_Type;
+ Item : out Unsigned;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Modular (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Unsigned (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ end Get_Uns;
+
+ --------------
+ -- Gets_LLU --
+ --------------
+
+ procedure Gets_LLU
+ (From : String;
+ Item : out Long_Long_Unsigned;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ raise Data_Error;
+ end Gets_LLU;
+
+ --------------
+ -- Gets_Uns --
+ --------------
+
+ procedure Gets_Uns
+ (From : String;
+ Item : out Unsigned;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Unsigned (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ raise Data_Error;
+ end Gets_Uns;
+
+ ------------------
+ -- Load_Modular --
+ ------------------
+
+ procedure Load_Modular
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+
+ -- Note: it is a bit strange to allow a minus sign here, but it seems
+ -- consistent with the general behavior expected by the ACVC tests
+ -- which is to scan past junk and then signal data error, see ACVC
+ -- test CE3704F, case (6), which is for signed integer exponents,
+ -- which seems a similar case.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants
+ -- for the signed case, and there seems no good reason to treat
+ -- exponents differently for the signed and unsigned cases.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Modular;
+
+ -------------
+ -- Put_LLU --
+ -------------
+
+ procedure Put_LLU
+ (File : File_Type;
+ Item : Long_Long_Unsigned;
+ Width : Field;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Long_Long_Unsigned (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLU;
+
+ -------------
+ -- Put_Uns --
+ -------------
+
+ procedure Put_Uns
+ (File : File_Type;
+ Item : Unsigned;
+ Width : Field;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Unsigned (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Unsigned (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Uns;
+
+ --------------
+ -- Puts_LLU --
+ --------------
+
+ procedure Puts_LLU
+ (To : out String;
+ Item : Long_Long_Unsigned;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLU;
+
+ --------------
+ -- Puts_Uns --
+ --------------
+
+ procedure Puts_Uns
+ (To : out String;
+ Item : Unsigned;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_Uns;
+
+end Ada.Wide_Wide_Text_IO.Modular_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Wide_Text_IO.Modular_IO
+-- that are shared among separate instantiations of this package. The
+-- routines in this package are identical semantically to those in Modular_IO
+-- itself, except that the generic parameter Num has been replaced by
+-- Unsigned or Long_Long_Unsigned, and the default parameters have been
+-- removed because they are supplied explicitly by the calls from within the
+-- generic template.
+
+with System.Unsigned_Types;
+
+private package Ada.Wide_Wide_Text_IO.Modular_Aux is
+
+ package U renames System.Unsigned_Types;
+
+ procedure Get_Uns
+ (File : File_Type;
+ Item : out U.Unsigned;
+ Width : Field);
+
+ procedure Get_LLU
+ (File : File_Type;
+ Item : out U.Long_Long_Unsigned;
+ Width : Field);
+
+ procedure Gets_Uns
+ (From : String;
+ Item : out U.Unsigned;
+ Last : out Positive);
+
+ procedure Gets_LLU
+ (From : String;
+ Item : out U.Long_Long_Unsigned;
+ Last : out Positive);
+
+ procedure Put_Uns
+ (File : File_Type;
+ Item : U.Unsigned;
+ Width : Field;
+ Base : Number_Base);
+
+ procedure Put_LLU
+ (File : File_Type;
+ Item : U.Long_Long_Unsigned;
+ Width : Field;
+ Base : Number_Base);
+
+ procedure Puts_Uns
+ (To : out String;
+ Item : U.Unsigned;
+ Base : Number_Base);
+
+ procedure Puts_LLU
+ (To : out String;
+ Item : U.Long_Long_Unsigned;
+ Base : Number_Base);
+
+end Ada.Wide_Wide_Text_IO.Modular_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Modular_Aux;
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Modular_IO is
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Wide_Text_IO.Modular_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width);
+ else
+ Aux.Get_Uns (TFT (File), Unsigned (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last);
+ else
+ Aux.Gets_Uns (S, Unsigned (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ else
+ Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Output, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Base : Number_Base := Default_Base)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base);
+ else
+ Aux.Puts_Uns (S, Unsigned (Item), Base);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Modular_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Modular_IO is a subpackage of
+-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading the
+-- necessary code if Modular_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is mod <>;
+
+package Ada.Wide_Wide_Text_IO.Modular_IO is
+
+ Default_Width : Field := Num'Width;
+ Default_Base : Number_Base := 10;
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0);
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base);
+
+ procedure Put
+ (Item : Num;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base);
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Base : Number_Base := Default_Base);
+
+end Ada.Wide_Wide_Text_IO.Modular_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.File_IO;
+
+package body Ada.Wide_Wide_Text_IO.Text_Streams is
+
+ ------------
+ -- Stream --
+ ------------
+
+ function Stream (File : File_Type) return Stream_Access is
+ begin
+ System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File));
+ return Stream_Access (File);
+ end Stream;
+
+end Ada.Wide_Wide_Text_IO.Text_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Streams;
+
+package Ada.Wide_Wide_Text_IO.Text_Streams is
+
+ type Stream_Access is access all Streams.Root_Stream_Type'Class;
+
+ function Stream (File : File_Type) return Stream_Access;
+
+end Ada.Wide_Wide_Text_IO.Text_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_UNBOUNDED_IO --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: historically GNAT provided these subprograms as a child of the
+-- package Ada.Strings.Wide_Wide_Unbounded. So we implement this new Ada 2005
+-- package by renaming the subprograms in that child. This is a more
+-- straightforward implementation anyway, since we need access to the
+-- internal representation of Unbounded_Wide_Wide_String.
+
+
+with Ada.Strings.Wide_Wide_Unbounded;
+with Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO;
+
+package Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO is
+
+ procedure Put
+ (File : File_Type;
+ Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String)
+ renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put;
+
+ procedure Put
+ (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String)
+ renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put;
+
+ procedure Put_Line
+ (File : Wide_Wide_Text_IO.File_Type;
+ Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String)
+ renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line;
+
+ procedure Put_Line
+ (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String)
+ renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line;
+
+ function Get_Line
+ (File : File_Type)
+ return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String
+ renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line;
+
+ function Get_Line
+ return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String
+ renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line;
+
+ procedure Get_Line
+ (File : File_Type;
+ Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String)
+ renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line;
+
+ procedure Get_Line
+ (Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String)
+ renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line;
+
+end Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO;
projects / platform / upstream / gcc.git / commitdiff