OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-chtgop.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT LIBRARY COMPONENTS                          --
4
--                                                                          --
5
--              ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- This unit was originally developed by Matthew J Heaney.                  --
28
------------------------------------------------------------------------------
29
 
30
with Ada.Containers.Prime_Numbers;
31
with Ada.Unchecked_Deallocation;
32
 
33
with System;  use type System.Address;
34
 
35
package body Ada.Containers.Hash_Tables.Generic_Operations is
36
 
37
   type Buckets_Allocation is access all Buckets_Type;
38
   --  Used for allocation and deallocation (see New_Buckets and Free_Buckets).
39
   --  This is necessary because Buckets_Access has an empty storage pool.
40
 
41
   ------------
42
   -- Adjust --
43
   ------------
44
 
45
   procedure Adjust (HT : in out Hash_Table_Type) is
46
      Src_Buckets : constant Buckets_Access := HT.Buckets;
47
      N           : constant Count_Type := HT.Length;
48
      Src_Node    : Node_Access;
49
      Dst_Prev    : Node_Access;
50
 
51
   begin
52
      HT.Buckets := null;
53
      HT.Length := 0;
54
 
55
      if N = 0 then
56
         return;
57
      end if;
58
 
59
      --  Technically it isn't necessary to allocate the exact same length
60
      --  buckets array, because our only requirement is that following
61
      --  assignment the source and target containers compare equal (that is,
62
      --  operator "=" returns True). We can satisfy this requirement with any
63
      --  hash table length, but we decide here to match the length of the
64
      --  source table. This has the benefit that when iterating, elements of
65
      --  the target are delivered in the exact same order as for the source.
66
 
67
      HT.Buckets := New_Buckets (Length => Src_Buckets'Length);
68
 
69
      for Src_Index in Src_Buckets'Range loop
70
         Src_Node := Src_Buckets (Src_Index);
71
 
72
         if Src_Node /= null then
73
            declare
74
               Dst_Node : constant Node_Access := Copy_Node (Src_Node);
75
 
76
               --  See note above
77
 
78
               pragma Assert (Index (HT, Dst_Node) = Src_Index);
79
 
80
            begin
81
               HT.Buckets (Src_Index) := Dst_Node;
82
               HT.Length := HT.Length + 1;
83
 
84
               Dst_Prev := Dst_Node;
85
            end;
86
 
87
            Src_Node := Next (Src_Node);
88
            while Src_Node /= null loop
89
               declare
90
                  Dst_Node : constant Node_Access := Copy_Node (Src_Node);
91
 
92
                  --  See note above
93
 
94
                  pragma Assert (Index (HT, Dst_Node) = Src_Index);
95
 
96
               begin
97
                  Set_Next (Node => Dst_Prev, Next => Dst_Node);
98
                  HT.Length := HT.Length + 1;
99
 
100
                  Dst_Prev := Dst_Node;
101
               end;
102
 
103
               Src_Node := Next (Src_Node);
104
            end loop;
105
         end if;
106
      end loop;
107
 
108
      pragma Assert (HT.Length = N);
109
   end Adjust;
110
 
111
   --------------
112
   -- Capacity --
113
   --------------
114
 
115
   function Capacity (HT : Hash_Table_Type) return Count_Type is
116
   begin
117
      if HT.Buckets = null then
118
         return 0;
119
      end if;
120
 
121
      return HT.Buckets'Length;
122
   end Capacity;
123
 
124
   -----------
125
   -- Clear --
126
   -----------
127
 
128
   procedure Clear (HT : in out Hash_Table_Type) is
129
      Index : Hash_Type := 0;
130
      Node  : Node_Access;
131
 
132
   begin
133
      if HT.Busy > 0 then
134
         raise Program_Error with
135
           "attempt to tamper with cursors (container is busy)";
136
      end if;
137
 
138
      while HT.Length > 0 loop
139
         while HT.Buckets (Index) = null loop
140
            Index := Index + 1;
141
         end loop;
142
 
143
         declare
144
            Bucket : Node_Access renames HT.Buckets (Index);
145
         begin
146
            loop
147
               Node := Bucket;
148
               Bucket := Next (Bucket);
149
               HT.Length := HT.Length - 1;
150
               Free (Node);
151
               exit when Bucket = null;
152
            end loop;
153
         end;
154
      end loop;
155
   end Clear;
156
 
157
   ---------------------------
158
   -- Delete_Node_Sans_Free --
159
   ---------------------------
160
 
161
   procedure Delete_Node_Sans_Free
162
     (HT : in out Hash_Table_Type;
163
      X  : Node_Access)
164
   is
165
      pragma Assert (X /= null);
166
 
167
      Indx : Hash_Type;
168
      Prev : Node_Access;
169
      Curr : Node_Access;
170
 
171
   begin
172
      if HT.Length = 0 then
173
         raise Program_Error with
174
           "attempt to delete node from empty hashed container";
175
      end if;
176
 
177
      Indx := Index (HT, X);
178
      Prev := HT.Buckets (Indx);
179
 
180
      if Prev = null then
181
         raise Program_Error with
182
           "attempt to delete node from empty hash bucket";
183
      end if;
184
 
185
      if Prev = X then
186
         HT.Buckets (Indx) := Next (Prev);
187
         HT.Length := HT.Length - 1;
188
         return;
189
      end if;
190
 
191
      if HT.Length = 1 then
192
         raise Program_Error with
193
           "attempt to delete node not in its proper hash bucket";
194
      end if;
195
 
196
      loop
197
         Curr := Next (Prev);
198
 
199
         if Curr = null then
200
            raise Program_Error with
201
              "attempt to delete node not in its proper hash bucket";
202
         end if;
203
 
204
         if Curr = X then
205
            Set_Next (Node => Prev, Next => Next (Curr));
206
            HT.Length := HT.Length - 1;
207
            return;
208
         end if;
209
 
210
         Prev := Curr;
211
      end loop;
212
   end Delete_Node_Sans_Free;
213
 
214
   --------------
215
   -- Finalize --
216
   --------------
217
 
218
   procedure Finalize (HT : in out Hash_Table_Type) is
219
   begin
220
      Clear (HT);
221
      Free_Buckets (HT.Buckets);
222
   end Finalize;
223
 
224
   -----------
225
   -- First --
226
   -----------
227
 
228
   function First (HT : Hash_Table_Type) return Node_Access is
229
      Indx : Hash_Type;
230
 
231
   begin
232
      if HT.Length = 0 then
233
         return null;
234
      end if;
235
 
236
      Indx := HT.Buckets'First;
237
      loop
238
         if HT.Buckets (Indx) /= null then
239
            return HT.Buckets (Indx);
240
         end if;
241
 
242
         Indx := Indx + 1;
243
      end loop;
244
   end First;
245
 
246
   ------------------
247
   -- Free_Buckets --
248
   ------------------
249
 
250
   procedure Free_Buckets (Buckets : in out Buckets_Access) is
251
      procedure Free is
252
        new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation);
253
 
254
   begin
255
      --  Buckets must have been created by New_Buckets. Here, we convert back
256
      --  to the Buckets_Allocation type, and do the free on that.
257
 
258
      Free (Buckets_Allocation (Buckets));
259
   end Free_Buckets;
260
 
261
   ---------------------
262
   -- Free_Hash_Table --
263
   ---------------------
264
 
265
   procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
266
      Node : Node_Access;
267
 
268
   begin
269
      if Buckets = null then
270
         return;
271
      end if;
272
 
273
      for J in Buckets'Range loop
274
         while Buckets (J) /= null loop
275
            Node := Buckets (J);
276
            Buckets (J) := Next (Node);
277
            Free (Node);
278
         end loop;
279
      end loop;
280
 
281
      Free_Buckets (Buckets);
282
   end Free_Hash_Table;
283
 
284
   -------------------
285
   -- Generic_Equal --
286
   -------------------
287
 
288
   function Generic_Equal
289
     (L, R : Hash_Table_Type) return Boolean
290
   is
291
      L_Index : Hash_Type;
292
      L_Node  : Node_Access;
293
 
294
      N : Count_Type;
295
 
296
   begin
297
      if L'Address = R'Address then
298
         return True;
299
      end if;
300
 
301
      if L.Length /= R.Length then
302
         return False;
303
      end if;
304
 
305
      if L.Length = 0 then
306
         return True;
307
      end if;
308
 
309
      --  Find the first node of hash table L
310
 
311
      L_Index := 0;
312
      loop
313
         L_Node := L.Buckets (L_Index);
314
         exit when L_Node /= null;
315
         L_Index := L_Index + 1;
316
      end loop;
317
 
318
      --  For each node of hash table L, search for an equivalent node in hash
319
      --  table R.
320
 
321
      N := L.Length;
322
      loop
323
         if not Find (HT => R, Key => L_Node) then
324
            return False;
325
         end if;
326
 
327
         N := N - 1;
328
 
329
         L_Node := Next (L_Node);
330
 
331
         if L_Node = null then
332
            --  We have exhausted the nodes in this bucket
333
 
334
            if N = 0 then
335
               return True;
336
            end if;
337
 
338
            --  Find the next bucket
339
 
340
            loop
341
               L_Index := L_Index + 1;
342
               L_Node := L.Buckets (L_Index);
343
               exit when L_Node /= null;
344
            end loop;
345
         end if;
346
      end loop;
347
   end Generic_Equal;
348
 
349
   -----------------------
350
   -- Generic_Iteration --
351
   -----------------------
352
 
353
   procedure Generic_Iteration (HT : Hash_Table_Type) is
354
      Node : Node_Access;
355
 
356
   begin
357
      if HT.Length = 0 then
358
         return;
359
      end if;
360
 
361
      for Indx in HT.Buckets'Range loop
362
         Node := HT.Buckets (Indx);
363
         while Node /= null loop
364
            Process (Node);
365
            Node := Next (Node);
366
         end loop;
367
      end loop;
368
   end Generic_Iteration;
369
 
370
   ------------------
371
   -- Generic_Read --
372
   ------------------
373
 
374
   procedure Generic_Read
375
     (Stream : not null access Root_Stream_Type'Class;
376
      HT     : out Hash_Table_Type)
377
   is
378
      N  : Count_Type'Base;
379
      NN : Hash_Type;
380
 
381
   begin
382
      Clear (HT);
383
 
384
      Count_Type'Base'Read (Stream, N);
385
 
386
      if N < 0 then
387
         raise Program_Error with "stream appears to be corrupt";
388
      end if;
389
 
390
      if N = 0 then
391
         return;
392
      end if;
393
 
394
      --  The RM does not specify whether or how the capacity changes when a
395
      --  hash table is streamed in. Therefore we decide here to allocate a new
396
      --  buckets array only when it's necessary to preserve representation
397
      --  invariants.
398
 
399
      if HT.Buckets = null
400
        or else HT.Buckets'Length < N
401
      then
402
         Free_Buckets (HT.Buckets);
403
         NN := Prime_Numbers.To_Prime (N);
404
         HT.Buckets := New_Buckets (Length => NN);
405
      end if;
406
 
407
      for J in 1 .. N loop
408
         declare
409
            Node : constant Node_Access := New_Node (Stream);
410
            Indx : constant Hash_Type := Index (HT, Node);
411
            B    : Node_Access renames HT.Buckets (Indx);
412
         begin
413
            Set_Next (Node => Node, Next => B);
414
            B := Node;
415
         end;
416
 
417
         HT.Length := HT.Length + 1;
418
      end loop;
419
   end Generic_Read;
420
 
421
   -------------------
422
   -- Generic_Write --
423
   -------------------
424
 
425
   procedure Generic_Write
426
     (Stream : not null access Root_Stream_Type'Class;
427
      HT     : Hash_Table_Type)
428
   is
429
      procedure Write (Node : Node_Access);
430
      pragma Inline (Write);
431
 
432
      procedure Write is new Generic_Iteration (Write);
433
 
434
      -----------
435
      -- Write --
436
      -----------
437
 
438
      procedure Write (Node : Node_Access) is
439
      begin
440
         Write (Stream, Node);
441
      end Write;
442
 
443
   begin
444
      --  See Generic_Read for an explanation of why we do not stream out the
445
      --  buckets array length too.
446
 
447
      Count_Type'Base'Write (Stream, HT.Length);
448
      Write (HT);
449
   end Generic_Write;
450
 
451
   -----------
452
   -- Index --
453
   -----------
454
 
455
   function Index
456
     (Buckets : Buckets_Type;
457
      Node    : Node_Access) return Hash_Type is
458
   begin
459
      return Hash_Node (Node) mod Buckets'Length;
460
   end Index;
461
 
462
   function Index
463
     (Hash_Table : Hash_Table_Type;
464
      Node       : Node_Access) return Hash_Type is
465
   begin
466
      return Index (Hash_Table.Buckets.all, Node);
467
   end Index;
468
 
469
   ----------
470
   -- Move --
471
   ----------
472
 
473
   procedure Move (Target, Source : in out Hash_Table_Type) is
474
   begin
475
      if Target'Address = Source'Address then
476
         return;
477
      end if;
478
 
479
      if Source.Busy > 0 then
480
         raise Program_Error with
481
           "attempt to tamper with cursors (container is busy)";
482
      end if;
483
 
484
      Clear (Target);
485
 
486
      declare
487
         Buckets : constant Buckets_Access := Target.Buckets;
488
      begin
489
         Target.Buckets := Source.Buckets;
490
         Source.Buckets := Buckets;
491
      end;
492
 
493
      Target.Length := Source.Length;
494
      Source.Length := 0;
495
   end Move;
496
 
497
   -----------------
498
   -- New_Buckets --
499
   -----------------
500
 
501
   function New_Buckets (Length : Hash_Type) return Buckets_Access is
502
      subtype Rng is Hash_Type range 0 .. Length - 1;
503
 
504
   begin
505
      --  Allocate in Buckets_Allocation'Storage_Pool, then convert to
506
      --  Buckets_Access.
507
 
508
      return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng)));
509
   end New_Buckets;
510
 
511
   ----------
512
   -- Next --
513
   ----------
514
 
515
   function Next
516
     (HT   : Hash_Table_Type;
517
      Node : Node_Access) return Node_Access
518
   is
519
      Result : Node_Access := Next (Node);
520
 
521
   begin
522
      if Result /= null then
523
         return Result;
524
      end if;
525
 
526
      for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
527
         Result := HT.Buckets (Indx);
528
 
529
         if Result /= null then
530
            return Result;
531
         end if;
532
      end loop;
533
 
534
      return null;
535
   end Next;
536
 
537
   ----------------------
538
   -- Reserve_Capacity --
539
   ----------------------
540
 
541
   procedure Reserve_Capacity
542
     (HT : in out Hash_Table_Type;
543
      N  : Count_Type)
544
   is
545
      NN : Hash_Type;
546
 
547
   begin
548
      if HT.Buckets = null then
549
         if N > 0 then
550
            NN := Prime_Numbers.To_Prime (N);
551
            HT.Buckets := New_Buckets (Length => NN);
552
         end if;
553
 
554
         return;
555
      end if;
556
 
557
      if HT.Length = 0 then
558
 
559
         --  This is the easy case. There are no nodes, so no rehashing is
560
         --  necessary. All we need to do is allocate a new buckets array
561
         --  having a length implied by the specified capacity. (We say
562
         --  "implied by" because bucket arrays are always allocated with a
563
         --  length that corresponds to a prime number.)
564
 
565
         if N = 0 then
566
            Free_Buckets (HT.Buckets);
567
            return;
568
         end if;
569
 
570
         if N = HT.Buckets'Length then
571
            return;
572
         end if;
573
 
574
         NN := Prime_Numbers.To_Prime (N);
575
 
576
         if NN = HT.Buckets'Length then
577
            return;
578
         end if;
579
 
580
         declare
581
            X : Buckets_Access := HT.Buckets;
582
            pragma Warnings (Off, X);
583
         begin
584
            HT.Buckets := New_Buckets (Length => NN);
585
            Free_Buckets (X);
586
         end;
587
 
588
         return;
589
      end if;
590
 
591
      if N = HT.Buckets'Length then
592
         return;
593
      end if;
594
 
595
      if N < HT.Buckets'Length then
596
 
597
         --  This is a request to contract the buckets array. The amount of
598
         --  contraction is bounded in order to preserve the invariant that the
599
         --  buckets array length is never smaller than the number of elements
600
         --  (the load factor is 1).
601
 
602
         if HT.Length >= HT.Buckets'Length then
603
            return;
604
         end if;
605
 
606
         NN := Prime_Numbers.To_Prime (HT.Length);
607
 
608
         if NN >= HT.Buckets'Length then
609
            return;
610
         end if;
611
 
612
      else
613
         NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
614
 
615
         if NN = HT.Buckets'Length then -- can't expand any more
616
            return;
617
         end if;
618
      end if;
619
 
620
      if HT.Busy > 0 then
621
         raise Program_Error with
622
           "attempt to tamper with cursors (container is busy)";
623
      end if;
624
 
625
      Rehash : declare
626
         Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
627
         Src_Buckets : Buckets_Access := HT.Buckets;
628
         pragma Warnings (Off, Src_Buckets);
629
 
630
         L : Count_Type renames HT.Length;
631
         LL : constant Count_Type := L;
632
 
633
         Src_Index : Hash_Type := Src_Buckets'First;
634
 
635
      begin
636
         while L > 0 loop
637
            declare
638
               Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
639
 
640
            begin
641
               while Src_Bucket /= null loop
642
                  declare
643
                     Src_Node : constant Node_Access := Src_Bucket;
644
 
645
                     Dst_Index : constant Hash_Type :=
646
                       Index (Dst_Buckets.all, Src_Node);
647
 
648
                     Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
649
 
650
                  begin
651
                     Src_Bucket := Next (Src_Node);
652
 
653
                     Set_Next (Src_Node, Dst_Bucket);
654
 
655
                     Dst_Bucket := Src_Node;
656
                  end;
657
 
658
                  pragma Assert (L > 0);
659
                  L := L - 1;
660
               end loop;
661
            exception
662
               when others =>
663
                  --  If there's an error computing a hash value during a
664
                  --  rehash, then AI-302 says the nodes "become lost."  The
665
                  --  issue is whether to actually deallocate these lost nodes,
666
                  --  since they might be designated by extant cursors.  Here
667
                  --  we decide to deallocate the nodes, since it's better to
668
                  --  solve real problems (storage consumption) rather than
669
                  --  imaginary ones (the user might, or might not, dereference
670
                  --  a cursor designating a node that has been deallocated),
671
                  --  and because we have a way to vet a dangling cursor
672
                  --  reference anyway, and hence can actually detect the
673
                  --  problem.
674
 
675
                  for Dst_Index in Dst_Buckets'Range loop
676
                     declare
677
                        B : Node_Access renames Dst_Buckets (Dst_Index);
678
                        X : Node_Access;
679
                     begin
680
                        while B /= null loop
681
                           X := B;
682
                           B := Next (X);
683
                           Free (X);
684
                        end loop;
685
                     end;
686
                  end loop;
687
 
688
                  Free_Buckets (Dst_Buckets);
689
                  raise Program_Error with
690
                    "hash function raised exception during rehash";
691
            end;
692
 
693
            Src_Index := Src_Index + 1;
694
         end loop;
695
 
696
         HT.Buckets := Dst_Buckets;
697
         HT.Length := LL;
698
 
699
         Free_Buckets (Src_Buckets);
700
      end Rehash;
701
   end Reserve_Capacity;
702
 
703
end Ada.Containers.Hash_Tables.Generic_Operations;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.