File: gen_list.adb

package info (click to toggle)
libtexttools 2.0.3-4
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 1,188 kB
  • ctags: 635
  • sloc: ada: 13,120; cpp: 1,679; ansic: 777; makefile: 156; sh: 2
file content (519 lines) | stat: -rw-r--r-- 20,234 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
------------------------------------------------------------------------------
-- GEN LIST (package body)                                                  --
--                                                                          --
-- Part of TextTools                                                        --
-- Designed and Programmed by Ken O. Burtch                                 --
--                                                                          --
------------------------------------------------------------------------------
--                                                                          --
--                 Copyright (C) 1999-2003 Ken O. Burtch                    --
--                                                                          --
-- This 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.  This 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 this;  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 is maintained at http://www.vaxxine.com/pegasoft                    --
--                                                                          --
------------------------------------------------------------------------------
-- Started September 5/95 by Ken O. Burtch
--
-- Package Body Notes:
--
-- 1. I avoid pragma Inline in order to keep the code compact.  Where
--    I could have used Inline, it was usually better to insert optimzed
--    code to do the same (eg. Push/Pull).

--with Text_IO; use Text_IO; -- for debugging

package body gen_list is
  pragma optimize( space );
  pragma suppress( all_checks );

NullList : List := (null,null,0,null,0,null);

RecordsAllocated : AListIndex := 0;

procedure GetAllocation( allocation : out AListIndex ) is
-- return number of outstanding records allocated
begin
  allocation := RecordsAllocated * (AListElement'size / 8);
end GetAllocation;

function MemoryLeak( allocation : in AListIndex ) return boolean is
-- note if memory leakage has occurred between allocation time & now
begin
  return ( RecordsAllocated * ( AListElement'size / 8 )) /= Allocation;
end MemoryLeak;

procedure Compact( TheList : in out List ) is
-- optimize the list
begin
  if TheList.FreeCache /= null then
     Free( TheList.FreeCache );
  end if;
end Compact;

procedure Clear( TheList : in out List ) is
-- erase the entire list
  TmpPtr, TmpPtr2 : AListRecordPtr;
begin
  TmpPtr := TheList.First;
  while TmpPtr /= null loop
     TmpPtr2 := TmpPtr.next;
     Free( TmpPtr );
     RecordsAllocated := RecordsAllocated - 1;
     TmpPtr := TmpPtr2;
  end loop;
  if TheList.FreeCache /= null then
     Free( TheList.FreeCache );
     RecordsAllocated := RecordsAllocated - 1; -- compensate for one not d'ed.
  end if;
  TheList := NullList;
end Clear;

function Length( TheList : in List ) return AListIndex is
-- return the length of the list
begin
  return TheList.count;
end Length;

function IsEmpty( TheList : in List ) return boolean is
-- could check count, but this is more absolute
begin
  return TheList.First = null;
end IsEmpty;

procedure Push( TheList : in out List; newdata : AListElement ) is
-- add a record to the start of the list & update the count
  TmpPtr : AListRecordPtr;
begin
  if TheList.FreeCache = null then   -- allocate a new record
     TmpPtr := new AListRecord;
     RecordsAllocated := RecordsAllocated + 1;
  else
     TmpPtr := TheList.FreeCache;    -- or grab one from the cache
     TheList.FreeCache := null;
  end if;
  TmpPtr.Data := newdata;            -- put data in it
  if TheList.First = null then       -- add to an empty list
     TheList.First := TmpPtr;
     TheList.Last := TmpPtr;
     TmpPtr.Next := null;
  else
     TmpPtr.next := TheList.first;   -- push it
     TheList.first := TmpPtr;
  end if;
  TheList.count := TheList.count + 1; -- adjust the count
  if TheList.LastPtr /= null then
     TheList.LastRec := TheList.LastRec + 1;
  end if;
end Push;

procedure Queue( TheList : in out List ; Data : AListElement ) is
-- add a record to the end of the list & update the count
  TmpPtr : AListRecordPtr;
begin
  if TheList.FreeCache = null then  -- allocate a new record
     TmpPtr := new AListRecord;
     RecordsAllocated := RecordsAllocated + 1;
  else
     TmpPtr := TheList.FreeCache;   -- or grab one from the cache
     TheList.FreeCache := null;
  end if;
  TmpPtr.Data := Data;              -- assign data
  TmpPtr.Next := null;              -- nothing will be after it
  if TheList.First = null then      -- add to an empty list
     TheList.First := TmpPtr;
  else
     TheList.Last.Next := TmpPtr;   -- or append to the end
  end if;
  TheList.Last := TmpPtr;             -- always the last record
  TheList.Count := TheList.Count + 1; -- add one to the count
end Queue;

procedure Insert( TheList : in out List ; Data : AListElement ) is
-- insert a record into the list in ascending order & update the count
  NewRec : AListRecordPtr;
  TmpPtr, TmpPtr2 : AListRecordPtr;
begin
  TmpPtr2 := null;                      -- ready to search the list
  TmpPtr := TheList.First;
  while TmpPtr /= null loop             -- quit if we reach the end
     exit when TmpPtr.Data >= Data;     --  or if we exceed the sort value
     TmpPtr2 := TmpPtr;
     TmpPtr := TmpPtr.Next;
  end loop;
  if TmpPtr = null then                 -- queue it if we reached the end
     Queue( TheList, Data );
  elsif TmpPtr2 = null then             -- or push it if goes in front
     Push( TheList, Data );
  else
     if TheList.FreeCache = null then   -- else allocate a new record
        NewRec := new AListRecord;
        RecordsAllocated := RecordsAllocated + 1;
     else
        NewRec := TheList.FreeCache;    -- or grab one from the cache
        TheList.FreeCache := null;
     end if;
     NewRec.Data := Data;               -- copy data
     NewRec.Next := TmpPtr;             -- goes before TmpPtr
     TmpPtr2.next := NewRec;            -- and after TmpPtr2
     TheList.Count := TheList.Count + 1; -- update the count
     TheList.LastPtr := null;            -- last position cache
  end if;
end Insert;

procedure Insert( TheList : in out List ; atIndex : AListIndex; 
   data : AListElement ) is
-- insert a record into the list at the index & update the count
  NewRec : AListRecordPtr;
  TmpPtr, TmpPtr2 : AListRecordPtr;
  Count : AListIndex;
begin
  if atIndex > 0 and atIndex <= TheList.Count then
    Count := 0;                      -- get ready to search list
    TmpPtr2 := null;
    TmpPtr := TheList.First;
    while TmpPtr /= null loop        -- stop when we hit the end
       Count := Count + 1;
       exit when Count = atIndex;    -- or when we hit the desired record
       TmpPtr2 := TmpPtr;
       TmpPtr := TmpPtr.Next;
    end loop;
    -- note: TmpPtr should NOT be null because of constraint check above
    if TmpPtr2 = null then             -- or push it if goes in front
       Push( TheList, Data );
    else
       if TheList.FreeCache = null then   -- else allocate a new record
          NewRec := new AListRecord;
          RecordsAllocated := RecordsAllocated + 1;
       else
          NewRec := TheList.FreeCache;    -- or grab one from the cache
          TheList.FreeCache := null;
       end if;
       NewRec.Data := Data;               -- copy data
       NewRec.Next := TmpPtr;             -- goes before TmpPtr
       TmpPtr2.next := NewRec;            -- and after TmpPtr2
       TheList.Count := TheList.Count + 1; -- update the count
       TheList.LastRec := atIndex;
       TheList.LastPtr := NewRec;
    end if;
  end if;
end Insert;

procedure Pull( TheList : in out List ; Data : in out AListElement ) is
-- remove a record from the front of the list & update the count
   TmpPtr : AListRecordPtr;
begin
  if TheList.first /= null then             -- if the list isn't empty
     TmpPtr := TheList.First;               -- extract the data
     Data := TheList.First.Data;
     TheList.first := TheList.First.Next;   -- update first pointer
     if TheList.FreeCache = null then       -- add record to free cache
        TheList.FreeCache := TmpPtr;
     else
        Free( TmpPtr );                     -- or deallocate if cache full
        RecordsAllocated := RecordsAllocated - 1;
     end if;
     if TheList.First = null then           -- if last record, fix last
        TheList.Last := null;
     end if;
     TheList.Count := TheList.Count - 1;    -- decrement the count
     TheList.LastPtr := null;               -- assuming the worst
  end if;
end Pull;

procedure Pull( TheList : in out List ) is
-- remove a record from the front of the list and discard it
  data : AListElement;
begin
  Pull( TheList, Data );
end Pull;

procedure Concat( List1, List2 : List; Result : in out List ) is
-- add to lists together and return the results as a third list
-- not very fast -- could rewrite to get rid of queue's
  TmpPtr  : AListRecordPtr;
  TmpList : List;
begin
  TmpPtr := List1.First;             -- move though first list
  while TmpPtr /= null loop
     Queue( TmpList, TmpPtr.Data );  -- add to result list
     TmpPtr := TmpPtr.Next;
  end loop;
  TmpPtr := List2.First;             -- move through second list
  while TmpPtr /= null loop
     Queue( TmpList, TmpPtr.Data );  -- add to result list
     TmpPtr := TmpPtr.Next;
  end loop;
  Clear( Result );                   -- overwrite result
  Result := TmpList;                 -- with new header info
end Concat;

procedure Cut( TheList : in out List ; atIndex : AListIndex;
  data : in out AListElement ) is
-- remove the atIndex-th record from the list and return it
  Count : AListIndex;
  TmpPtr, TmpPtr2 : AListRecordPtr;
begin
  if atIndex > 0 and atIndex <= TheList.Count then
    Count := 0;                      -- get ready to search list
    TmpPtr2 := null;
    TmpPtr := TheList.First;
    while TmpPtr /= null loop        -- stop when we hit the end
       Count := Count + 1;
       exit when Count = atIndex;    -- or when we hit the desired record
       TmpPtr2 := TmpPtr;
       TmpPtr := TmpPtr.Next;
    end loop;
    -- note: TmpPtr should NOT be null because of constraint check above
    data := TmpPtr.data;             -- return the data
    if TmpPtr2 = null then           -- if it's the first then pull
       Pull( TheList );
    else
       TmpPtr2.Next := TmpPtr.Next;  -- else, next follows last one
       if TmpPtr2.Next = null then   -- update last if is the last
          TheList.Last := TmpPtr2;
       end if;
       if TheList.FreeCache = null then -- add to the cache
          TheList.FreeCache := TmpPtr;
       else
          Free( TmpPtr );               -- or discard if cache is full
          RecordsAllocated := RecordsAllocated - 1;
       end if;
       TheList.Count := TheList.Count - 1; -- smaller by 1
       TheList.LastPtr := null;         -- assuming the worst
    end if;
  end if;
end Cut;

procedure Clear( TheList : in out List; atIndex : AListIndex ) is
  Discard : AListElement;
begin
  Cut( TheList, atIndex, Discard );
end Clear;

procedure Replace( TheList : in out List ; atIndex : AListIndex ;
          Data : AListElement ) is
-- replaces the atIndex-th record from the list
  Count  : AListIndex;
  TmpPtr : AListRecordPtr;
begin
  if atIndex > 0 and atIndex <= TheList.Count then
     if TheList.LastPtr /= null and then atIndex >= TheList.LastRec then
        TmpPtr := TheList.LastPtr;      -- use LastPtr if useful
        Count := TheList.LastRec-1;     --   (count inc'd below)
     else
        Count := 0;                     -- start from scratch
        TmpPtr := TheList.First;
     end if;
     while TmpPtr /= null loop
        Count := Count + 1;
        exit when Count = atIndex;
        TmpPtr := TmpPtr.Next;
     end loop;
     -- note: TmpPtr should NOT be null because of constraint check above
     TmpPtr.Data := Data;
  end if;
end Replace;

procedure Find( TheList : in out List ; atIndex : AListIndex ;
          Data : in out AListElement ) is
-- finds the atIndex-th record from the list
  Count : AListIndex;
  TmpPtr : AListRecordPtr;
begin
  if atIndex > 0 and atIndex <= TheList.Count then
     -- was <=
     if TheList.LastPtr /= null and then atIndex >= TheList.LastRec then
        Count := TheList.LastRec-1;    -- use Lastptr if helpful
        TmpPtr := TheList.LastPtr;     --   (count is inc'd below)
     else
        Count := 0;                    -- else start from scratch
        TmpPtr := TheList.first;
     end if;
     while TmpPtr /= null loop
        Count := Count + 1;
        exit when Count = atIndex;
        TmpPtr := TmpPtr.next;
     end loop;
     -- note: TmpPtr should NOT be null because of constraint check above
     data := TmpPtr.data;
     TheList.LastRec := atIndex;  -- last access point
     TheList.LastPtr := TmpPtr;
  end if;
end Find;

procedure Find( TheList : in out List ; data : AListElement;
  start : AListIndex := 1; FoundAt : in out AListIndex ) is
-- locate the first (next) record matching c and return it's index
  Count : AListIndex;
  TmpPtr : AListRecordPtr;
begin
  if start > 0 and start <= TheList.Count then
     if TheList.LastPtr /= null and then start >= TheList.LastRec then
        Count := TheList.LastRec-1; --   (Count is inc'd below)
        TmpPtr := TheList.LastPtr;  -- use LastPtr if it's useful
     else
        Count := 0;                 -- else start from scratch
        TmpPtr := TheList.first;
     end if;
     while TmpPtr /= null loop
       Count := Count + 1;
       exit when (TmpPtr.Data = Data) and then (Count >= Start);
       TmpPtr := TmpPtr.next;
     end loop;
     if TmpPtr = null then
        Count := 0;
     else
       TheList.LastRec := Count;   -- remember where we left off
       TheList.LastPtr := TmpPtr;
     end if;
     FoundAt := Count;
  else -- wierd start or empty list
     FoundAt := 0;
  end if;
end Find;

procedure SubList( TheList : in out List ; index, len : AListIndex;
         result : in out List ) is
-- extract a sublist of length len from position index
  Count   : AListIndex;
  TmpPtr  : AListRecordPtr;
  TmpList : List; -- in case TheList = Result
begin
  if TheList.LastPtr /= null and index >= TheList.LastRec then
     TmpPtr := TheList.LastPtr;            -- use LastPtr if useful
     Count := TheList.LastRec-1;           --   (LastRec inc'd below)
  else
     Count := 0;                           -- else start from scratch
     TmpPtr := TheList.First;
  end if;
  while TmpPtr /= null loop                -- loop until we run out
     Count := Count + 1;
     exit when (Count >= Index);           -- or we find the nth item
     TmpPtr := TmpPtr.Next;
  end loop;
  if TmpPtr /= null then                   -- if we're still in the list
     TheList.LastPtr := TmpPtr;            --    record where we are
     TheList.LastRec := Count;             --    for future speed benefits
  end if;
  Count := 0;                              -- read to build sublist
  while TmpPtr /= null loop                -- loop until we run out
     Queue( TmpList, TmpPtr.data );        -- should rewrite this for speed
     Count := Count + 1;
     exit when (Count >= len );            -- or stop when we have enough
     TmpPtr := TmpPtr.Next;
  end loop;
  Clear( Result );                         -- overwrite result
  Result := TmpList;                       -- with new header info
end SubList;

procedure Copy( FromList, ToList : in out List ) is
-- Make a copy of the ToList
  FromListPtr : AListRecordPtr;
  TmpPtr      : AListRecordPtr;
  TmpList     : List;  -- FromList might be ToList
begin
  FromListPtr := FromList.First;        -- begin at the first record
  if FromListPtr /= null then           -- if there is a first record
     TmpPtr := new AListRecord;         --    add it to the new list
     RecordsAllocated := RecordsAllocated + 1;
     TmpPtr.data := FromListPtr.data;
     TmpList.First := TmpPtr;
     TmpList.Last  := TmpPtr;
     FromListPtr := FromListPtr.next;   --   update pointer
     while FromListPtr /= null loop     -- for any remaining records
       TmpPtr := new AListRecord;       --   create a copy for first list
       RecordsAllocated := RecordsAllocated + 1;
       TmpPtr.data := FromListPtr.data;
       TmpList.Last.Next := TmpPtr;      --   and append it
       TmpList.Last := TmpPtr;
       FromListPtr := FromListPtr.Next; --   update pointer
    end loop;
    TmpList.Count := FromList.Count;    -- fix counts and last.next pointers
    TmpList.Last.Next := null;
    Clear( ToList );                    -- overwrite result
    ToList := TmpList;                  -- with new header info
  end if;
end Copy;

procedure Copy( FromList, ToList1, ToList2 : in out List ) is
-- Make two copies of the FromList
  FromListPtr : AListRecordPtr;
  TmpPtr      : AListRecordptr;
  List1, List2: List; -- ToList1 or ToList2 might be same as FromList
begin
  FromListPtr := FromList.First;        -- begin at the first record
  if FromListPtr /= null then           -- if there is a first record
     TmpPtr := new AListRecord;         --    add it to the first list
     RecordsAllocated := RecordsAllocated + 1;
     TmpPtr.data := FromListPtr.data;
     List1.First := TmpPtr;
     List1.Last  := TmpPtr;
     TmpPtr := new AListRecord;         --    and to the second
     RecordsAllocated := RecordsAllocated + 1;
     TmpPtr.data := FromListPtr.data;
     List2.First := TmpPtr;
     List2.Last  := TmpPtr;
     FromListPtr := FromListPtr.next;   --   update pointer
     while FromListPtr /= null loop     -- for any remaining records
       TmpPtr := new AListRecord;       --   create a copy for first list
       RecordsAllocated := RecordsAllocated + 1;
       TmpPtr.data := FromListPtr.data;
       List1.Last.Next := TmpPtr;     --   and append it
       List1.Last := TmpPtr;
       TmpPtr := new AListRecord;       --   create a copy for second list
       RecordsAllocated := RecordsAllocated + 1;
       TmpPtr.data := FromListPtr.data;
       List2.Last.Next := TmpPtr;     --   and append it, too
       List2.Last := TmpPtr;
       FromListPtr := FromListPtr.Next; --   update pointer
    end loop;
    List1.Count := FromList.Count;    -- fix counts and last.next pointers
    List1.Last.Next := null;
    List2.Count := FromList.Count;
    List2.Last.Next := null;
    Clear( ToList1 );                 -- overwrite result lists
    Clear( ToList2 );
    ToList1 := List1;                 -- with new header info
    ToList2 := List2;
  end if;
end Copy;

procedure Move( FromList, ToList : in out List ) is
-- move a list between two list variables
begin
  if FromList.first /= ToList.first then
     Clear( ToList );
     ToList := FromList;
     FromList := NullList;
  end if;
end Move;

procedure Swap( List1, List2 : in out List ) is
  TmpList : List;
begin
  if List1.first /= List2.first then
     Move( FromList => List1, ToList => TmpList );
     Move( FromList => List2, ToList => List1 );
     Move( FromList => TmpList, ToList => List2 );
  end if;
end Swap;

end gen_list;