OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [a-cohase.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT LIBRARY COMPONENTS                          --
4
--                                                                          --
5
--           A D A . C O N T A I N E R S . H A S H E D _ S E T S            --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2004-2009, 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.Unchecked_Deallocation;
31
 
32
with Ada.Containers.Hash_Tables.Generic_Operations;
33
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
34
 
35
with Ada.Containers.Hash_Tables.Generic_Keys;
36
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
37
 
38
with Ada.Containers.Prime_Numbers;
39
 
40
with System; use type System.Address;
41
 
42
package body Ada.Containers.Hashed_Sets is
43
 
44
   -----------------------
45
   -- Local Subprograms --
46
   -----------------------
47
 
48
   procedure Assign (Node : Node_Access; Item : Element_Type);
49
   pragma Inline (Assign);
50
 
51
   function Copy_Node (Source : Node_Access) return Node_Access;
52
   pragma Inline (Copy_Node);
53
 
54
   function Equivalent_Keys
55
     (Key  : Element_Type;
56
      Node : Node_Access) return Boolean;
57
   pragma Inline (Equivalent_Keys);
58
 
59
   function Find_Equal_Key
60
     (R_HT   : Hash_Table_Type;
61
      L_Node : Node_Access) return Boolean;
62
 
63
   function Find_Equivalent_Key
64
     (R_HT   : Hash_Table_Type;
65
      L_Node : Node_Access) return Boolean;
66
 
67
   procedure Free (X : in out Node_Access);
68
 
69
   function Hash_Node (Node : Node_Access) return Hash_Type;
70
   pragma Inline (Hash_Node);
71
 
72
   procedure Insert
73
     (HT       : in out Hash_Table_Type;
74
      New_Item : Element_Type;
75
      Node     : out Node_Access;
76
      Inserted : out Boolean);
77
 
78
   function Is_In
79
     (HT  : Hash_Table_Type;
80
      Key : Node_Access) return Boolean;
81
   pragma Inline (Is_In);
82
 
83
   function Next (Node : Node_Access) return Node_Access;
84
   pragma Inline (Next);
85
 
86
   function Read_Node (Stream : not null access Root_Stream_Type'Class)
87
     return Node_Access;
88
   pragma Inline (Read_Node);
89
 
90
   procedure Set_Next (Node : Node_Access; Next : Node_Access);
91
   pragma Inline (Set_Next);
92
 
93
   function Vet (Position : Cursor) return Boolean;
94
 
95
   procedure Write_Node
96
     (Stream : not null access Root_Stream_Type'Class;
97
      Node   : Node_Access);
98
   pragma Inline (Write_Node);
99
 
100
   --------------------------
101
   -- Local Instantiations --
102
   --------------------------
103
 
104
   package HT_Ops is new Hash_Tables.Generic_Operations
105
     (HT_Types  => HT_Types,
106
      Hash_Node => Hash_Node,
107
      Next      => Next,
108
      Set_Next  => Set_Next,
109
      Copy_Node => Copy_Node,
110
      Free      => Free);
111
 
112
   package Element_Keys is new Hash_Tables.Generic_Keys
113
     (HT_Types        => HT_Types,
114
      Next            => Next,
115
      Set_Next        => Set_Next,
116
      Key_Type        => Element_Type,
117
      Hash            => Hash,
118
      Equivalent_Keys => Equivalent_Keys);
119
 
120
   function Is_Equal is
121
      new HT_Ops.Generic_Equal (Find_Equal_Key);
122
 
123
   function Is_Equivalent is
124
      new HT_Ops.Generic_Equal (Find_Equivalent_Key);
125
 
126
   procedure Read_Nodes is
127
      new HT_Ops.Generic_Read (Read_Node);
128
 
129
   procedure Replace_Element is
130
      new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
131
 
132
   procedure Write_Nodes is
133
      new HT_Ops.Generic_Write (Write_Node);
134
 
135
   ---------
136
   -- "=" --
137
   ---------
138
 
139
   function "=" (Left, Right : Set) return Boolean is
140
   begin
141
      return Is_Equal (Left.HT, Right.HT);
142
   end "=";
143
 
144
   ------------
145
   -- Adjust --
146
   ------------
147
 
148
   procedure Adjust (Container : in out Set) is
149
   begin
150
      HT_Ops.Adjust (Container.HT);
151
   end Adjust;
152
 
153
   ------------
154
   -- Assign --
155
   ------------
156
 
157
   procedure Assign (Node : Node_Access; Item : Element_Type) is
158
   begin
159
      Node.Element := Item;
160
   end Assign;
161
 
162
   --------------
163
   -- Capacity --
164
   --------------
165
 
166
   function Capacity (Container : Set) return Count_Type is
167
   begin
168
      return HT_Ops.Capacity (Container.HT);
169
   end Capacity;
170
 
171
   -----------
172
   -- Clear --
173
   -----------
174
 
175
   procedure Clear (Container : in out Set) is
176
   begin
177
      HT_Ops.Clear (Container.HT);
178
   end Clear;
179
 
180
   --------------
181
   -- Contains --
182
   --------------
183
 
184
   function Contains (Container : Set; Item : Element_Type) return Boolean is
185
   begin
186
      return Find (Container, Item) /= No_Element;
187
   end Contains;
188
 
189
   ---------------
190
   -- Copy_Node --
191
   ---------------
192
 
193
   function Copy_Node (Source : Node_Access) return Node_Access is
194
   begin
195
      return new Node_Type'(Element => Source.Element, Next => null);
196
   end Copy_Node;
197
 
198
   ------------
199
   -- Delete --
200
   ------------
201
 
202
   procedure Delete
203
     (Container : in out Set;
204
      Item      : Element_Type)
205
   is
206
      X : Node_Access;
207
 
208
   begin
209
      Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
210
 
211
      if X = null then
212
         raise Constraint_Error with "attempt to delete element not in set";
213
      end if;
214
 
215
      Free (X);
216
   end Delete;
217
 
218
   procedure Delete
219
     (Container : in out Set;
220
      Position  : in out Cursor)
221
   is
222
   begin
223
      if Position.Node = null then
224
         raise Constraint_Error with "Position cursor equals No_Element";
225
      end if;
226
 
227
      if Position.Container /= Container'Unrestricted_Access then
228
         raise Program_Error with "Position cursor designates wrong set";
229
      end if;
230
 
231
      if Container.HT.Busy > 0 then
232
         raise Program_Error with
233
           "attempt to tamper with elements (set is busy)";
234
      end if;
235
 
236
      pragma Assert (Vet (Position), "bad cursor in Delete");
237
 
238
      HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
239
 
240
      Free (Position.Node);
241
      Position.Container := null;
242
   end Delete;
243
 
244
   ----------------
245
   -- Difference --
246
   ----------------
247
 
248
   procedure Difference
249
     (Target : in out Set;
250
      Source : Set)
251
   is
252
      Tgt_Node : Node_Access;
253
 
254
   begin
255
      if Target'Address = Source'Address then
256
         Clear (Target);
257
         return;
258
      end if;
259
 
260
      if Source.HT.Length = 0 then
261
         return;
262
      end if;
263
 
264
      if Target.HT.Busy > 0 then
265
         raise Program_Error with
266
           "attempt to tamper with elements (set is busy)";
267
      end if;
268
 
269
      if Source.HT.Length < Target.HT.Length then
270
         declare
271
            Src_Node : Node_Access;
272
 
273
         begin
274
            Src_Node := HT_Ops.First (Source.HT);
275
            while Src_Node /= null loop
276
               Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
277
 
278
               if Tgt_Node /= null then
279
                  HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
280
                  Free (Tgt_Node);
281
               end if;
282
 
283
               Src_Node := HT_Ops.Next (Source.HT, Src_Node);
284
            end loop;
285
         end;
286
 
287
      else
288
         Tgt_Node := HT_Ops.First (Target.HT);
289
         while Tgt_Node /= null loop
290
            if Is_In (Source.HT, Tgt_Node) then
291
               declare
292
                  X : Node_Access := Tgt_Node;
293
               begin
294
                  Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
295
                  HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
296
                  Free (X);
297
               end;
298
 
299
            else
300
               Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
301
            end if;
302
         end loop;
303
      end if;
304
   end Difference;
305
 
306
   function Difference (Left, Right : Set) return Set is
307
      Buckets : HT_Types.Buckets_Access;
308
      Length  : Count_Type;
309
 
310
   begin
311
      if Left'Address = Right'Address then
312
         return Empty_Set;
313
      end if;
314
 
315
      if Left.HT.Length = 0 then
316
         return Empty_Set;
317
      end if;
318
 
319
      if Right.HT.Length = 0 then
320
         return Left;
321
      end if;
322
 
323
      declare
324
         Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
325
      begin
326
         Buckets := HT_Ops.New_Buckets (Length => Size);
327
      end;
328
 
329
      Length := 0;
330
 
331
      Iterate_Left : declare
332
         procedure Process (L_Node : Node_Access);
333
 
334
         procedure Iterate is
335
            new HT_Ops.Generic_Iteration (Process);
336
 
337
         -------------
338
         -- Process --
339
         -------------
340
 
341
         procedure Process (L_Node : Node_Access) is
342
         begin
343
            if not Is_In (Right.HT, L_Node) then
344
               declare
345
                  J : constant Hash_Type :=
346
                        Hash (L_Node.Element) mod Buckets'Length;
347
 
348
                  Bucket : Node_Access renames Buckets (J);
349
 
350
               begin
351
                  Bucket := new Node_Type'(L_Node.Element, Bucket);
352
               end;
353
 
354
               Length := Length + 1;
355
            end if;
356
         end Process;
357
 
358
      --  Start of processing for Iterate_Left
359
 
360
      begin
361
         Iterate (Left.HT);
362
      exception
363
         when others =>
364
            HT_Ops.Free_Hash_Table (Buckets);
365
            raise;
366
      end Iterate_Left;
367
 
368
      return (Controlled with HT => (Buckets, Length, 0, 0));
369
   end Difference;
370
 
371
   -------------
372
   -- Element --
373
   -------------
374
 
375
   function Element (Position : Cursor) return Element_Type is
376
   begin
377
      if Position.Node = null then
378
         raise Constraint_Error with "Position cursor equals No_Element";
379
      end if;
380
 
381
      pragma Assert (Vet (Position), "bad cursor in function Element");
382
 
383
      return Position.Node.Element;
384
   end Element;
385
 
386
   ---------------------
387
   -- Equivalent_Sets --
388
   ---------------------
389
 
390
   function Equivalent_Sets (Left, Right : Set) return Boolean is
391
   begin
392
      return Is_Equivalent (Left.HT, Right.HT);
393
   end Equivalent_Sets;
394
 
395
   -------------------------
396
   -- Equivalent_Elements --
397
   -------------------------
398
 
399
   function Equivalent_Elements (Left, Right : Cursor)
400
     return Boolean is
401
   begin
402
      if Left.Node = null then
403
         raise Constraint_Error with
404
           "Left cursor of Equivalent_Elements equals No_Element";
405
      end if;
406
 
407
      if Right.Node = null then
408
         raise Constraint_Error with
409
           "Right cursor of Equivalent_Elements equals No_Element";
410
      end if;
411
 
412
      pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
413
      pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
414
 
415
      return Equivalent_Elements (Left.Node.Element, Right.Node.Element);
416
   end Equivalent_Elements;
417
 
418
   function Equivalent_Elements (Left : Cursor; Right : Element_Type)
419
     return Boolean is
420
   begin
421
      if Left.Node = null then
422
         raise Constraint_Error with
423
           "Left cursor of Equivalent_Elements equals No_Element";
424
      end if;
425
 
426
      pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad");
427
 
428
      return Equivalent_Elements (Left.Node.Element, Right);
429
   end Equivalent_Elements;
430
 
431
   function Equivalent_Elements (Left : Element_Type; Right : Cursor)
432
     return Boolean is
433
   begin
434
      if Right.Node = null then
435
         raise Constraint_Error with
436
           "Right cursor of Equivalent_Elements equals No_Element";
437
      end if;
438
 
439
      pragma Assert
440
        (Vet (Right),
441
         "Right cursor of Equivalent_Elements is bad");
442
 
443
      return Equivalent_Elements (Left, Right.Node.Element);
444
   end Equivalent_Elements;
445
 
446
   ---------------------
447
   -- Equivalent_Keys --
448
   ---------------------
449
 
450
   function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
451
     return Boolean is
452
   begin
453
      return Equivalent_Elements (Key, Node.Element);
454
   end Equivalent_Keys;
455
 
456
   -------------
457
   -- Exclude --
458
   -------------
459
 
460
   procedure Exclude
461
     (Container : in out Set;
462
      Item      : Element_Type)
463
   is
464
      X : Node_Access;
465
   begin
466
      Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
467
      Free (X);
468
   end Exclude;
469
 
470
   --------------
471
   -- Finalize --
472
   --------------
473
 
474
   procedure Finalize (Container : in out Set) is
475
   begin
476
      HT_Ops.Finalize (Container.HT);
477
   end Finalize;
478
 
479
   ----------
480
   -- Find --
481
   ----------
482
 
483
   function Find
484
     (Container : Set;
485
      Item      : Element_Type) return Cursor
486
   is
487
      Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
488
 
489
   begin
490
      if Node = null then
491
         return No_Element;
492
      end if;
493
 
494
      return Cursor'(Container'Unrestricted_Access, Node);
495
   end Find;
496
 
497
   --------------------
498
   -- Find_Equal_Key --
499
   --------------------
500
 
501
   function Find_Equal_Key
502
     (R_HT   : Hash_Table_Type;
503
      L_Node : Node_Access) return Boolean
504
   is
505
      R_Index : constant Hash_Type :=
506
                  Element_Keys.Index (R_HT, L_Node.Element);
507
 
508
      R_Node  : Node_Access := R_HT.Buckets (R_Index);
509
 
510
   begin
511
      loop
512
         if R_Node = null then
513
            return False;
514
         end if;
515
 
516
         if L_Node.Element = R_Node.Element then
517
            return True;
518
         end if;
519
 
520
         R_Node := Next (R_Node);
521
      end loop;
522
   end Find_Equal_Key;
523
 
524
   -------------------------
525
   -- Find_Equivalent_Key --
526
   -------------------------
527
 
528
   function Find_Equivalent_Key
529
     (R_HT   : Hash_Table_Type;
530
      L_Node : Node_Access) return Boolean
531
   is
532
      R_Index : constant Hash_Type :=
533
                  Element_Keys.Index (R_HT, L_Node.Element);
534
 
535
      R_Node  : Node_Access := R_HT.Buckets (R_Index);
536
 
537
   begin
538
      loop
539
         if R_Node = null then
540
            return False;
541
         end if;
542
 
543
         if Equivalent_Elements (L_Node.Element, R_Node.Element) then
544
            return True;
545
         end if;
546
 
547
         R_Node := Next (R_Node);
548
      end loop;
549
   end Find_Equivalent_Key;
550
 
551
   -----------
552
   -- First --
553
   -----------
554
 
555
   function First (Container : Set) return Cursor is
556
      Node : constant Node_Access := HT_Ops.First (Container.HT);
557
 
558
   begin
559
      if Node = null then
560
         return No_Element;
561
      end if;
562
 
563
      return Cursor'(Container'Unrestricted_Access, Node);
564
   end First;
565
 
566
   ----------
567
   -- Free --
568
   ----------
569
 
570
   procedure Free (X : in out Node_Access) is
571
      procedure Deallocate is
572
         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
573
 
574
   begin
575
      if X /= null then
576
         X.Next := X;     --  detect mischief (in Vet)
577
         Deallocate (X);
578
      end if;
579
   end Free;
580
 
581
   -----------------
582
   -- Has_Element --
583
   -----------------
584
 
585
   function Has_Element (Position : Cursor) return Boolean is
586
   begin
587
      pragma Assert (Vet (Position), "bad cursor in Has_Element");
588
      return Position.Node /= null;
589
   end Has_Element;
590
 
591
   ---------------
592
   -- Hash_Node --
593
   ---------------
594
 
595
   function Hash_Node (Node : Node_Access) return Hash_Type is
596
   begin
597
      return Hash (Node.Element);
598
   end Hash_Node;
599
 
600
   -------------
601
   -- Include --
602
   -------------
603
 
604
   procedure Include
605
     (Container : in out Set;
606
      New_Item  : Element_Type)
607
   is
608
      Position : Cursor;
609
      Inserted : Boolean;
610
 
611
   begin
612
      Insert (Container, New_Item, Position, Inserted);
613
 
614
      if not Inserted then
615
         if Container.HT.Lock > 0 then
616
            raise Program_Error with
617
              "attempt to tamper with cursors (set is locked)";
618
         end if;
619
 
620
         Position.Node.Element := New_Item;
621
      end if;
622
   end Include;
623
 
624
   ------------
625
   -- Insert --
626
   ------------
627
 
628
   procedure Insert
629
     (Container : in out Set;
630
      New_Item  : Element_Type;
631
      Position  : out Cursor;
632
      Inserted  : out Boolean)
633
   is
634
   begin
635
      Insert (Container.HT, New_Item, Position.Node, Inserted);
636
      Position.Container := Container'Unchecked_Access;
637
   end Insert;
638
 
639
   procedure Insert
640
     (Container : in out Set;
641
      New_Item  : Element_Type)
642
   is
643
      Position : Cursor;
644
      pragma Unreferenced (Position);
645
 
646
      Inserted : Boolean;
647
 
648
   begin
649
      Insert (Container, New_Item, Position, Inserted);
650
 
651
      if not Inserted then
652
         raise Constraint_Error with
653
           "attempt to insert element already in set";
654
      end if;
655
   end Insert;
656
 
657
   procedure Insert
658
     (HT       : in out Hash_Table_Type;
659
      New_Item : Element_Type;
660
      Node     : out Node_Access;
661
      Inserted : out Boolean)
662
   is
663
      function New_Node (Next : Node_Access) return Node_Access;
664
      pragma Inline (New_Node);
665
 
666
      procedure Local_Insert is
667
        new Element_Keys.Generic_Conditional_Insert (New_Node);
668
 
669
      --------------
670
      -- New_Node --
671
      --------------
672
 
673
      function New_Node (Next : Node_Access) return Node_Access is
674
      begin
675
         return new Node_Type'(New_Item, Next);
676
      end New_Node;
677
 
678
   --  Start of processing for Insert
679
 
680
   begin
681
      if HT_Ops.Capacity (HT) = 0 then
682
         HT_Ops.Reserve_Capacity (HT, 1);
683
      end if;
684
 
685
      Local_Insert (HT, New_Item, Node, Inserted);
686
 
687
      if Inserted
688
        and then HT.Length > HT_Ops.Capacity (HT)
689
      then
690
         HT_Ops.Reserve_Capacity (HT, HT.Length);
691
      end if;
692
   end Insert;
693
 
694
   ------------------
695
   -- Intersection --
696
   ------------------
697
 
698
   procedure Intersection
699
     (Target : in out Set;
700
      Source : Set)
701
   is
702
      Tgt_Node : Node_Access;
703
 
704
   begin
705
      if Target'Address = Source'Address then
706
         return;
707
      end if;
708
 
709
      if Source.HT.Length = 0 then
710
         Clear (Target);
711
         return;
712
      end if;
713
 
714
      if Target.HT.Busy > 0 then
715
         raise Program_Error with
716
           "attempt to tamper with elements (set is busy)";
717
      end if;
718
 
719
      Tgt_Node := HT_Ops.First (Target.HT);
720
      while Tgt_Node /= null loop
721
         if Is_In (Source.HT, Tgt_Node) then
722
            Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
723
 
724
         else
725
            declare
726
               X : Node_Access := Tgt_Node;
727
            begin
728
               Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
729
               HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
730
               Free (X);
731
            end;
732
         end if;
733
      end loop;
734
   end Intersection;
735
 
736
   function Intersection (Left, Right : Set) return Set is
737
      Buckets : HT_Types.Buckets_Access;
738
      Length  : Count_Type;
739
 
740
   begin
741
      if Left'Address = Right'Address then
742
         return Left;
743
      end if;
744
 
745
      Length := Count_Type'Min (Left.Length, Right.Length);
746
 
747
      if Length = 0 then
748
         return Empty_Set;
749
      end if;
750
 
751
      declare
752
         Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
753
      begin
754
         Buckets := HT_Ops.New_Buckets (Length => Size);
755
      end;
756
 
757
      Length := 0;
758
 
759
      Iterate_Left : declare
760
         procedure Process (L_Node : Node_Access);
761
 
762
         procedure Iterate is
763
            new HT_Ops.Generic_Iteration (Process);
764
 
765
         -------------
766
         -- Process --
767
         -------------
768
 
769
         procedure Process (L_Node : Node_Access) is
770
         begin
771
            if Is_In (Right.HT, L_Node) then
772
               declare
773
                  J : constant Hash_Type :=
774
                        Hash (L_Node.Element) mod Buckets'Length;
775
 
776
                  Bucket : Node_Access renames Buckets (J);
777
 
778
               begin
779
                  Bucket := new Node_Type'(L_Node.Element, Bucket);
780
               end;
781
 
782
               Length := Length + 1;
783
            end if;
784
         end Process;
785
 
786
      --  Start of processing for Iterate_Left
787
 
788
      begin
789
         Iterate (Left.HT);
790
      exception
791
         when others =>
792
            HT_Ops.Free_Hash_Table (Buckets);
793
            raise;
794
      end Iterate_Left;
795
 
796
      return (Controlled with HT => (Buckets, Length, 0, 0));
797
   end Intersection;
798
 
799
   --------------
800
   -- Is_Empty --
801
   --------------
802
 
803
   function Is_Empty (Container : Set) return Boolean is
804
   begin
805
      return Container.HT.Length = 0;
806
   end Is_Empty;
807
 
808
   -----------
809
   -- Is_In --
810
   -----------
811
 
812
   function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
813
   begin
814
      return Element_Keys.Find (HT, Key.Element) /= null;
815
   end Is_In;
816
 
817
   ---------------
818
   -- Is_Subset --
819
   ---------------
820
 
821
   function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
822
      Subset_Node : Node_Access;
823
 
824
   begin
825
      if Subset'Address = Of_Set'Address then
826
         return True;
827
      end if;
828
 
829
      if Subset.Length > Of_Set.Length then
830
         return False;
831
      end if;
832
 
833
      Subset_Node := HT_Ops.First (Subset.HT);
834
      while Subset_Node /= null loop
835
         if not Is_In (Of_Set.HT, Subset_Node) then
836
            return False;
837
         end if;
838
         Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
839
      end loop;
840
 
841
      return True;
842
   end Is_Subset;
843
 
844
   -------------
845
   -- Iterate --
846
   -------------
847
 
848
   procedure Iterate
849
     (Container : Set;
850
      Process   : not null access procedure (Position : Cursor))
851
   is
852
      procedure Process_Node (Node : Node_Access);
853
      pragma Inline (Process_Node);
854
 
855
      procedure Iterate is
856
         new HT_Ops.Generic_Iteration (Process_Node);
857
 
858
      ------------------
859
      -- Process_Node --
860
      ------------------
861
 
862
      procedure Process_Node (Node : Node_Access) is
863
      begin
864
         Process (Cursor'(Container'Unrestricted_Access, Node));
865
      end Process_Node;
866
 
867
      B : Natural renames Container'Unrestricted_Access.HT.Busy;
868
 
869
   --  Start of processing for Iterate
870
 
871
   begin
872
      B := B + 1;
873
 
874
      begin
875
         Iterate (Container.HT);
876
      exception
877
         when others =>
878
            B := B - 1;
879
            raise;
880
      end;
881
 
882
      B := B - 1;
883
   end Iterate;
884
 
885
   ------------
886
   -- Length --
887
   ------------
888
 
889
   function Length (Container : Set) return Count_Type is
890
   begin
891
      return Container.HT.Length;
892
   end Length;
893
 
894
   ----------
895
   -- Move --
896
   ----------
897
 
898
   procedure Move (Target : in out Set; Source : in out Set) is
899
   begin
900
      HT_Ops.Move (Target => Target.HT, Source => Source.HT);
901
   end Move;
902
 
903
   ----------
904
   -- Next --
905
   ----------
906
 
907
   function Next (Node : Node_Access) return Node_Access is
908
   begin
909
      return Node.Next;
910
   end Next;
911
 
912
   function Next (Position : Cursor) return Cursor is
913
   begin
914
      if Position.Node = null then
915
         return No_Element;
916
      end if;
917
 
918
      pragma Assert (Vet (Position), "bad cursor in Next");
919
 
920
      declare
921
         HT   : Hash_Table_Type renames Position.Container.HT;
922
         Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
923
 
924
      begin
925
         if Node = null then
926
            return No_Element;
927
         end if;
928
 
929
         return Cursor'(Position.Container, Node);
930
      end;
931
   end Next;
932
 
933
   procedure Next (Position : in out Cursor) is
934
   begin
935
      Position := Next (Position);
936
   end Next;
937
 
938
   -------------
939
   -- Overlap --
940
   -------------
941
 
942
   function Overlap (Left, Right : Set) return Boolean is
943
      Left_Node : Node_Access;
944
 
945
   begin
946
      if Right.Length = 0 then
947
         return False;
948
      end if;
949
 
950
      if Left'Address = Right'Address then
951
         return True;
952
      end if;
953
 
954
      Left_Node := HT_Ops.First (Left.HT);
955
      while Left_Node /= null loop
956
         if Is_In (Right.HT, Left_Node) then
957
            return True;
958
         end if;
959
         Left_Node := HT_Ops.Next (Left.HT, Left_Node);
960
      end loop;
961
 
962
      return False;
963
   end Overlap;
964
 
965
   -------------------
966
   -- Query_Element --
967
   -------------------
968
 
969
   procedure Query_Element
970
     (Position : Cursor;
971
      Process  : not null access procedure (Element : Element_Type))
972
   is
973
   begin
974
      if Position.Node = null then
975
         raise Constraint_Error with
976
           "Position cursor of Query_Element equals No_Element";
977
      end if;
978
 
979
      pragma Assert (Vet (Position), "bad cursor in Query_Element");
980
 
981
      declare
982
         HT : Hash_Table_Type renames Position.Container.HT;
983
 
984
         B : Natural renames HT.Busy;
985
         L : Natural renames HT.Lock;
986
 
987
      begin
988
         B := B + 1;
989
         L := L + 1;
990
 
991
         begin
992
            Process (Position.Node.Element);
993
         exception
994
            when others =>
995
               L := L - 1;
996
               B := B - 1;
997
               raise;
998
         end;
999
 
1000
         L := L - 1;
1001
         B := B - 1;
1002
      end;
1003
   end Query_Element;
1004
 
1005
   ----------
1006
   -- Read --
1007
   ----------
1008
 
1009
   procedure Read
1010
     (Stream    : not null access Root_Stream_Type'Class;
1011
      Container : out Set)
1012
   is
1013
   begin
1014
      Read_Nodes (Stream, Container.HT);
1015
   end Read;
1016
 
1017
   procedure Read
1018
     (Stream : not null access Root_Stream_Type'Class;
1019
      Item   : out Cursor)
1020
   is
1021
   begin
1022
      raise Program_Error with "attempt to stream set cursor";
1023
   end Read;
1024
 
1025
   ---------------
1026
   -- Read_Node --
1027
   ---------------
1028
 
1029
   function Read_Node (Stream : not null access Root_Stream_Type'Class)
1030
     return Node_Access
1031
   is
1032
      Node : Node_Access := new Node_Type;
1033
 
1034
   begin
1035
      Element_Type'Read (Stream, Node.Element);
1036
      return Node;
1037
   exception
1038
      when others =>
1039
         Free (Node);
1040
         raise;
1041
   end Read_Node;
1042
 
1043
   -------------
1044
   -- Replace --
1045
   -------------
1046
 
1047
   procedure Replace
1048
     (Container : in out Set;
1049
      New_Item  : Element_Type)
1050
   is
1051
      Node : constant Node_Access :=
1052
               Element_Keys.Find (Container.HT, New_Item);
1053
 
1054
   begin
1055
      if Node = null then
1056
         raise Constraint_Error with
1057
           "attempt to replace element not in set";
1058
      end if;
1059
 
1060
      if Container.HT.Lock > 0 then
1061
         raise Program_Error with
1062
           "attempt to tamper with cursors (set is locked)";
1063
      end if;
1064
 
1065
      Node.Element := New_Item;
1066
   end Replace;
1067
 
1068
   procedure Replace_Element
1069
     (Container : in out Set;
1070
      Position  : Cursor;
1071
      New_Item  : Element_Type)
1072
   is
1073
   begin
1074
      if Position.Node = null then
1075
         raise Constraint_Error with
1076
           "Position cursor equals No_Element";
1077
      end if;
1078
 
1079
      if Position.Container /= Container'Unrestricted_Access then
1080
         raise Program_Error with
1081
           "Position cursor designates wrong set";
1082
      end if;
1083
 
1084
      pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1085
 
1086
      Replace_Element (Container.HT, Position.Node, New_Item);
1087
   end Replace_Element;
1088
 
1089
   ----------------------
1090
   -- Reserve_Capacity --
1091
   ----------------------
1092
 
1093
   procedure Reserve_Capacity
1094
     (Container : in out Set;
1095
      Capacity  : Count_Type)
1096
   is
1097
   begin
1098
      HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1099
   end Reserve_Capacity;
1100
 
1101
   --------------
1102
   -- Set_Next --
1103
   --------------
1104
 
1105
   procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1106
   begin
1107
      Node.Next := Next;
1108
   end Set_Next;
1109
 
1110
   --------------------------
1111
   -- Symmetric_Difference --
1112
   --------------------------
1113
 
1114
   procedure Symmetric_Difference
1115
     (Target : in out Set;
1116
      Source : Set)
1117
   is
1118
   begin
1119
      if Target'Address = Source'Address then
1120
         Clear (Target);
1121
         return;
1122
      end if;
1123
 
1124
      if Target.HT.Busy > 0 then
1125
         raise Program_Error with
1126
           "attempt to tamper with elements (set is busy)";
1127
      end if;
1128
 
1129
      declare
1130
         N : constant Count_Type := Target.Length + Source.Length;
1131
      begin
1132
         if N > HT_Ops.Capacity (Target.HT) then
1133
            HT_Ops.Reserve_Capacity (Target.HT, N);
1134
         end if;
1135
      end;
1136
 
1137
      if Target.Length = 0 then
1138
         Iterate_Source_When_Empty_Target : declare
1139
            procedure Process (Src_Node : Node_Access);
1140
 
1141
            procedure Iterate is
1142
               new HT_Ops.Generic_Iteration (Process);
1143
 
1144
            -------------
1145
            -- Process --
1146
            -------------
1147
 
1148
            procedure Process (Src_Node : Node_Access) is
1149
               E : Element_Type renames Src_Node.Element;
1150
               B : Buckets_Type renames Target.HT.Buckets.all;
1151
               J : constant Hash_Type := Hash (E) mod B'Length;
1152
               N : Count_Type renames Target.HT.Length;
1153
 
1154
            begin
1155
               B (J) := new Node_Type'(E, B (J));
1156
               N := N + 1;
1157
            end Process;
1158
 
1159
         --  Start of processing for Iterate_Source_When_Empty_Target
1160
 
1161
         begin
1162
            Iterate (Source.HT);
1163
         end Iterate_Source_When_Empty_Target;
1164
 
1165
      else
1166
         Iterate_Source : declare
1167
            procedure Process (Src_Node : Node_Access);
1168
 
1169
            procedure Iterate is
1170
               new HT_Ops.Generic_Iteration (Process);
1171
 
1172
            -------------
1173
            -- Process --
1174
            -------------
1175
 
1176
            procedure Process (Src_Node : Node_Access) is
1177
               E : Element_Type renames Src_Node.Element;
1178
               B : Buckets_Type renames Target.HT.Buckets.all;
1179
               J : constant Hash_Type := Hash (E) mod B'Length;
1180
               N : Count_Type renames Target.HT.Length;
1181
 
1182
            begin
1183
               if B (J) = null then
1184
                  B (J) := new Node_Type'(E, null);
1185
                  N := N + 1;
1186
 
1187
               elsif Equivalent_Elements (E, B (J).Element) then
1188
                  declare
1189
                     X : Node_Access := B (J);
1190
                  begin
1191
                     B (J) := B (J).Next;
1192
                     N := N - 1;
1193
                     Free (X);
1194
                  end;
1195
 
1196
               else
1197
                  declare
1198
                     Prev : Node_Access := B (J);
1199
                     Curr : Node_Access := Prev.Next;
1200
 
1201
                  begin
1202
                     while Curr /= null loop
1203
                        if Equivalent_Elements (E, Curr.Element) then
1204
                           Prev.Next := Curr.Next;
1205
                           N := N - 1;
1206
                           Free (Curr);
1207
                           return;
1208
                        end if;
1209
 
1210
                        Prev := Curr;
1211
                        Curr := Prev.Next;
1212
                     end loop;
1213
 
1214
                     B (J) := new Node_Type'(E, B (J));
1215
                     N := N + 1;
1216
                  end;
1217
               end if;
1218
            end Process;
1219
 
1220
         --  Start of processing for Iterate_Source
1221
 
1222
         begin
1223
            Iterate (Source.HT);
1224
         end Iterate_Source;
1225
      end if;
1226
   end Symmetric_Difference;
1227
 
1228
   function Symmetric_Difference (Left, Right : Set) return Set is
1229
      Buckets : HT_Types.Buckets_Access;
1230
      Length  : Count_Type;
1231
 
1232
   begin
1233
      if Left'Address = Right'Address then
1234
         return Empty_Set;
1235
      end if;
1236
 
1237
      if Right.Length = 0 then
1238
         return Left;
1239
      end if;
1240
 
1241
      if Left.Length = 0 then
1242
         return Right;
1243
      end if;
1244
 
1245
      declare
1246
         Size : constant Hash_Type :=
1247
                  Prime_Numbers.To_Prime (Left.Length + Right.Length);
1248
      begin
1249
         Buckets := HT_Ops.New_Buckets (Length => Size);
1250
      end;
1251
 
1252
      Length := 0;
1253
 
1254
      Iterate_Left : declare
1255
         procedure Process (L_Node : Node_Access);
1256
 
1257
         procedure Iterate is
1258
            new HT_Ops.Generic_Iteration (Process);
1259
 
1260
         -------------
1261
         -- Process --
1262
         -------------
1263
 
1264
         procedure Process (L_Node : Node_Access) is
1265
         begin
1266
            if not Is_In (Right.HT, L_Node) then
1267
               declare
1268
                  E : Element_Type renames L_Node.Element;
1269
                  J : constant Hash_Type := Hash (E) mod Buckets'Length;
1270
 
1271
               begin
1272
                  Buckets (J) := new Node_Type'(E, Buckets (J));
1273
                  Length := Length + 1;
1274
               end;
1275
            end if;
1276
         end Process;
1277
 
1278
      --  Start of processing for Iterate_Left
1279
 
1280
      begin
1281
         Iterate (Left.HT);
1282
      exception
1283
         when others =>
1284
            HT_Ops.Free_Hash_Table (Buckets);
1285
            raise;
1286
      end Iterate_Left;
1287
 
1288
      Iterate_Right : declare
1289
         procedure Process (R_Node : Node_Access);
1290
 
1291
         procedure Iterate is
1292
            new HT_Ops.Generic_Iteration (Process);
1293
 
1294
         -------------
1295
         -- Process --
1296
         -------------
1297
 
1298
         procedure Process (R_Node : Node_Access) is
1299
         begin
1300
            if not Is_In (Left.HT, R_Node) then
1301
               declare
1302
                  E : Element_Type renames R_Node.Element;
1303
                  J : constant Hash_Type := Hash (E) mod Buckets'Length;
1304
 
1305
               begin
1306
                  Buckets (J) := new Node_Type'(E, Buckets (J));
1307
                  Length := Length + 1;
1308
               end;
1309
            end if;
1310
         end Process;
1311
 
1312
      --  Start of processing for Iterate_Right
1313
 
1314
      begin
1315
         Iterate (Right.HT);
1316
      exception
1317
         when others =>
1318
            HT_Ops.Free_Hash_Table (Buckets);
1319
            raise;
1320
      end Iterate_Right;
1321
 
1322
      return (Controlled with HT => (Buckets, Length, 0, 0));
1323
   end Symmetric_Difference;
1324
 
1325
   ------------
1326
   -- To_Set --
1327
   ------------
1328
 
1329
   function To_Set (New_Item : Element_Type) return Set is
1330
      HT : Hash_Table_Type;
1331
 
1332
      Node     : Node_Access;
1333
      Inserted : Boolean;
1334
      pragma Unreferenced (Node, Inserted);
1335
 
1336
   begin
1337
      Insert (HT, New_Item, Node, Inserted);
1338
      return Set'(Controlled with HT);
1339
   end To_Set;
1340
 
1341
   -----------
1342
   -- Union --
1343
   -----------
1344
 
1345
   procedure Union
1346
     (Target : in out Set;
1347
      Source : Set)
1348
   is
1349
      procedure Process (Src_Node : Node_Access);
1350
 
1351
      procedure Iterate is
1352
         new HT_Ops.Generic_Iteration (Process);
1353
 
1354
      -------------
1355
      -- Process --
1356
      -------------
1357
 
1358
      procedure Process (Src_Node : Node_Access) is
1359
         function New_Node (Next : Node_Access) return Node_Access;
1360
         pragma Inline (New_Node);
1361
 
1362
         procedure Insert is
1363
            new Element_Keys.Generic_Conditional_Insert (New_Node);
1364
 
1365
         --------------
1366
         -- New_Node --
1367
         --------------
1368
 
1369
         function New_Node (Next : Node_Access) return Node_Access is
1370
            Node : constant Node_Access :=
1371
                     new Node_Type'(Src_Node.Element, Next);
1372
         begin
1373
            return Node;
1374
         end New_Node;
1375
 
1376
         Tgt_Node : Node_Access;
1377
         Success  : Boolean;
1378
         pragma Unreferenced (Tgt_Node, Success);
1379
 
1380
      --  Start of processing for Process
1381
 
1382
      begin
1383
         Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1384
      end Process;
1385
 
1386
   --  Start of processing for Union
1387
 
1388
   begin
1389
      if Target'Address = Source'Address then
1390
         return;
1391
      end if;
1392
 
1393
      if Target.HT.Busy > 0 then
1394
         raise Program_Error with
1395
           "attempt to tamper with elements (set is busy)";
1396
      end if;
1397
 
1398
      declare
1399
         N : constant Count_Type := Target.Length + Source.Length;
1400
      begin
1401
         if N > HT_Ops.Capacity (Target.HT) then
1402
            HT_Ops.Reserve_Capacity (Target.HT, N);
1403
         end if;
1404
      end;
1405
 
1406
      Iterate (Source.HT);
1407
   end Union;
1408
 
1409
   function Union (Left, Right : Set) return Set is
1410
      Buckets : HT_Types.Buckets_Access;
1411
      Length  : Count_Type;
1412
 
1413
   begin
1414
      if Left'Address = Right'Address then
1415
         return Left;
1416
      end if;
1417
 
1418
      if Right.Length = 0 then
1419
         return Left;
1420
      end if;
1421
 
1422
      if Left.Length = 0 then
1423
         return Right;
1424
      end if;
1425
 
1426
      declare
1427
         Size : constant Hash_Type :=
1428
                  Prime_Numbers.To_Prime (Left.Length + Right.Length);
1429
      begin
1430
         Buckets := HT_Ops.New_Buckets (Length => Size);
1431
      end;
1432
 
1433
      Iterate_Left : declare
1434
         procedure Process (L_Node : Node_Access);
1435
 
1436
         procedure Iterate is
1437
            new HT_Ops.Generic_Iteration (Process);
1438
 
1439
         -------------
1440
         -- Process --
1441
         -------------
1442
 
1443
         procedure Process (L_Node : Node_Access) is
1444
            J : constant Hash_Type :=
1445
                  Hash (L_Node.Element) mod Buckets'Length;
1446
 
1447
         begin
1448
            Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
1449
         end Process;
1450
 
1451
      --  Start of processing for Iterate_Left
1452
 
1453
      begin
1454
         Iterate (Left.HT);
1455
      exception
1456
         when others =>
1457
            HT_Ops.Free_Hash_Table (Buckets);
1458
            raise;
1459
      end Iterate_Left;
1460
 
1461
      Length := Left.Length;
1462
 
1463
      Iterate_Right : declare
1464
         procedure Process (Src_Node : Node_Access);
1465
 
1466
         procedure Iterate is
1467
            new HT_Ops.Generic_Iteration (Process);
1468
 
1469
         -------------
1470
         -- Process --
1471
         -------------
1472
 
1473
         procedure Process (Src_Node : Node_Access) is
1474
            J : constant Hash_Type :=
1475
                  Hash (Src_Node.Element) mod Buckets'Length;
1476
 
1477
            Tgt_Node : Node_Access := Buckets (J);
1478
 
1479
         begin
1480
            while Tgt_Node /= null loop
1481
               if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1482
                  return;
1483
               end if;
1484
 
1485
               Tgt_Node := Next (Tgt_Node);
1486
            end loop;
1487
 
1488
            Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
1489
            Length := Length + 1;
1490
         end Process;
1491
 
1492
      --  Start of processing for Iterate_Right
1493
 
1494
      begin
1495
         Iterate (Right.HT);
1496
      exception
1497
         when others =>
1498
            HT_Ops.Free_Hash_Table (Buckets);
1499
            raise;
1500
      end Iterate_Right;
1501
 
1502
      return (Controlled with HT => (Buckets, Length, 0, 0));
1503
   end Union;
1504
 
1505
   ---------
1506
   -- Vet --
1507
   ---------
1508
 
1509
   function Vet (Position : Cursor) return Boolean is
1510
   begin
1511
      if Position.Node = null then
1512
         return Position.Container = null;
1513
      end if;
1514
 
1515
      if Position.Container = null then
1516
         return False;
1517
      end if;
1518
 
1519
      if Position.Node.Next = Position.Node then
1520
         return False;
1521
      end if;
1522
 
1523
      declare
1524
         HT : Hash_Table_Type renames Position.Container.HT;
1525
         X  : Node_Access;
1526
 
1527
      begin
1528
         if HT.Length = 0 then
1529
            return False;
1530
         end if;
1531
 
1532
         if HT.Buckets = null
1533
           or else HT.Buckets'Length = 0
1534
         then
1535
            return False;
1536
         end if;
1537
 
1538
         X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element));
1539
 
1540
         for J in 1 .. HT.Length loop
1541
            if X = Position.Node then
1542
               return True;
1543
            end if;
1544
 
1545
            if X = null then
1546
               return False;
1547
            end if;
1548
 
1549
            if X = X.Next then  --  to prevent unnecessary looping
1550
               return False;
1551
            end if;
1552
 
1553
            X := X.Next;
1554
         end loop;
1555
 
1556
         return False;
1557
      end;
1558
   end Vet;
1559
 
1560
   -----------
1561
   -- Write --
1562
   -----------
1563
 
1564
   procedure Write
1565
     (Stream    : not null access Root_Stream_Type'Class;
1566
      Container : Set)
1567
   is
1568
   begin
1569
      Write_Nodes (Stream, Container.HT);
1570
   end Write;
1571
 
1572
   procedure Write
1573
     (Stream : not null access Root_Stream_Type'Class;
1574
      Item   : Cursor)
1575
   is
1576
   begin
1577
      raise Program_Error with "attempt to stream set cursor";
1578
   end Write;
1579
 
1580
   ----------------
1581
   -- Write_Node --
1582
   ----------------
1583
 
1584
   procedure Write_Node
1585
     (Stream : not null access Root_Stream_Type'Class;
1586
      Node   : Node_Access)
1587
   is
1588
   begin
1589
      Element_Type'Write (Stream, Node.Element);
1590
   end Write_Node;
1591
 
1592
   package body Generic_Keys is
1593
 
1594
      -----------------------
1595
      -- Local Subprograms --
1596
      -----------------------
1597
 
1598
      function Equivalent_Key_Node
1599
        (Key  : Key_Type;
1600
         Node : Node_Access) return Boolean;
1601
      pragma Inline (Equivalent_Key_Node);
1602
 
1603
      --------------------------
1604
      -- Local Instantiations --
1605
      --------------------------
1606
 
1607
      package Key_Keys is
1608
         new Hash_Tables.Generic_Keys
1609
          (HT_Types  => HT_Types,
1610
           Next      => Next,
1611
           Set_Next  => Set_Next,
1612
           Key_Type  => Key_Type,
1613
           Hash      => Hash,
1614
           Equivalent_Keys => Equivalent_Key_Node);
1615
 
1616
      --------------
1617
      -- Contains --
1618
      --------------
1619
 
1620
      function Contains
1621
        (Container : Set;
1622
         Key       : Key_Type) return Boolean
1623
      is
1624
      begin
1625
         return Find (Container, Key) /= No_Element;
1626
      end Contains;
1627
 
1628
      ------------
1629
      -- Delete --
1630
      ------------
1631
 
1632
      procedure Delete
1633
        (Container : in out Set;
1634
         Key       : Key_Type)
1635
      is
1636
         X : Node_Access;
1637
 
1638
      begin
1639
         Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1640
 
1641
         if X = null then
1642
            raise Constraint_Error with "attempt to delete key not in set";
1643
         end if;
1644
 
1645
         Free (X);
1646
      end Delete;
1647
 
1648
      -------------
1649
      -- Element --
1650
      -------------
1651
 
1652
      function Element
1653
        (Container : Set;
1654
         Key       : Key_Type) return Element_Type
1655
      is
1656
         Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1657
 
1658
      begin
1659
         if Node = null then
1660
            raise Constraint_Error with "key not in map";
1661
         end if;
1662
 
1663
         return Node.Element;
1664
      end Element;
1665
 
1666
      -------------------------
1667
      -- Equivalent_Key_Node --
1668
      -------------------------
1669
 
1670
      function Equivalent_Key_Node
1671
        (Key  : Key_Type;
1672
         Node : Node_Access) return Boolean
1673
      is
1674
      begin
1675
         return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1676
      end Equivalent_Key_Node;
1677
 
1678
      -------------
1679
      -- Exclude --
1680
      -------------
1681
 
1682
      procedure Exclude
1683
        (Container : in out Set;
1684
         Key       : Key_Type)
1685
      is
1686
         X : Node_Access;
1687
      begin
1688
         Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1689
         Free (X);
1690
      end Exclude;
1691
 
1692
      ----------
1693
      -- Find --
1694
      ----------
1695
 
1696
      function Find
1697
        (Container : Set;
1698
         Key       : Key_Type) return Cursor
1699
      is
1700
         Node : constant Node_Access :=
1701
                  Key_Keys.Find (Container.HT, Key);
1702
 
1703
      begin
1704
         if Node = null then
1705
            return No_Element;
1706
         end if;
1707
 
1708
         return Cursor'(Container'Unrestricted_Access, Node);
1709
      end Find;
1710
 
1711
      ---------
1712
      -- Key --
1713
      ---------
1714
 
1715
      function Key (Position : Cursor) return Key_Type is
1716
      begin
1717
         if Position.Node = null then
1718
            raise Constraint_Error with
1719
              "Position cursor equals No_Element";
1720
         end if;
1721
 
1722
         pragma Assert (Vet (Position), "bad cursor in function Key");
1723
 
1724
         return Key (Position.Node.Element);
1725
      end Key;
1726
 
1727
      -------------
1728
      -- Replace --
1729
      -------------
1730
 
1731
      procedure Replace
1732
        (Container : in out Set;
1733
         Key       : Key_Type;
1734
         New_Item  : Element_Type)
1735
      is
1736
         Node : constant Node_Access :=
1737
                  Key_Keys.Find (Container.HT, Key);
1738
 
1739
      begin
1740
         if Node = null then
1741
            raise Constraint_Error with
1742
              "attempt to replace key not in set";
1743
         end if;
1744
 
1745
         Replace_Element (Container.HT, Node, New_Item);
1746
      end Replace;
1747
 
1748
      -----------------------------------
1749
      -- Update_Element_Preserving_Key --
1750
      -----------------------------------
1751
 
1752
      procedure Update_Element_Preserving_Key
1753
        (Container : in out Set;
1754
         Position  : Cursor;
1755
         Process   : not null access
1756
                       procedure (Element : in out Element_Type))
1757
      is
1758
         HT   : Hash_Table_Type renames Container.HT;
1759
         Indx : Hash_Type;
1760
 
1761
      begin
1762
         if Position.Node = null then
1763
            raise Constraint_Error with
1764
              "Position cursor equals No_Element";
1765
         end if;
1766
 
1767
         if Position.Container /= Container'Unrestricted_Access then
1768
            raise Program_Error with
1769
              "Position cursor designates wrong set";
1770
         end if;
1771
 
1772
         if HT.Buckets = null
1773
           or else HT.Buckets'Length = 0
1774
           or else HT.Length = 0
1775
           or else Position.Node.Next = Position.Node
1776
         then
1777
            raise Program_Error with "Position cursor is bad (set is empty)";
1778
         end if;
1779
 
1780
         pragma Assert
1781
           (Vet (Position),
1782
            "bad cursor in Update_Element_Preserving_Key");
1783
 
1784
         Indx := HT_Ops.Index (HT, Position.Node);
1785
 
1786
         declare
1787
            E : Element_Type renames Position.Node.Element;
1788
            K : constant Key_Type := Key (E);
1789
 
1790
            B : Natural renames HT.Busy;
1791
            L : Natural renames HT.Lock;
1792
 
1793
         begin
1794
            B := B + 1;
1795
            L := L + 1;
1796
 
1797
            begin
1798
               Process (E);
1799
            exception
1800
               when others =>
1801
                  L := L - 1;
1802
                  B := B - 1;
1803
                  raise;
1804
            end;
1805
 
1806
            L := L - 1;
1807
            B := B - 1;
1808
 
1809
            if Equivalent_Keys (K, Key (E)) then
1810
               pragma Assert (Hash (K) = Hash (E));
1811
               return;
1812
            end if;
1813
         end;
1814
 
1815
         if HT.Buckets (Indx) = Position.Node then
1816
            HT.Buckets (Indx) := Position.Node.Next;
1817
 
1818
         else
1819
            declare
1820
               Prev : Node_Access := HT.Buckets (Indx);
1821
 
1822
            begin
1823
               while Prev.Next /= Position.Node loop
1824
                  Prev := Prev.Next;
1825
 
1826
                  if Prev = null then
1827
                     raise Program_Error with
1828
                       "Position cursor is bad (node not found)";
1829
                  end if;
1830
               end loop;
1831
 
1832
               Prev.Next := Position.Node.Next;
1833
            end;
1834
         end if;
1835
 
1836
         HT.Length := HT.Length - 1;
1837
 
1838
         declare
1839
            X : Node_Access := Position.Node;
1840
 
1841
         begin
1842
            Free (X);
1843
         end;
1844
 
1845
         raise Program_Error with "key was modified";
1846
      end Update_Element_Preserving_Key;
1847
 
1848
   end Generic_Keys;
1849
 
1850
end Ada.Containers.Hashed_Sets;

powered by: WebSVN 2.1.0

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