1-- 2-- Copyright (c) 2008-2009 Tero Koskinen <tero.koskinen@iki.fi> 3-- 4-- Permission to use, copy, modify, and distribute this software for any 5-- purpose with or without fee is hereby granted, provided that the above 6-- copyright notice and this permission notice appear in all copies. 7-- 8-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15-- 16with Ada.Unchecked_Deallocation; 17 18package body Ahven.SList is 19 procedure Remove (Ptr : Node_Access) is 20 procedure Free is 21 new Ada.Unchecked_Deallocation (Object => Node, 22 Name => Node_Access); 23 My_Ptr : Node_Access := Ptr; 24 begin 25 Ptr.Next := null; 26 Free (My_Ptr); 27 end Remove; 28 29 procedure Append (Target : in out List; 30 Node_Data : Element_Type) is 31 New_Node : Node_Access := null; 32 begin 33 if Target.Size = Count_Type'Last then 34 raise List_Full; 35 end if; 36 37 New_Node := new Node'(Data => Node_Data, Next => null); 38 39 if Target.Last = null then 40 Target.First := New_Node; 41 else 42 Target.Last.Next := New_Node; 43 end if; 44 Target.Last := New_Node; 45 46 Target.Size := Target.Size + 1; 47 end Append; 48 49 procedure Clear (Target : in out List) is 50 Current_Node : Node_Access := Target.First; 51 Next_Node : Node_Access := null; 52 begin 53 while Current_Node /= null loop 54 Next_Node := Current_Node.Next; 55 Remove (Current_Node); 56 Current_Node := Next_Node; 57 end loop; 58 59 Target.First := null; 60 Target.Last := null; 61 Target.Size := 0; 62 end Clear; 63 64 function First (Target : List) return Cursor is 65 begin 66 return Cursor (Target.First); 67 end First; 68 69 function Next (Position : Cursor) return Cursor is 70 begin 71 if Position = null then 72 raise Invalid_Cursor; 73 end if; 74 return Cursor (Position.Next); 75 end Next; 76 77 function Data (Position : Cursor) return Element_Type is 78 begin 79 if Position = null then 80 raise Invalid_Cursor; 81 end if; 82 83 return Position.Data; 84 end Data; 85 86 function Is_Valid (Position : Cursor) return Boolean is 87 begin 88 return Position /= null; 89 end Is_Valid; 90 91 function Length (Target : List) return Count_Type is 92 begin 93 return Target.Size; 94 end Length; 95 96 procedure For_Each (Target : List) is 97 Current_Node : Node_Access := Target.First; 98 begin 99 while Current_Node /= null loop 100 Action (Current_Node.Data); 101 Current_Node := Current_Node.Next; 102 end loop; 103 end For_Each; 104 105 procedure Initialize (Target : in out List) is 106 begin 107 Target.Last := null; 108 Target.First := null; 109 Target.Size := 0; 110 end Initialize; 111 112 procedure Finalize (Target : in out List) is 113 begin 114 Clear (Target); 115 end Finalize; 116 117 procedure Adjust (Target : in out List) is 118 Target_Last : Node_Access := null; 119 Target_First : Node_Access := null; 120 Current : Node_Access := Target.First; 121 New_Node : Node_Access; 122 begin 123 -- Recreate the list using the same data 124 while Current /= null loop 125 New_Node := new Node'(Data => Current.Data, Next => null); 126 127 if Target_Last = null then 128 Target_First := New_Node; 129 else 130 Target_Last.Next := New_Node; 131 end if; 132 Target_Last := New_Node; 133 134 Current := Current.Next; 135 end loop; 136 Target.First := Target_First; 137 Target.Last := Target_Last; 138 139 -- No need to adjust size, it is same as before copying 140 end Adjust; 141end Ahven.SList; 142