← Back to branch summary

~ubuntu-branches/debian/stretch/adabrowse/stretch

« back to all changes in this revision

Viewing changes to gal-containers-simple.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2004-02-14 13:22:40 UTC
  • Revision ID: james.westby@ubuntu.com-20040214132240-cqumhiq1677pkvzo
Tags: upstream-4.0.2
Import upstream version 4.0.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
gal-containers-simple.adb
 
1
-------------------------------------------------------------------------------
 
2
--
 
3
-- <STRONG>Copyright (c) 2001-2003 by Thomas Wolf.</STRONG>
 
4
-- <BLOCKQUOTE>
 
5
--    This piece of software is free software; you can redistribute it and/or
 
6
--    modify it under the terms of the  GNU General Public License as published
 
7
--    by the Free Software  Foundation; either version 2, or (at your option)
 
8
--    any later version. This unit is distributed in the hope that it will be
 
9
--    useful, but <EM>without any warranty</EM>; without even the implied
 
10
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
 
11
--    See the GNU General Public License for  more details. You should have
 
12
--    received a copy of the GNU General Public License with this distribution,
 
13
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
 
14
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
 
15
--    USA.
 
16
-- </BLOCKQUOTE>
 
17
-- <BLOCKQUOTE>
 
18
--   As a special exception from the GPL, if other files instantiate generics
 
19
--   from this unit, or you link this unit with other files to produce an
 
20
--   executable, this unit does not by itself cause the resulting executable
 
21
--   to be covered by the GPL. This exception does not however invalidate any
 
22
--   other reasons why the executable file might be covered by the GPL.
 
23
-- </BLOCKQUOTE>
 
24
--
 
25
-- <DL><DT><STRONG>
 
26
-- Author:</STRONG><DD>
 
27
--   Thomas Wolf  (TW)
 
28
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
 
29
--
 
30
-- <DL><DT><STRONG>
 
31
-- Purpose:</STRONG><DD>
 
32
--   Simple dynamic container, implemented as a very simple singly linked list.
 
33
--   Only operations are adding items, sorting, and finally traversing. It's
 
34
--   truly simple, but captures a very common case.
 
35
--   </DL>
 
36
--
 
37
-- <DL><DT><STRONG>
 
38
-- Tasking semantics:</STRONG><DD>
 
39
--   N/A. Not abortion-safe.</DL>
 
40
--
 
41
-- <DL><DT><STRONG>
 
42
-- Storage semantics:</STRONG><DD>
 
43
--   Dynamic storage allocation in a user-supplied storage pool.</DL>
 
44
--
 
45
-- <!--
 
46
-- Revision History
 
47
--
 
48
--   16-JUN-2003   TW  Initial version.
 
49
-- -->
 
50
-------------------------------------------------------------------------------
 
51
 
 
52
pragma License (Modified_GPL);
 
53
 
 
54
with Ada.Unchecked_Deallocation;
 
55
 
 
56
with GAL.Support;
 
57
with GAL.Support.List_Sort;
 
58
 
 
59
--  generic
 
60
--     type Item is private;
 
61
--
 
62
--     with package Memory is new GAL.Storage.Memory (<>);
 
63
--
 
64
--     with function "=" (Left, Right : in Item) return Boolean is <>;
 
65
--
 
66
package body GAL.Containers.Simple is
 
67
 
 
68
   procedure Swap
 
69
     (Left, Right : in out Simple_Container)
 
70
   is
 
71
      procedure Exchange is new GAL.Support.Swap (Link);
 
72
      procedure Exchange is new GAL.Support.Swap (Natural);
 
73
   begin
 
74
      Exchange (Left.C.Anchor, Right.C.Anchor);
 
75
      Exchange (Left.C.Last,   Right.C.Last);
 
76
      Exchange (Left.C.Count,  Right.C.Count);
 
77
   end Swap;
 
78
 
 
79
   function Nof_Elements
 
80
     (Container : in Simple_Container)
 
81
     return Natural
 
82
   is
 
83
   begin
 
84
      return Container.C.Count;
 
85
   end Nof_Elements;
 
86
 
 
87
   function Is_Empty
 
88
     (Container : in Simple_Container)
 
89
     return Boolean
 
90
   is
 
91
   begin
 
92
      return Container.C.Last = null;
 
93
   end Is_Empty;
 
94
 
 
95
   procedure Add
 
96
     (What : in     Item;
 
97
      To   : in out True_Container)
 
98
   is
 
99
      New_Item : constant Link := new Node'(Data => What, Next => null);
 
100
   begin
 
101
      if To.Last = null then
 
102
         To.Anchor := New_Item;
 
103
      else
 
104
         To.Last.Next := New_Item;
 
105
      end if;
 
106
      To.Last  := New_Item;
 
107
      To.Count := To.Count + 1;
 
108
   end Add;
 
109
 
 
110
   procedure Add
 
111
     (What : in     Item;
 
112
      To   : in out Simple_Container)
 
113
   is
 
114
   begin
 
115
      Add (What, To.C);
 
116
   end Add;
 
117
 
 
118
   procedure Reset
 
119
     (Container : in out True_Container)
 
120
   is
 
121
      P : Link := Container.Anchor;
 
122
 
 
123
      procedure Free is new Ada.Unchecked_Deallocation (Node, Link);
 
124
 
 
125
   begin
 
126
      while P /= null loop
 
127
         declare
 
128
            Q : constant Link := P.Next;
 
129
         begin
 
130
            Free (P); P := Q;
 
131
         end;
 
132
      end loop;
 
133
      Container.Anchor := null;
 
134
      Container.Last   := null;
 
135
      Container.Count  := 0;
 
136
   end Reset;
 
137
 
 
138
   procedure Reset
 
139
     (Container : in out Simple_Container)
 
140
   is
 
141
   begin
 
142
      Reset (Container.C);
 
143
   end Reset;
 
144
 
 
145
   procedure Traverse
 
146
     (Container : in     Simple_Container;
 
147
      V         : in out Visitor'Class)
 
148
   is
 
149
      P    : Link    := Container.C.Anchor;
 
150
      Quit : Boolean := False;
 
151
   begin
 
152
      while P /= null and then not Quit loop
 
153
         Execute (V, P.Data, Quit);
 
154
         P := P.Next;
 
155
      end loop;
 
156
   end Traverse;
 
157
 
 
158
   --  generic
 
159
   --     with procedure Execute
 
160
   --            (Value : in out Item;
 
161
   --             Quit  : in out Boolean);
 
162
   procedure Traverse_G
 
163
     (Container : in Simple_Container)
 
164
   is
 
165
      P    : Link    := Container.C.Anchor;
 
166
      Quit : Boolean := False;
 
167
   begin
 
168
      while P /= null and then not Quit loop
 
169
         Execute (P.Data, Quit);
 
170
         P := P.Next;
 
171
      end loop;
 
172
   end Traverse_G;
 
173
 
 
174
   --  generic
 
175
   --     type Auxiliary (<>) is limited private;
 
176
   --     with procedure Execute
 
177
   --            (Value : in out Item;
 
178
   --             Data  : in out Auxiliary;
 
179
   --             Quit  : in out Boolean);
 
180
   procedure Traverse_Aux_G
 
181
     (Container : in     Simple_Container;
 
182
      Data      : in out Auxiliary)
 
183
   is
 
184
      P    : Link    := Container.C.Anchor;
 
185
      Quit : Boolean := False;
 
186
   begin
 
187
      while P /= null and then not Quit loop
 
188
         Execute (P.Data, Data, Quit);
 
189
         P := P.Next;
 
190
      end loop;
 
191
   end Traverse_Aux_G;
 
192
 
 
193
   --  generic
 
194
   --     with function "<" (Left, Right : in Item) return Boolean is <>;
 
195
   procedure Sort
 
196
     (Container : in out Simple_Container)
 
197
   is
 
198
      function Smaller (L, R : in Link) return Boolean;
 
199
      pragma Inline (Smaller);
 
200
 
 
201
      function Smaller (L, R : in Link) return Boolean
 
202
      is
 
203
      begin
 
204
         return L.Data < R.Data;
 
205
      end Smaller;
 
206
 
 
207
      function Next (L : in Link) return Link;
 
208
      pragma Inline (Next);
 
209
 
 
210
      function Next (L : in Link) return Link
 
211
      is
 
212
      begin
 
213
         return L.Next;
 
214
      end Next;
 
215
 
 
216
      procedure Set_Next (L, Next : in Link);
 
217
      pragma Inline (Set_Next);
 
218
 
 
219
      procedure Set_Next (L, Next : in Link)
 
220
      is
 
221
      begin
 
222
         L.Next := Next;
 
223
      end Set_Next;
 
224
 
 
225
      procedure Post_Process (First, Last : in out Link)
 
226
      is
 
227
         pragma Warnings (Off, First); --  silence -gnatwa
 
228
         pragma Warnings (Off, Last);  --  silence -gnatwa
 
229
      begin
 
230
         null;
 
231
      end Post_Process;
 
232
 
 
233
      procedure Sort is
 
234
         new GAL.Support.List_Sort
 
235
               (Node, Link, Smaller, Next, Set_Next, Post_Process);
 
236
 
 
237
   begin
 
238
      Sort (Container.C.Anchor, Container.C.Last);
 
239
   end Sort;
 
240
 
 
241
   procedure Adjust   (Container : in out True_Container)
 
242
   is
 
243
      P : Link := Container.Anchor;
 
244
   begin
 
245
      Container.Anchor := null;
 
246
      Container.Last   := null;
 
247
      Container.Count  := 0;
 
248
      while P /= null loop
 
249
         Add (P.Data, Container);
 
250
         P := P.Next;
 
251
      end loop;
 
252
   end Adjust;
 
253
 
 
254
   procedure Finalize (Container : in out True_Container)
 
255
   is
 
256
   begin
 
257
      Reset (Container);
 
258
   end Finalize;
 
259
 
 
260
   procedure Write
 
261
     (Stream    : access Ada.Streams.Root_Stream_Type'Class;
 
262
      Container : in     Simple_Container)
 
263
   is
 
264
      P : Link := Container.C.Anchor;
 
265
   begin
 
266
      Natural'Write (Stream, Container.C.Count);
 
267
      while P /= null loop
 
268
         Item'Write (Stream, P.Data);
 
269
         P := P.Next;
 
270
      end loop;
 
271
   end Write;
 
272
 
 
273
   procedure Read
 
274
     (Stream    : access Ada.Streams.Root_Stream_Type'Class;
 
275
      Container :    out Simple_Container)
 
276
   is
 
277
   begin
 
278
      Reset (Container);
 
279
      declare
 
280
         N : Natural;
 
281
      begin
 
282
         Natural'Read (Stream, N);
 
283
         while N > 0 loop
 
284
            declare
 
285
               Data : Item;
 
286
            begin
 
287
               Item'Read (Stream, Data);
 
288
               Add (Data, Container);
 
289
            end;
 
290
            N := N - 1;
 
291
         end loop;
 
292
      end;
 
293
   end Read;
 
294
 
 
295
end GAL.Containers.Simple;