![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to generic_lists.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Polynomials|
Return to generic_lists.adb CVS log | Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Polynomials |
1.1 maekawa 1: package body Generic_Lists is
2:
3: -- INTERNAL DATA :
4:
5: type Node is record
6: The_Item : Item;
7: Next : List;
8: end record;
9:
10: Free_List : List := null;
11:
12: -- AUXILIARIES :
13:
14: procedure Set_Next ( The_Node : in out Node; To_Next : in List ) is
15: begin
16: The_Node.Next := To_Next;
17: end Set_Next;
18:
19: function Next_Of ( The_Node : in Node ) return List is
20: begin
21: return The_Node.Next;
22: end Next_Of;
23:
24: procedure Free ( l : in out List ) is
25:
26: tmp : List;
27:
28: begin
29: while l /= null loop
30: tmp := l;
31: l := Next_Of(l.all);
32: Set_Next(tmp.all,Free_List);
33: Free_List := tmp;
34: end loop;
35: end Free;
36:
37: function New_Item return List is
38:
39: tmp : List;
40:
41: begin
42: if Free_List = null
43: then return new Node;
44: else tmp := Free_List;
45: Free_List := Next_Of(tmp.all);
46: Set_Next(tmp.all,null);
47: return tmp;
48: end if;
49: end New_Item;
50:
51: -- CONSTRUCTORS :
52:
53: procedure Construct ( i : in Item; l : in out List ) is
54:
55: tmp : List;
56:
57: begin
58: tmp := New_Item;
59: tmp.The_Item := i;
60: tmp.Next := l;
61: l := tmp;
62: exception
63: when Storage_Error => raise Overflow;
64: end Construct;
65:
66: procedure Append ( first,last : in out List; i : in Item ) is
67: begin
68: if Is_Null(first)
69: then Construct(i,first);
70: last := first;
71: else declare
72: tmp : List;
73: begin
74: Construct(i,tmp);
75: Swap_Tail(last,tmp);
76: last := Tail_Of(last);
77: end;
78: end if;
79: end Append;
80:
81: procedure Concat ( first,last : in out List; l : in List ) is
82:
83: tmp : List := l;
84:
85: begin
86: while not Is_Null(tmp) loop
87: Append(first,last,Head_Of(tmp));
88: tmp := Tail_Of(tmp);
89: end loop;
90: end Concat;
91:
92: procedure Set_Head ( l : in out List; i : in Item ) is
93: begin
94: l.The_Item := i;
95: exception
96: when Constraint_Error => raise List_Is_Null;
97: end Set_Head;
98:
99: procedure Swap_Tail ( l1,l2 : in out List ) is
100:
101: tmp : List;
102:
103: begin
104: tmp := l1.Next;
105: l1.Next := l2;
106: l2 := tmp;
107: exception
108: when Constraint_Error => raise List_Is_Null;
109: end Swap_Tail;
110:
111: procedure Copy ( l1 : in List; l2 : in out List ) is
112:
113: From_Index : List := l1;
114: To_Index : List;
115:
116: begin
117: Free(l2);
118: if l1 /= null
119: then l2 := New_Item;
120: l2.The_Item := From_Index.The_Item;
121: To_Index := l2;
122: From_Index := From_Index.Next;
123: while From_Index /= null loop
124: To_Index.Next := New_Item;
125: To_Index := To_Index.Next;
126: To_Index.The_Item := From_Index.The_Item;
127: From_Index := From_Index.Next;
128: end loop;
129: end if;
130: exception
131: when Storage_Error => raise Overflow;
132: end Copy;
133:
134: -- SELECTORS :
135:
136: function Is_Equal ( l1,l2 : List ) return boolean is
137:
138: left_index : List := l1;
139: right_index : List := l2;
140:
141: begin
142: while left_index /= null loop
143: if left_index.The_Item /= right_index.The_Item
144: then return False;
145: end if;
146: left_index := left_index.Next;
147: right_index := right_index.Next;
148: end loop;
149: return (right_index = null);
150: exception
151: when Constraint_Error => return false;
152: end Is_Equal;
153:
154: function Length_Of ( l : List ) return natural is
155:
156: cnt : natural := 0;
157: tmp : List := l;
158:
159: begin
160: while not Is_Null(tmp) loop
161: cnt := cnt + 1;
162: tmp := Tail_Of(tmp);
163: end loop;
164: return cnt;
165: end Length_Of;
166:
167: function Is_Null ( l : list ) return boolean is
168: begin
169: return (l = null);
170: end Is_Null;
171:
172: function Head_Of ( l : List ) return Item is
173: begin
174: return l.The_Item;
175: exception
176: when Constraint_Error => raise List_Is_Null;
177: end Head_Of;
178:
179: function Tail_Of ( l : List ) return List is
180: begin
181: return l.Next;
182: exception
183: when Constraint_Error => raise List_Is_Null;
184: end Tail_Of;
185:
186: -- DESTRUCTOR :
187:
188: procedure Clear ( l : in out List ) is
189: begin
190: Free(l);
191: end Clear;
192:
193: end Generic_Lists;