-- The Ada Structured Library - A set of container classes and general -- tools for use with Ada95. -- Copyright (C) 1998-1999 Corey Minyard (minyard@acm.org) -- -- This library is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2 of the License, or (at your -- option) any later version. -- -- This library is distributed in the hope that it will be useful, but -- WITHOUT 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 along -- with this library; if not, write to the Free Software Foundation, Inc., -- 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. -- with Ada.Unchecked_Deallocation; package body Asgc.Ordered.Alist.CTYPEMANAGED is procedure Free_Iterator is new Ada.Unchecked_Deallocation (Iterator, Iterator_Ptr); --$START EXPANDABLE procedure Free is new Ada.Unchecked_Deallocation (Vector_Array, Vector_Array_Ptr); --$END EXPANDABLE -- An Array List (AList) is a circular data structure implemented with -- an array. It has a Head and a Tail. The Head is the first item in -- the list and the Tail is one past the end of the list. Because of -- this layout, if Head and Tail are equal then the list is empty. -- However, this means that the code here must always leave one empty -- item in the list, since if the last element was filled in then Head -- would equal Tail again. -- -- When operating on this data structure, remember that the data can -- "wrap" around the end of the array. So we might have the instance: -- -- Head Tail -- +-------------------------------------------------+ -- + |******************| + -- +-------------------------------------------------+ -- -- which is the easy case, where Head < Tail. However, if we have a -- wrap, we have something like: -- -- Tail Head -- +-------------------------------------------------+ -- +************| |*****************+ -- +-------------------------------------------------+ -- -- where Tail < Head. -- ------------------------------------------------------------------------ -- Move to the next value in the object, wrapping around the array if -- necessary. function Next (O : in Object'Class; V : in Positive) return Positive is begin if (V = AREF(O.Data)'Last) then return AREF(O.Data)'First; else return V + 1; end if; end Next; ------------------------------------------------------------------------ -- Move to the previous value in the object, wrapping around the array -- if necessary. function Prev (O : in Object'Class; V : in Positive) return Positive is begin if (V = AREF(O.Data)'First) then return AREF(O.Data)'Last; else return V - 1; end if; end Prev; --$START EXPANDABLE ------------------------------------------------------------------------ -- Increase the size of an expandable vector. procedure Increase_Vector_Size (O : in out Object'Class) is New_Vector : Vector_Array_Ptr; Last_Entry : Positive; New_Head : Positive; begin if (O.Increment = 0) then raise Container_Full; end if; Last_Entry := Prev(O, O.Tail); New_Vector := new Vector_Array(1 .. O.Data.all'Last + O.Increment); if (O.Head < Last_Entry) then New_Vector.all(1 .. O.Data'Last) := O.Data.all; O.Tail := Next(O, Last_Entry); else New_Head := O.Head + O.Increment; New_Vector.all(1 .. Last_Entry) := O.Data.all(1 .. Last_Entry); New_Vector.all(New_Head .. New_Vector.all'Last) := O.Data.all(O.Head .. O.Data.all'Last); O.Head := New_Head; end if; Free(O.Data); O.Data := New_Vector; end Increase_Vector_Size; --$END EXPANDABLE ------------------------------------------------------------------------ -- Check that an object is valid, that is has not been freed. This is -- not a perfect check, but will hopefully help find some bugs. procedure Check_Object (O : in Object'Class) is begin if (O.Is_Free) then raise Object_Free; end if; end Check_Object; ------------------------------------------------------------------------ -- Check that an iterator is valid. It must not have been freed, it -- must be initialized, its object must be valid, and it must not have -- been modified since the last time the iterator was positioned. procedure Check_Iterator (Iter : in Iterator) is begin if (Iter.Is_Free) then raise Iterator_Free; end if; if (Iter.Robj = null) then raise Invalid_Iterator; end if; Check_Object(Iter.Robj.all); if (Iter.Update /= Iter.Robj.Update) then raise Object_Updated; end if; if (Iter.Robj.Head < Iter.Robj.Tail) then if ((Iter.Pos < Iter.Robj.Head) or (Iter.Pos >= Iter.Robj.Tail)) then raise Invalid_Iterator; end if; elsif (Iter.Robj.Head > Iter.Robj.Tail) then if ((Iter.Pos < Iter.Robj.Head) and (Iter.Pos >= Iter.Robj.Tail)) then raise Invalid_Iterator; end if; else raise Invalid_Iterator; end if; end Check_Iterator; ------------------------------------------------------------------------ -- Check that an iterator is valid. It must not have been freed, it -- must be initialized, its object must be valid, and it must not have -- been modified since the last time the iterator was positioned. -- This routine allows the object to be empty. procedure Check_Iterator_Empty_Ok (Iter : in Iterator) is begin if (Iter.Is_Free) then raise Iterator_Free; end if; if (Iter.Robj = null) then raise Invalid_Iterator; end if; Check_Object(Iter.Robj.all); if (Iter.Update /= Iter.Robj.Update) then raise Object_Updated; end if; if (Iter.Robj.Head < Iter.Robj.Tail) then if ((Iter.Pos < Iter.Robj.Head) or (Iter.Pos >= Iter.Robj.Tail)) then raise Invalid_Iterator; end if; elsif (Iter.Robj.Head > Iter.Robj.Tail) then if ((Iter.Pos < Iter.Robj.Head) and (Iter.Pos >= Iter.Robj.Tail)) then raise Invalid_Iterator; end if; end if; end Check_Iterator_Empty_Ok; ------------------------------------------------------------------------ -- Check an iterator, but don't bother checking its positions. This is -- primarily for methods that set some the position of the iterator. procedure Check_Iterator_No_Pos (Iter : in Iterator) is begin if (Iter.Is_Free) then raise Iterator_Free; end if; if (Iter.Robj = null) then raise Invalid_Iterator; end if; Check_Object(Iter.Robj.all); end Check_Iterator_No_Pos; ------------------------------------------------------------------------ -- Return the number of items in the container, doing special -- calculations if it is a wrap. function Count (O : in Object'Class) return Natural is begin if (O.Head <= O.Tail) then return O.Tail - O.Head; else return ((AREF(O.Data)'Last - O.Head + 1) + (O.Tail - AREF(O.Data)'First)); end if; end Count; ------------------------------------------------------------------------ -- Convert a location in the container (the Nth item in the container -- from the user's point of view) into an index into the array. function Get_Pos (O : in Object'Class; Loc : in Positive) return Positive is Pos : Positive; begin if (Loc > Count(O)) then raise Constraint_Error; end if; Pos := O.Head + Loc - 1; if (Pos > AREF(O.Data)'Last) then Pos := Pos - AREF(O.Data)'Last; end if; return Pos; end Get_Pos; ------------------------------------------------------------------------ -- Convert a location in the container (the Nth item in the container -- from the user's point of view) into an index into the array. Allow -- it to go one past the end for addition of elements. function Get_Pos_Allow_Addition (O : in Object'Class; Loc : in Positive) return Positive is Pos : Positive; begin if (Loc > (Count(O) + 1)) then raise Constraint_Error; end if; Pos := O.Head + Loc - 1; if (Pos > AREF(O.Data)'Last) then Pos := Pos - AREF(O.Data)'Last; end if; return Pos; end Get_Pos_Allow_Addition; ------------------------------------------------------------------------ -- Convert an array index into a location in the container. function Get_Loc (O : in Object'Class; Pos : in Positive) return Natural is Loc : Positive; begin if (Pos < O.Head) then -- It's a wrap around case. Loc := ((Pos - AREF(O.Data)'First) + (AREF(O.Data)'Last - O.Head) + 2); else Loc := Pos - O.Head + 1; end if; return Loc; end Get_Loc; ------------------------------------------------------------------------ -- Add an item at the specified position in the array. Although the -- location (Loc) of the value will not be changed, the position (Pos) -- might be moved depending on how the operation worked. The new Pos -- is returned in that parameter. procedure Perform_Add (O : in out Object'Class; Loc : in Positive; Pos : in out Positive; Val : in Contained_Type) is After_Tail : Positive; Prev_Pos : Positive; Curr_Pos : Positive; begin After_Tail := Next(O, O.Tail); if (After_Tail = O.Head) then -- Container is full. --$START EXPANDABLE Increase_Vector_Size(O); After_Tail := Next(O, O.Tail); Pos := Get_Pos_Allow_Addition(O, Loc); --$END EXPANDABLE --$START FIXED raise Container_Full; --$END FIXED end if; if (Pos = O.Tail) then -- Optimize for tail, just add it at the end. O.Tail := After_Tail; elsif (Pos = O.Head) then -- Optimize for head, just move the head index back one and put it -- there. Pos := Prev(O, Pos); O.Head := Pos; elsif (Loc < (Count(O) / 2)) then -- We are putting it in the first half of the data, so it is less -- work to move the beginning data back one. Pos := Prev(O, Pos); Prev_Pos := Prev(O, O.Head); Curr_Pos := O.Head; O.Head := Prev_Pos; loop O.Data(Prev_Pos) := O.Data(Curr_Pos); exit when (Curr_Pos = Pos); Prev_Pos := Curr_Pos; Curr_Pos := Next(O, Curr_Pos); end loop; else -- We are putting it in the second half of the data, so move -- everything after the position forward one. Prev_Pos := O.Tail; Curr_Pos := Prev(O, O.Tail); loop O.Data(Prev_Pos) := O.Data(Curr_Pos); exit when (Curr_Pos = Pos); Prev_Pos := Curr_Pos; Curr_Pos := Prev(O, Curr_Pos); end loop; O.Tail := After_Tail; end if; O.Data(Pos) := Val; O.Update := O.Update + 1; if (O.Cb /= null) then Added(O.Cb, O, O.Data(Pos)); end if; end Perform_Add; ------------------------------------------------------------------------ -- Delete the specified position in the array. The Pos will reference -- the next position in the array after the value was removed, unless -- we delete the tail. procedure Delete_Pos (O : in out Object'Class; Pos : in out Positive; Loc : in Positive) is Deleted_Val : Contained_Type; Prev_Pos : Positive; Curr_Pos : Positive; begin Deleted_Val := O.Data(Pos); if (Pos = O.Head) then O.Head := Next(O, O.Head); Pos := O.Head; elsif (Pos = O.Tail) then O.Tail := Prev(O, O.Tail); elsif (Loc < (Count(O) / 2)) then -- It's faster to move all the data up one from the head. Curr_Pos := Prev(O, Pos); Prev_Pos := Pos; while (Prev_Pos /= O.Head) loop O.Data(Prev_Pos) := O.Data(Curr_Pos); Prev_Pos := Curr_Pos; Curr_Pos := Prev(O, Curr_Pos); end loop; O.Head := Next(O, Prev_Pos); Pos := Next(O, Pos); else -- It's faster to move all the back one from the tail. Curr_Pos := Next(O, Pos); Prev_Pos := Pos; while (Prev_Pos /= O.Tail) loop O.Data(Prev_Pos) := O.Data(Curr_Pos); Prev_Pos := Curr_Pos; Curr_Pos := Next(O, Curr_Pos); end loop; O.Tail := Prev(O, Prev_Pos); end if; O.Update := O.Update + 1; if (O.Cb /= null) then Deleted(O.Cb, O, Deleted_Val); end if; end Delete_Pos; ------------------------------------------------------------------------ -- This is a controlled type, so we have those methods to handle. ------------------------------------------------------------------------ procedure Initialize (O : in out Object) is begin null; end Initialize; ------------------------------------------------------------------------ procedure Adjust (O : in out Object) is --$START EXPANDABLE Old_Vector : Vector_Array_Ptr := O.Data; Last_Entry : Positive; --$END EXPANDABLE Curr : Positive; begin --$START EXPANDABLE O.Data := new Vector_Array(Old_Vector.all'Range); Last_Entry := Prev(O, O.Tail); if (O.Head < Last_Entry) then -- Not a wrap around, so a simple assignment will do. O.Data.all(O.Head .. Last_Entry) := Old_Vector(O.Head .. Last_Entry); elsif(O.Head > Last_Entry) then -- A wraparound case, so we need to assign each end of the array. O.Data.all(O.Head .. O.Data.all'Last) := Old_Vector(O.Head .. O.Data.all'Last); O.Data.all(O.Data.all'First .. Last_Entry) := Old_Vector(O.Data.all'First .. Last_Entry); end if; --$END EXPANDABLE -- Call the Copied callback on each new element if the container has -- a callback set. if (O.Cb /= null) then Curr := O.Head; while (Curr /= O.Tail) loop Copied(O.Cb, O, O.Data(Curr)); Curr := Next(O, Curr); end loop; end if; end Adjust; ------------------------------------------------------------------------ procedure Finalize (O : in out Object) is Curr : Positive := O.Head; begin O.Is_Free := True; if (O.Cb /= null) then while (Curr /= O.Tail) loop Deleted(O.Cb, O, O.Data(Curr)); Curr := Next(O, Curr); end loop; end if; --$START EXPANDABLE Free(O.Data); --$END EXPANDABLE end Finalize; ------------------------------------------------------------------------ procedure Finalize (Iter : in out Iterator) is begin Iter.Is_Free := True; end Finalize; ------------------------------------------------------------------------ -- The functions that follow are defined as abstract in previous -- packages. See those packages for descriptions of what these -- methods do. ------------------------------------------------------------------------ function "=" (O1, O2 : in Object) return Boolean is Curr1, Curr2 : Positive; begin if (Count(O1) /= Count(O2)) then return False; else Curr1 := O1.Head; Curr2 := O2.Head; while (Curr1 /= O1.Tail) loop if (O1.Data(Curr1) /= O2.Data(Curr2)) then return False; end if; Curr1 := Next(O1, Curr1); Curr2 := Next(O2, Curr2); end loop; end if; return True; end "="; ------------------------------------------------------------------------ procedure Verify_Integrity (O : in Object) is begin -- Integrity of an AList doesn't really apply. Check_Object(O); end Verify_Integrity; ------------------------------------------------------------------------ function Copy (O : in Object) return Asgc.Object_Class is Retval : Object_Ptr; begin --$START FIXED Retval := new Object(Size => O.Size); --$END FIXED --$START EXPANDABLE Retval := new Object(Initial_Size => O.Initial_Size, Increment => O.Increment); --$END EXPANDABLE Retval.all := O; return Asgc.Object_Class(Retval); end Copy; ------------------------------------------------------------------------ function Member_Count (O : in Object) return Natural is begin return Count(O); end Member_Count; ------------------------------------------------------------------------ procedure Add_At (O : in out Object; Loc : in Positive; Val : in Contained_Type) is Pos : Positive; begin Check_Object(O); Pos := Get_Pos_Allow_Addition(O, Loc); Perform_Add(O, Loc, Pos, Val); end Add_At; ------------------------------------------------------------------------ procedure Set_At (O : in out Object; Loc : in Positive; Val : in Contained_Type) is Pos : Positive; Old_Val : Contained_Type; begin Check_Object(O); Pos := Get_Pos(O, Loc); Old_Val := O.Data(Pos); O.Data(Pos) := Val; -- Add then delete the values in case these are the same value. This -- can avoid some nasty side effects. if (O.Cb /= null) then Added(O.Cb, O, O.Data(Pos)); end if; if (O.Cb /= null) then Deleted(O.Cb, O, Old_Val); end if; end Set_At; ------------------------------------------------------------------------ function Get_At (O : in Object; Loc : in Positive) return Contained_Type is Pos : Positive; begin Check_Object(O); Pos := Get_Pos(O, Loc); return O.Data(Pos); end Get_At; ------------------------------------------------------------------------ procedure Swap_At (O : in out Object; Loc1, Loc2 : in Positive) is Tmp : Contained_Type; Pos1 : Positive; Pos2 : Positive; begin Check_Object(O); Pos1 := Get_Pos(O, Loc1); Pos2 := Get_Pos(O, Loc2); Tmp := O.Data(Pos1); O.Data(Pos1) := O.Data(Pos2); O.Data(Pos2) := Tmp; end Swap_At; ------------------------------------------------------------------------ procedure Delete_At (O : in out Object; Loc : in Positive) is Pos : Positive; begin Check_Object(O); Pos := Get_Pos(O, Loc); Delete_Pos(O, Pos, Loc); end Delete_At; ------------------------------------------------------------------------ procedure Delete (O : in out Object; Val : in Contained_Type) is Curr : Positive; begin Check_Object(O); Curr := O.Head; while (Curr /= O.Tail) loop if (O.Data(Curr) = Val) then Delete_Pos(O, Curr, Get_Loc(O, Curr)); return; end if; Curr := Next(O, Curr); end loop; raise Item_Not_Found; end Delete; ------------------------------------------------------------------------ function Value_Exists (O : in Object; Val : in Contained_Type) return Boolean is Curr : Positive; begin Check_Object(O); Curr := O.Head; while (Curr /= O.Tail) loop if (O.Data(Curr) = Val) then return True; end if; Curr := Next(O, Curr); end loop; return False; end Value_Exists; ------------------------------------------------------------------------ procedure Push (O : in out Object; Val : in Contained_Type) is begin Add_At(O, 1, Val); end Push; ------------------------------------------------------------------------ procedure Pop (O : in out Object; Val : out Contained_Type) is begin Val := Get_At(O, 1); Delete_At(O, 1); end Pop; ------------------------------------------------------------------------ procedure Enqueue (O : in out Object; Val : in Contained_Type) is New_Pos : Positive := O.Tail; begin Check_Object(O); -- We directly put the value at the tail index, it's a little faster -- than computing the end location and adding there. Perform_Add(O, Get_Loc(O, O.Tail), New_Pos, Val); end Enqueue; ------------------------------------------------------------------------ procedure Dequeue (O : in out Object; Val : out Contained_Type) is begin Val := Get_At(O, 1); Delete_At(O, 1); end Dequeue; ------------------------------------------------------------------------ function New_Iterator (O : access Object) return Asgc.Iterator_Class is Retval : Iterator_Ptr; begin Check_Object(O.all); Retval := new Iterator; Retval.Robj := Object_Class(O); return Asgc.Iterator_Class(Retval); end New_Iterator; ------------------------------------------------------------------------ function New_Iterator (O : in Object_class) return Iterator is Retval : Iterator; begin Retval.Robj := O; return Retval; end New_Iterator; ------------------------------------------------------------------------ procedure Free (Iter : access Iterator) is To_Free : Iterator_Ptr := Iterator_Ptr(Iter); begin if (Iter.Is_Free) then raise Iterator_Free; end if; Free_Iterator(To_Free); end Free; ------------------------------------------------------------------------ procedure Set_Container (Iter : in out Iterator; O : in Asgc.Object_Class) is begin Check_Object(Object'Class(O.all)); Iter.Robj := Object_Class(O); Iter.Update := Invalid_Update; end Set_Container; ------------------------------------------------------------------------ procedure First (Iter : in out Iterator; Is_End : out End_Marker) is begin Check_Iterator_No_Pos(Iter); if (Iter.Robj.Head = Iter.Robj.Tail) then Iter.Pos := Prev(Iter.Robj.all, Iter.Robj.Head); else Iter.Pos := Iter.Robj.Head; end if; Iter.Update := Iter.Robj.Update; if (Iter.Robj.Head = Iter.Robj.Tail) then Is_End := Past_End; else Is_End := Not_Past_End; end if; end First; ------------------------------------------------------------------------ procedure Next (Iter : in out Iterator; Is_End : out End_Marker) is Next_Pos : Positive; begin Check_Iterator(Iter); Next_Pos := Next(Iter.Robj.all, Iter.Pos); if (Next_Pos = Iter.Robj.Tail) then Is_End := Past_End; else Iter.Pos := Next_Pos; Is_End := Not_Past_End; end if; end Next; ------------------------------------------------------------------------ procedure Delete (Iter : in out Iterator; Is_End : out End_Marker) is begin Check_Iterator(Iter); if (Iter.Pos = Iter.Robj.Tail) then Delete_Pos(Iter.Robj.all, Iter.Pos, Get_Loc(Iter.Robj.all, Iter.Pos)); Is_End := Past_End; else Delete_Pos(Iter.Robj.all, Iter.Pos, Get_Loc(Iter.Robj.all, Iter.Pos)); Iter.Update := Iter.Robj.Update; Is_End := Not_Past_End; end if; end Delete; ------------------------------------------------------------------------ function Is_Same (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator_Empty_Ok(Iter1); Check_Iterator_Empty_Ok(Iter2); if (Iter1.Robj /= Iter2.Robj) then raise Iterator_Mismatch; end if; return (Iter1.Pos = Iter2.Pos); end Is_Same; ------------------------------------------------------------------------ function Get (Iter : in Iterator) return Contained_Type is begin Check_Iterator(Iter); return Iter.Robj.Data(Iter.Pos); end Get; ------------------------------------------------------------------------ procedure Get_Incr (Iter : in out Iterator; Val : out Contained_Type; Is_End : out End_Marker) is begin Check_Iterator(Iter); Val := Iter.Robj.Data(Iter.Pos); Next(Iter, Is_End); end Get_Incr; ------------------------------------------------------------------------ function "=" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Robj.Data(Iter1.Pos) = Iter2.Robj.Data(Iter2.Pos)); end "="; ------------------------------------------------------------------------ function "=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Robj.Data(Iter.Pos) = Val); end "="; ------------------------------------------------------------------------ function "=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Iter.Robj.Data(Iter.Pos) = Val); end "="; ------------------------------------------------------------------------ procedure Last (Iter : in out Iterator; Is_End : out End_Marker) is begin Check_Iterator_No_Pos(Iter); Iter.Update := Iter.Robj.Update; if (Iter.Robj.Head = Iter.Robj.Tail) then Iter.Pos := Prev(Iter.Robj.all, Iter.Robj.Head); Is_End := Past_End; else Iter.Pos := Prev(Iter.Robj.all, Iter.Robj.Tail); Is_End := Not_Past_End; end if; end Last; ------------------------------------------------------------------------ procedure Prev (Iter : in out Iterator; Is_End : out End_Marker) is begin Check_Iterator(Iter); if (Iter.Pos = Iter.Robj.Head) then Is_End := Past_End; else Is_End := Not_Past_End; Iter.Pos := Prev(Iter.Robj.all, Iter.Pos); end if; end Prev; ------------------------------------------------------------------------ procedure Set_Loc (Iter : out Iterator; Loc : in Positive) is Pos : Positive; begin Check_Iterator_No_Pos(Iter); Pos := Get_Pos(Iter.Robj.all, Loc); Iter.Update := Iter.Robj.Update; Iter.Pos := Pos; end Set_Loc; ------------------------------------------------------------------------ function Get_Loc (Iter : in Iterator) return Natural is begin Check_Iterator_Empty_Ok(Iter); return Get_Loc(Iter.Robj.all, Iter.Pos); end Get_Loc; ------------------------------------------------------------------------ function Is_After (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator_Empty_Ok(Iter1); Check_Iterator_Empty_Ok(Iter2); if (Iter1.Robj /= Iter2.Robj) then raise Iterator_Mismatch; end if; -- If we divide the array in to three regions, we have a wraparound -- condition if: -- Tail Head -- +-------------------------------------------------+ -- +xxxxxxxxxxxx| |xxxxxxxxxxxxxxxxx+ -- +-------------------------------------------------+ -- -- Where the xxx is where valid data is and the blank space is -- unused. The first two cases of the following if/elsif/else handle -- this condition, if one iterator is in one region and the other -- iterator is in the other region, the answer is static. Otherwise, -- they are both in the same region and a straight comparison is valid. if ((Iter1.Pos >= Iter1.Robj.Head) and (Iter2.Pos < Iter1.Robj.Tail)) then return False; elsif ((Iter1.Pos < Iter1.Robj.Head) and (Iter2.Pos > Iter1.Robj.Tail)) then return True; else return (Iter1.Pos > Iter2.Pos); end if; end Is_After; ------------------------------------------------------------------------ function Is_Before (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator_Empty_Ok(Iter1); Check_Iterator_Empty_Ok(Iter2); if (Iter1.Robj /= Iter2.Robj) then raise Iterator_Mismatch; end if; -- See Is_After for an explanation of how this works. if ((Iter1.Pos >= Iter1.Robj.Head) and (Iter2.Pos < Iter1.Robj.Tail)) then return True; elsif ((Iter1.Pos < Iter1.Robj.Head) and (Iter2.Pos > Iter1.Robj.Tail)) then return False; else return (Iter1.Pos < Iter2.Pos); end if; end Is_Before; ------------------------------------------------------------------------ function "+" (Iter : in Iterator; Offset : in Integer) return Iterator is New_Iterator : Iterator; Loc : Positive; begin Check_Iterator_Empty_Ok(Iter); Loc := Get_Loc(Iter.Robj.all, Iter.Pos); if (Offset >= 0) then if ((Loc + Offset) > Count(Iter.Robj.all)) then raise Constraint_Error; end if; New_Iterator.Pos := Iter.Pos + Offset; if (New_Iterator.Pos > AREF(Iter.Robj.Data)'Last) then New_Iterator.Pos := New_Iterator.Pos - AREF(Iter.Robj.Data)'Last; end if; else if (Loc <= -Offset) then raise Constraint_Error; end if; if (Iter.Pos < -Offset) then New_Iterator.Pos := Iter.Pos + AREF(Iter.Robj.Data)'Last + Offset; else New_Iterator.Pos := Iter.Pos + Offset; end if; end if; New_Iterator.Robj := Iter.Robj; New_Iterator.Update := New_Iterator.Robj.Update; return New_Iterator; end "+"; ------------------------------------------------------------------------ function "-" (Iter : in Iterator; Offset : in Integer) return Iterator is begin return (Iter + (- Offset)); end "-"; ------------------------------------------------------------------------ procedure Swap (Iter1, Iter2 : in out Iterator) is Tmp1 : Contained_Type; Tmp2 : Contained_Type; begin Check_Iterator(Iter1); Check_Iterator(Iter2); Tmp1 := Iter1.Robj.Data(Iter1.Pos); Tmp2 := Iter2.Robj.Data(Iter2.Pos); Iter1.Robj.Data(Iter1.Pos) := Tmp2; Iter2.Robj.Data(Iter2.Pos) := Tmp1; -- If we are moving items between different containers, we need to be -- sure to call added and deleted on them for the specified -- containers. As usual, added is called first and deleted is call -- last. if (Iter1.Robj /= Iter2.Robj) then if (Iter1.Robj.Cb /= null) then Added(Iter1.Robj.Cb, Iter1.Robj.all, Iter1.Robj.Data(Iter1.Pos)); end if; if (Iter2.Robj.Cb /= null) then Added(Iter2.Robj.Cb, Iter2.Robj.all, Iter2.Robj.Data(Iter2.Pos)); end if; if (Iter1.Robj.Cb /= null) then Deleted(Iter1.Robj.Cb, Iter1.Robj.all, Tmp1); end if; if (Iter2.Robj.Cb /= null) then Deleted(Iter2.Robj.Cb, Iter2.Robj.all, Tmp2); end if; end if; end Swap; ------------------------------------------------------------------------ procedure Add_After (Iter : in out Iterator; Val : in Contained_Type) is Next_Pos : Positive; begin Check_Iterator_Empty_Ok(Iter); Next_Pos := Next(Iter.Robj.all, Iter.Pos); Perform_Add(Iter.Robj.all, Get_Loc(Iter.Robj.all, Next_Pos), Next_Pos, Val); Iter.Update := Iter.Robj.Update; Iter.Pos := Next_Pos; end Add_After; ------------------------------------------------------------------------ procedure Add_Before (Iter : in out Iterator; Val : in Contained_Type) is begin Check_Iterator_Empty_Ok(Iter); -- Special case to handle empty lists. When a list is empty, the -- iterator will be set to the value before the head index. When we -- do an add_before in that case, we want the iterator to point to -- the head for this to work correctly. if (Iter.Robj.Head = Iter.Robj.Tail) then Iter.Pos := Iter.Robj.Head; end if; Perform_Add(Iter.Robj.all, Get_Loc(Iter.Robj.all, Iter.Pos), Iter.Pos, Val); Iter.Update := Iter.Robj.Update; end Add_Before; ------------------------------------------------------------------------ procedure Set (Iter : in Iterator; Val : in Contained_Type) is Old_Val : Contained_Type; begin Check_Iterator(Iter); Old_Val := Iter.Robj.Data(Iter.Pos); Iter.Robj.Data(Iter.Pos) := Val; -- Add then delete the values in case these are the same value. This -- can avoid some nasty side effects. if (Iter.Robj.Cb /= null) then Added(Iter.Robj.Cb, Iter.Robj.all, Iter.Robj.Data(Iter.Pos)); end if; if (Iter.Robj.Cb /= null) then Deleted(Iter.Robj.Cb, Iter.Robj.all, Old_Val); end if; end Set; ------------------------------------------------------------------------ procedure Get_Decr (Iter : in out Iterator; Val : out Contained_Type; Is_End : out End_Marker) is begin Check_Iterator(Iter); Val := Iter.Robj.Data(Iter.Pos); Prev(Iter, Is_End); end Get_Decr; --$START SORTABLE ------------------------------------------------------------------------ function ">" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Robj.Data(Iter1.Pos) > Iter2.Robj.Data(Iter2.Pos)); end ">"; ------------------------------------------------------------------------ function ">" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Robj.Data(Iter.Pos) > Val); end ">"; ------------------------------------------------------------------------ function ">" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Val > Iter.Robj.Data(Iter.Pos)); end ">"; ------------------------------------------------------------------------ function "<" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Robj.Data(Iter1.Pos) < Iter2.Robj.Data(Iter2.Pos)); end "<"; ------------------------------------------------------------------------ function "<" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Robj.Data(Iter.Pos) < Val); end "<"; ------------------------------------------------------------------------ function "<" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Val < Iter.Robj.Data(Iter.Pos)); end "<"; ------------------------------------------------------------------------ function ">=" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Robj.Data(Iter1.Pos) >= Iter2.Robj.Data(Iter2.Pos)); end ">="; ------------------------------------------------------------------------ function ">=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Robj.Data(Iter.Pos) >= Val); end ">="; ------------------------------------------------------------------------ function ">=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Val >= Iter.Robj.Data(Iter.Pos)); end ">="; ------------------------------------------------------------------------ function "<=" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Robj.Data(Iter1.Pos) <= Iter2.Robj.Data(Iter2.Pos)); end "<="; ------------------------------------------------------------------------ function "<=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Robj.Data(Iter.Pos) <= Val); end "<="; ------------------------------------------------------------------------ function "<=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Val <= Iter.Robj.Data(Iter.Pos)); end "<="; --$END SORTABLE end Asgc.Ordered.Alist.CTYPEMANAGED;