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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-cihase.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.INDEFINITE_HASHED_SETS                   --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2004-2012, 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.Indefinite_Hashed_Sets is
43
 
44
   type Iterator is new Limited_Controlled and
45
     Set_Iterator_Interfaces.Forward_Iterator with
46
   record
47
      Container : Set_Access;
48
   end record;
49
 
50
   overriding procedure Finalize (Object : in out Iterator);
51
 
52
   overriding function First (Object : Iterator) return Cursor;
53
 
54
   overriding function Next
55
     (Object   : Iterator;
56
      Position : Cursor) return Cursor;
57
 
58
   -----------------------
59
   -- Local Subprograms --
60
   -----------------------
61
 
62
   procedure Assign (Node : Node_Access; Item : Element_Type);
63
   pragma Inline (Assign);
64
 
65
   function Copy_Node (Source : Node_Access) return Node_Access;
66
   pragma Inline (Copy_Node);
67
 
68
   function Equivalent_Keys
69
     (Key  : Element_Type;
70
      Node : Node_Access) return Boolean;
71
   pragma Inline (Equivalent_Keys);
72
 
73
   function Find_Equal_Key
74
     (R_HT   : Hash_Table_Type;
75
      L_Node : Node_Access) return Boolean;
76
 
77
   function Find_Equivalent_Key
78
     (R_HT   : Hash_Table_Type;
79
      L_Node : Node_Access) return Boolean;
80
 
81
   procedure Free (X : in out Node_Access);
82
 
83
   function Hash_Node (Node : Node_Access) return Hash_Type;
84
   pragma Inline (Hash_Node);
85
 
86
   procedure Insert
87
     (HT       : in out Hash_Table_Type;
88
      New_Item : Element_Type;
89
      Node     : out Node_Access;
90
      Inserted : out Boolean);
91
 
92
   function Is_In (HT  : Hash_Table_Type; Key : Node_Access) return Boolean;
93
   pragma Inline (Is_In);
94
 
95
   function Next (Node : Node_Access) return Node_Access;
96
   pragma Inline (Next);
97
 
98
   function Read_Node (Stream : not null access Root_Stream_Type'Class)
99
     return Node_Access;
100
   pragma Inline (Read_Node);
101
 
102
   procedure Set_Next (Node : Node_Access; Next : Node_Access);
103
   pragma Inline (Set_Next);
104
 
105
   function Vet (Position : Cursor) return Boolean;
106
 
107
   procedure Write_Node
108
     (Stream : not null access Root_Stream_Type'Class;
109
      Node   : Node_Access);
110
   pragma Inline (Write_Node);
111
 
112
   --------------------------
113
   -- Local Instantiations --
114
   --------------------------
115
 
116
   procedure Free_Element is
117
     new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
118
 
119
   package HT_Ops is new Hash_Tables.Generic_Operations
120
     (HT_Types  => HT_Types,
121
      Hash_Node => Hash_Node,
122
      Next      => Next,
123
      Set_Next  => Set_Next,
124
      Copy_Node => Copy_Node,
125
      Free      => Free);
126
 
127
   package Element_Keys is new Hash_Tables.Generic_Keys
128
     (HT_Types        => HT_Types,
129
      Next            => Next,
130
      Set_Next        => Set_Next,
131
      Key_Type        => Element_Type,
132
      Hash            => Hash,
133
      Equivalent_Keys => Equivalent_Keys);
134
 
135
   function Is_Equal is
136
      new HT_Ops.Generic_Equal (Find_Equal_Key);
137
 
138
   function Is_Equivalent is
139
      new HT_Ops.Generic_Equal (Find_Equivalent_Key);
140
 
141
   procedure Read_Nodes is
142
      new HT_Ops.Generic_Read (Read_Node);
143
 
144
   procedure Replace_Element is
145
      new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
146
 
147
   procedure Write_Nodes is
148
     new HT_Ops.Generic_Write (Write_Node);
149
 
150
   ---------
151
   -- "=" --
152
   ---------
153
 
154
   function "=" (Left, Right : Set) return Boolean is
155
   begin
156
      return Is_Equal (Left.HT, Right.HT);
157
   end "=";
158
 
159
   ------------
160
   -- Adjust --
161
   ------------
162
 
163
   procedure Adjust (Container : in out Set) is
164
   begin
165
      HT_Ops.Adjust (Container.HT);
166
   end Adjust;
167
 
168
   procedure Adjust (Control : in out Reference_Control_Type) is
169
   begin
170
      if Control.Container /= null then
171
         declare
172
            HT : Hash_Table_Type renames Control.Container.all.HT;
173
            B : Natural renames HT.Busy;
174
            L : Natural renames HT.Lock;
175
         begin
176
            B := B + 1;
177
            L := L + 1;
178
         end;
179
      end if;
180
   end Adjust;
181
 
182
   ------------
183
   -- Assign --
184
   ------------
185
 
186
   procedure Assign (Node : Node_Access; Item : Element_Type) is
187
      X : Element_Access := Node.Element;
188
   begin
189
      Node.Element := new Element_Type'(Item);
190
      Free_Element (X);
191
   end Assign;
192
 
193
   procedure Assign (Target : in out Set; Source : Set) is
194
   begin
195
      if Target'Address = Source'Address then
196
         return;
197
      end if;
198
 
199
      Target.Clear;
200
      Target.Union (Source);
201
   end Assign;
202
 
203
   --------------
204
   -- Capacity --
205
   --------------
206
 
207
   function Capacity (Container : Set) return Count_Type is
208
   begin
209
      return HT_Ops.Capacity (Container.HT);
210
   end Capacity;
211
 
212
   -----------
213
   -- Clear --
214
   -----------
215
 
216
   procedure Clear (Container : in out Set) is
217
   begin
218
      HT_Ops.Clear (Container.HT);
219
   end Clear;
220
 
221
   ------------------------
222
   -- Constant_Reference --
223
   ------------------------
224
 
225
   function Constant_Reference
226
     (Container : aliased Set;
227
      Position  : Cursor) return Constant_Reference_Type
228
   is
229
   begin
230
      if Position.Container = null then
231
         raise Constraint_Error with "Position cursor has no element";
232
      end if;
233
 
234
      if Position.Container /= Container'Unrestricted_Access then
235
         raise Program_Error with
236
           "Position cursor designates wrong container";
237
      end if;
238
 
239
      if Position.Node.Element = null then
240
         raise Program_Error with "Node has no element";
241
      end if;
242
 
243
      pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
244
 
245
      declare
246
         HT : Hash_Table_Type renames Position.Container.all.HT;
247
         B : Natural renames HT.Busy;
248
         L : Natural renames HT.Lock;
249
      begin
250
         return R : constant Constant_Reference_Type :=
251
                      (Element => Position.Node.Element.all'Access,
252
                       Control =>
253
                         (Controlled with Container'Unrestricted_Access))
254
         do
255
            B := B + 1;
256
            L := L + 1;
257
         end return;
258
      end;
259
   end Constant_Reference;
260
 
261
   --------------
262
   -- Contains --
263
   --------------
264
 
265
   function Contains (Container : Set; Item : Element_Type) return Boolean is
266
   begin
267
      return Find (Container, Item) /= No_Element;
268
   end Contains;
269
 
270
   ----------
271
   -- Copy --
272
   ----------
273
 
274
   function Copy
275
     (Source   : Set;
276
      Capacity : Count_Type := 0) return Set
277
   is
278
      C : Count_Type;
279
 
280
   begin
281
      if Capacity = 0 then
282
         C := Source.Length;
283
 
284
      elsif Capacity >= Source.Length then
285
         C := Capacity;
286
 
287
      else
288
         raise Capacity_Error
289
           with "Requested capacity is less than Source length";
290
      end if;
291
 
292
      return Target : Set do
293
         Target.Reserve_Capacity (C);
294
         Target.Assign (Source);
295
      end return;
296
   end Copy;
297
 
298
   ---------------
299
   -- Copy_Node --
300
   ---------------
301
 
302
   function Copy_Node (Source : Node_Access) return Node_Access is
303
      E : Element_Access := new Element_Type'(Source.Element.all);
304
   begin
305
      return new Node_Type'(Element => E, Next => null);
306
   exception
307
      when others =>
308
         Free_Element (E);
309
         raise;
310
   end Copy_Node;
311
 
312
   ------------
313
   -- Delete --
314
   ------------
315
 
316
   procedure Delete
317
     (Container : in out Set;
318
      Item      : Element_Type)
319
   is
320
      X : Node_Access;
321
 
322
   begin
323
      Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
324
 
325
      if X = null then
326
         raise Constraint_Error with "attempt to delete element not in set";
327
      end if;
328
 
329
      Free (X);
330
   end Delete;
331
 
332
   procedure Delete
333
     (Container : in out Set;
334
      Position  : in out Cursor)
335
   is
336
   begin
337
      if Position.Node = null then
338
         raise Constraint_Error with "Position cursor equals No_Element";
339
      end if;
340
 
341
      if Position.Node.Element = null then
342
         raise Program_Error with "Position cursor is bad";
343
      end if;
344
 
345
      if Position.Container /= Container'Unrestricted_Access then
346
         raise Program_Error with "Position cursor designates wrong set";
347
      end if;
348
 
349
      if Container.HT.Busy > 0 then
350
         raise Program_Error with
351
           "attempt to tamper with cursors (set is busy)";
352
      end if;
353
 
354
      pragma Assert (Vet (Position), "Position cursor is bad");
355
 
356
      HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
357
 
358
      Free (Position.Node);
359
      Position.Container := null;
360
   end Delete;
361
 
362
   ----------------
363
   -- Difference --
364
   ----------------
365
 
366
   procedure Difference
367
     (Target : in out Set;
368
      Source : Set)
369
   is
370
      Tgt_Node : Node_Access;
371
 
372
   begin
373
      if Target'Address = Source'Address then
374
         Clear (Target);
375
         return;
376
      end if;
377
 
378
      if Source.HT.Length = 0 then
379
         return;
380
      end if;
381
 
382
      if Target.HT.Busy > 0 then
383
         raise Program_Error with
384
           "attempt to tamper with cursors (set is busy)";
385
      end if;
386
 
387
      if Source.HT.Length < Target.HT.Length then
388
         declare
389
            Src_Node : Node_Access;
390
 
391
         begin
392
            Src_Node := HT_Ops.First (Source.HT);
393
            while Src_Node /= null loop
394
               Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
395
 
396
               if Tgt_Node /= null then
397
                  HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
398
                  Free (Tgt_Node);
399
               end if;
400
 
401
               Src_Node := HT_Ops.Next (Source.HT, Src_Node);
402
            end loop;
403
         end;
404
 
405
      else
406
         Tgt_Node := HT_Ops.First (Target.HT);
407
         while Tgt_Node /= null loop
408
            if Is_In (Source.HT, Tgt_Node) then
409
               declare
410
                  X : Node_Access := Tgt_Node;
411
               begin
412
                  Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
413
                  HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
414
                  Free (X);
415
               end;
416
 
417
            else
418
               Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
419
            end if;
420
         end loop;
421
      end if;
422
   end Difference;
423
 
424
   function Difference (Left, Right : Set) return Set is
425
      Buckets : HT_Types.Buckets_Access;
426
      Length  : Count_Type;
427
 
428
   begin
429
      if Left'Address = Right'Address then
430
         return Empty_Set;
431
      end if;
432
 
433
      if Left.Length = 0 then
434
         return Empty_Set;
435
      end if;
436
 
437
      if Right.Length = 0 then
438
         return Left;
439
      end if;
440
 
441
      declare
442
         Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
443
      begin
444
         Buckets := HT_Ops.New_Buckets (Length => Size);
445
      end;
446
 
447
      Length := 0;
448
 
449
      Iterate_Left : declare
450
         procedure Process (L_Node : Node_Access);
451
 
452
         procedure Iterate is
453
            new HT_Ops.Generic_Iteration (Process);
454
 
455
         -------------
456
         -- Process --
457
         -------------
458
 
459
         procedure Process (L_Node : Node_Access) is
460
         begin
461
            if not Is_In (Right.HT, L_Node) then
462
               declare
463
                  Src    : Element_Type renames L_Node.Element.all;
464
                  Indx   : constant Hash_Type := Hash (Src) mod Buckets'Length;
465
                  Bucket : Node_Access renames Buckets (Indx);
466
                  Tgt    : Element_Access := new Element_Type'(Src);
467
               begin
468
                  Bucket := new Node_Type'(Tgt, Bucket);
469
               exception
470
                  when others =>
471
                     Free_Element (Tgt);
472
                     raise;
473
               end;
474
 
475
               Length := Length + 1;
476
            end if;
477
         end Process;
478
 
479
      --  Start of processing for Iterate_Left
480
 
481
      begin
482
         Iterate (Left.HT);
483
      exception
484
         when others =>
485
            HT_Ops.Free_Hash_Table (Buckets);
486
            raise;
487
      end Iterate_Left;
488
 
489
      return (Controlled with HT => (Buckets, Length, 0, 0));
490
   end Difference;
491
 
492
   -------------
493
   -- Element --
494
   -------------
495
 
496
   function Element (Position : Cursor) return Element_Type is
497
   begin
498
      if Position.Node = null then
499
         raise Constraint_Error with "Position cursor of equals No_Element";
500
      end if;
501
 
502
      if Position.Node.Element = null then  --  handle dangling reference
503
         raise Program_Error with "Position cursor is bad";
504
      end if;
505
 
506
      pragma Assert (Vet (Position), "bad cursor in function Element");
507
 
508
      return Position.Node.Element.all;
509
   end Element;
510
 
511
   ---------------------
512
   -- Equivalent_Sets --
513
   ---------------------
514
 
515
   function Equivalent_Sets (Left, Right : Set) return Boolean is
516
   begin
517
      return Is_Equivalent (Left.HT, Right.HT);
518
   end Equivalent_Sets;
519
 
520
   -------------------------
521
   -- Equivalent_Elements --
522
   -------------------------
523
 
524
   function Equivalent_Elements (Left, Right : Cursor) return Boolean is
525
   begin
526
      if Left.Node = null then
527
         raise Constraint_Error with
528
           "Left cursor of Equivalent_Elements equals No_Element";
529
      end if;
530
 
531
      if Right.Node = null then
532
         raise Constraint_Error with
533
           "Right cursor of Equivalent_Elements equals No_Element";
534
      end if;
535
 
536
      if Left.Node.Element = null then
537
         raise Program_Error with
538
           "Left cursor of Equivalent_Elements is bad";
539
      end if;
540
 
541
      if Right.Node.Element = null then
542
         raise Program_Error with
543
           "Right cursor of Equivalent_Elements is bad";
544
      end if;
545
 
546
      pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
547
      pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
548
 
549
      return Equivalent_Elements
550
               (Left.Node.Element.all,
551
                Right.Node.Element.all);
552
   end Equivalent_Elements;
553
 
554
   function Equivalent_Elements
555
     (Left  : Cursor;
556
      Right : Element_Type) return Boolean
557
   is
558
   begin
559
      if Left.Node = null then
560
         raise Constraint_Error with
561
           "Left cursor of Equivalent_Elements equals No_Element";
562
      end if;
563
 
564
      if Left.Node.Element = null then
565
         raise Program_Error with
566
           "Left cursor of Equivalent_Elements is bad";
567
      end if;
568
 
569
      pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
570
 
571
      return Equivalent_Elements (Left.Node.Element.all, Right);
572
   end Equivalent_Elements;
573
 
574
   function Equivalent_Elements
575
     (Left  : Element_Type;
576
      Right : Cursor) return Boolean
577
   is
578
   begin
579
      if Right.Node = null then
580
         raise Constraint_Error with
581
           "Right cursor of Equivalent_Elements equals No_Element";
582
      end if;
583
 
584
      if Right.Node.Element = null then
585
         raise Program_Error with
586
           "Right cursor of Equivalent_Elements is bad";
587
      end if;
588
 
589
      pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
590
 
591
      return Equivalent_Elements (Left, Right.Node.Element.all);
592
   end Equivalent_Elements;
593
 
594
   ---------------------
595
   -- Equivalent_Keys --
596
   ---------------------
597
 
598
   function Equivalent_Keys
599
     (Key  : Element_Type;
600
      Node : Node_Access) return Boolean
601
   is
602
   begin
603
      return Equivalent_Elements (Key, Node.Element.all);
604
   end Equivalent_Keys;
605
 
606
   -------------
607
   -- Exclude --
608
   -------------
609
 
610
   procedure Exclude
611
     (Container : in out Set;
612
      Item      : Element_Type)
613
   is
614
      X : Node_Access;
615
   begin
616
      Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
617
      Free (X);
618
   end Exclude;
619
 
620
   --------------
621
   -- Finalize --
622
   --------------
623
 
624
   procedure Finalize (Container : in out Set) is
625
   begin
626
      HT_Ops.Finalize (Container.HT);
627
   end Finalize;
628
 
629
   procedure Finalize (Object : in out Iterator) is
630
   begin
631
      if Object.Container /= null then
632
         declare
633
            B : Natural renames Object.Container.all.HT.Busy;
634
         begin
635
            B := B - 1;
636
         end;
637
      end if;
638
   end Finalize;
639
 
640
   procedure Finalize (Control : in out Reference_Control_Type) is
641
   begin
642
      if Control.Container /= null then
643
         declare
644
            HT : Hash_Table_Type renames Control.Container.all.HT;
645
            B : Natural renames HT.Busy;
646
            L : Natural renames HT.Lock;
647
         begin
648
            B := B - 1;
649
            L := L - 1;
650
         end;
651
 
652
         Control.Container := null;
653
      end if;
654
   end Finalize;
655
 
656
   ----------
657
   -- Find --
658
   ----------
659
 
660
   function Find
661
     (Container : Set;
662
      Item      : Element_Type) return Cursor
663
   is
664
      Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
665
   begin
666
      return (if Node = null then No_Element
667
              else Cursor'(Container'Unrestricted_Access, Node));
668
   end Find;
669
 
670
   --------------------
671
   -- Find_Equal_Key --
672
   --------------------
673
 
674
   function Find_Equal_Key
675
     (R_HT   : Hash_Table_Type;
676
      L_Node : Node_Access) return Boolean
677
   is
678
      R_Index : constant Hash_Type :=
679
                  Element_Keys.Index (R_HT, L_Node.Element.all);
680
 
681
      R_Node  : Node_Access := R_HT.Buckets (R_Index);
682
 
683
   begin
684
      loop
685
         if R_Node = null then
686
            return False;
687
         end if;
688
 
689
         if L_Node.Element.all = R_Node.Element.all then
690
            return True;
691
         end if;
692
 
693
         R_Node := Next (R_Node);
694
      end loop;
695
   end Find_Equal_Key;
696
 
697
   -------------------------
698
   -- Find_Equivalent_Key --
699
   -------------------------
700
 
701
   function Find_Equivalent_Key
702
     (R_HT   : Hash_Table_Type;
703
      L_Node : Node_Access) return Boolean
704
   is
705
      R_Index : constant Hash_Type :=
706
                  Element_Keys.Index (R_HT, L_Node.Element.all);
707
 
708
      R_Node  : Node_Access := R_HT.Buckets (R_Index);
709
 
710
   begin
711
      loop
712
         if R_Node = null then
713
            return False;
714
         end if;
715
 
716
         if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
717
            return True;
718
         end if;
719
 
720
         R_Node := Next (R_Node);
721
      end loop;
722
   end Find_Equivalent_Key;
723
 
724
   -----------
725
   -- First --
726
   -----------
727
 
728
   function First (Container : Set) return Cursor is
729
      Node : constant Node_Access := HT_Ops.First (Container.HT);
730
   begin
731
      return (if Node = null then No_Element
732
              else Cursor'(Container'Unrestricted_Access, Node));
733
   end First;
734
 
735
   function First (Object : Iterator) return Cursor is
736
   begin
737
      return Object.Container.First;
738
   end First;
739
 
740
   ----------
741
   -- Free --
742
   ----------
743
 
744
   procedure Free (X : in out Node_Access) is
745
      procedure Deallocate is
746
         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
747
 
748
   begin
749
      if X = null then
750
         return;
751
      end if;
752
 
753
      X.Next := X;  --  detect mischief (in Vet)
754
 
755
      begin
756
         Free_Element (X.Element);
757
      exception
758
         when others =>
759
            X.Element := null;
760
            Deallocate (X);
761
            raise;
762
      end;
763
 
764
      Deallocate (X);
765
   end Free;
766
 
767
   -----------------
768
   -- Has_Element --
769
   -----------------
770
 
771
   function Has_Element (Position : Cursor) return Boolean is
772
   begin
773
      pragma Assert (Vet (Position), "bad cursor in Has_Element");
774
      return Position.Node /= null;
775
   end Has_Element;
776
 
777
   ---------------
778
   -- Hash_Node --
779
   ---------------
780
 
781
   function Hash_Node (Node : Node_Access) return Hash_Type is
782
   begin
783
      return Hash (Node.Element.all);
784
   end Hash_Node;
785
 
786
   -------------
787
   -- Include --
788
   -------------
789
 
790
   procedure Include
791
     (Container : in out Set;
792
      New_Item  : Element_Type)
793
   is
794
      Position : Cursor;
795
      Inserted : Boolean;
796
 
797
      X : Element_Access;
798
 
799
   begin
800
      Insert (Container, New_Item, Position, Inserted);
801
 
802
      if not Inserted then
803
         if Container.HT.Lock > 0 then
804
            raise Program_Error with
805
              "attempt to tamper with elements (set is locked)";
806
         end if;
807
 
808
         X := Position.Node.Element;
809
 
810
         Position.Node.Element := new Element_Type'(New_Item);
811
 
812
         Free_Element (X);
813
      end if;
814
   end Include;
815
 
816
   ------------
817
   -- Insert --
818
   ------------
819
 
820
   procedure Insert
821
     (Container : in out Set;
822
      New_Item  : Element_Type;
823
      Position  : out Cursor;
824
      Inserted  : out Boolean)
825
   is
826
   begin
827
      Insert (Container.HT, New_Item, Position.Node, Inserted);
828
      Position.Container := Container'Unchecked_Access;
829
   end Insert;
830
 
831
   procedure Insert
832
     (Container : in out Set;
833
      New_Item  : Element_Type)
834
   is
835
      Position : Cursor;
836
      pragma Unreferenced (Position);
837
 
838
      Inserted : Boolean;
839
 
840
   begin
841
      Insert (Container, New_Item, Position, Inserted);
842
 
843
      if not Inserted then
844
         raise Constraint_Error with
845
           "attempt to insert element already in set";
846
      end if;
847
   end Insert;
848
 
849
   procedure Insert
850
     (HT       : in out Hash_Table_Type;
851
      New_Item : Element_Type;
852
      Node     : out Node_Access;
853
      Inserted : out Boolean)
854
   is
855
      function New_Node (Next : Node_Access) return Node_Access;
856
      pragma Inline (New_Node);
857
 
858
      procedure Local_Insert is
859
         new Element_Keys.Generic_Conditional_Insert (New_Node);
860
 
861
      --------------
862
      -- New_Node --
863
      --------------
864
 
865
      function New_Node (Next : Node_Access) return Node_Access is
866
         Element : Element_Access := new Element_Type'(New_Item);
867
      begin
868
         return new Node_Type'(Element, Next);
869
      exception
870
         when others =>
871
            Free_Element (Element);
872
            raise;
873
      end New_Node;
874
 
875
   --  Start of processing for Insert
876
 
877
   begin
878
      if HT_Ops.Capacity (HT) = 0 then
879
         HT_Ops.Reserve_Capacity (HT, 1);
880
      end if;
881
 
882
      Local_Insert (HT, New_Item, Node, Inserted);
883
 
884
      if Inserted
885
        and then HT.Length > HT_Ops.Capacity (HT)
886
      then
887
         HT_Ops.Reserve_Capacity (HT, HT.Length);
888
      end if;
889
   end Insert;
890
 
891
   ------------------
892
   -- Intersection --
893
   ------------------
894
 
895
   procedure Intersection
896
     (Target : in out Set;
897
      Source : Set)
898
   is
899
      Tgt_Node : Node_Access;
900
 
901
   begin
902
      if Target'Address = Source'Address then
903
         return;
904
      end if;
905
 
906
      if Source.Length = 0 then
907
         Clear (Target);
908
         return;
909
      end if;
910
 
911
      if Target.HT.Busy > 0 then
912
         raise Program_Error with
913
           "attempt to tamper with cursors (set is busy)";
914
      end if;
915
 
916
      Tgt_Node := HT_Ops.First (Target.HT);
917
      while Tgt_Node /= null loop
918
         if Is_In (Source.HT, Tgt_Node) then
919
            Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
920
 
921
         else
922
            declare
923
               X : Node_Access := Tgt_Node;
924
            begin
925
               Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
926
               HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
927
               Free (X);
928
            end;
929
         end if;
930
      end loop;
931
   end Intersection;
932
 
933
   function Intersection (Left, Right : Set) return Set is
934
      Buckets : HT_Types.Buckets_Access;
935
      Length  : Count_Type;
936
 
937
   begin
938
      if Left'Address = Right'Address then
939
         return Left;
940
      end if;
941
 
942
      Length := Count_Type'Min (Left.Length, Right.Length);
943
 
944
      if Length = 0 then
945
         return Empty_Set;
946
      end if;
947
 
948
      declare
949
         Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
950
      begin
951
         Buckets := HT_Ops.New_Buckets (Length => Size);
952
      end;
953
 
954
      Length := 0;
955
 
956
      Iterate_Left : declare
957
         procedure Process (L_Node : Node_Access);
958
 
959
         procedure Iterate is
960
            new HT_Ops.Generic_Iteration (Process);
961
 
962
         -------------
963
         -- Process --
964
         -------------
965
 
966
         procedure Process (L_Node : Node_Access) is
967
         begin
968
            if Is_In (Right.HT, L_Node) then
969
               declare
970
                  Src : Element_Type renames L_Node.Element.all;
971
 
972
                  Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
973
 
974
                  Bucket : Node_Access renames Buckets (Indx);
975
 
976
                  Tgt : Element_Access := new Element_Type'(Src);
977
 
978
               begin
979
                  Bucket := new Node_Type'(Tgt, Bucket);
980
               exception
981
                  when others =>
982
                     Free_Element (Tgt);
983
                     raise;
984
               end;
985
 
986
               Length := Length + 1;
987
            end if;
988
         end Process;
989
 
990
      --  Start of processing for Iterate_Left
991
 
992
      begin
993
         Iterate (Left.HT);
994
      exception
995
         when others =>
996
            HT_Ops.Free_Hash_Table (Buckets);
997
            raise;
998
      end Iterate_Left;
999
 
1000
      return (Controlled with HT => (Buckets, Length, 0, 0));
1001
   end Intersection;
1002
 
1003
   --------------
1004
   -- Is_Empty --
1005
   --------------
1006
 
1007
   function Is_Empty (Container : Set) return Boolean is
1008
   begin
1009
      return Container.HT.Length = 0;
1010
   end Is_Empty;
1011
 
1012
   -----------
1013
   -- Is_In --
1014
   -----------
1015
 
1016
   function Is_In (HT  : Hash_Table_Type; Key : Node_Access) return Boolean is
1017
   begin
1018
      return Element_Keys.Find (HT, Key.Element.all) /= null;
1019
   end Is_In;
1020
 
1021
   ---------------
1022
   -- Is_Subset --
1023
   ---------------
1024
 
1025
   function Is_Subset
1026
     (Subset : Set;
1027
      Of_Set : Set) return Boolean
1028
   is
1029
      Subset_Node : Node_Access;
1030
 
1031
   begin
1032
      if Subset'Address = Of_Set'Address then
1033
         return True;
1034
      end if;
1035
 
1036
      if Subset.Length > Of_Set.Length then
1037
         return False;
1038
      end if;
1039
 
1040
      Subset_Node := HT_Ops.First (Subset.HT);
1041
      while Subset_Node /= null loop
1042
         if not Is_In (Of_Set.HT, Subset_Node) then
1043
            return False;
1044
         end if;
1045
 
1046
         Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
1047
      end loop;
1048
 
1049
      return True;
1050
   end Is_Subset;
1051
 
1052
   -------------
1053
   -- Iterate --
1054
   -------------
1055
 
1056
   procedure Iterate
1057
     (Container : Set;
1058
      Process   : not null access procedure (Position : Cursor))
1059
   is
1060
      procedure Process_Node (Node : Node_Access);
1061
      pragma Inline (Process_Node);
1062
 
1063
      procedure Iterate is
1064
         new HT_Ops.Generic_Iteration (Process_Node);
1065
 
1066
      ------------------
1067
      -- Process_Node --
1068
      ------------------
1069
 
1070
      procedure Process_Node (Node : Node_Access) is
1071
      begin
1072
         Process (Cursor'(Container'Unrestricted_Access, Node));
1073
      end Process_Node;
1074
 
1075
      B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1076
 
1077
   --  Start of processing for Iterate
1078
 
1079
   begin
1080
      B := B + 1;
1081
 
1082
      begin
1083
         Iterate (Container.HT);
1084
      exception
1085
         when others =>
1086
            B := B - 1;
1087
            raise;
1088
      end;
1089
 
1090
      B := B - 1;
1091
   end Iterate;
1092
 
1093
   function Iterate (Container : Set)
1094
     return Set_Iterator_Interfaces.Forward_Iterator'Class
1095
   is
1096
      B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1097
   begin
1098
      return It : constant Iterator :=
1099
                    Iterator'(Limited_Controlled with
1100
                                Container => Container'Unrestricted_Access)
1101
      do
1102
         B := B + 1;
1103
      end return;
1104
   end Iterate;
1105
 
1106
   ------------
1107
   -- Length --
1108
   ------------
1109
 
1110
   function Length (Container : Set) return Count_Type is
1111
   begin
1112
      return Container.HT.Length;
1113
   end Length;
1114
 
1115
   ----------
1116
   -- Move --
1117
   ----------
1118
 
1119
   procedure Move (Target : in out Set; Source : in out Set) is
1120
   begin
1121
      HT_Ops.Move (Target => Target.HT, Source => Source.HT);
1122
   end Move;
1123
 
1124
   ----------
1125
   -- Next --
1126
   ----------
1127
 
1128
   function Next (Node : Node_Access) return Node_Access is
1129
   begin
1130
      return Node.Next;
1131
   end Next;
1132
 
1133
   function Next (Position : Cursor) return Cursor is
1134
   begin
1135
      if Position.Node = null then
1136
         return No_Element;
1137
      end if;
1138
 
1139
      if Position.Node.Element = null then
1140
         raise Program_Error with "bad cursor in Next";
1141
      end if;
1142
 
1143
      pragma Assert (Vet (Position), "bad cursor in Next");
1144
 
1145
      declare
1146
         HT   : Hash_Table_Type renames Position.Container.HT;
1147
         Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1148
      begin
1149
         return (if Node = null then No_Element
1150
                 else Cursor'(Position.Container, Node));
1151
      end;
1152
   end Next;
1153
 
1154
   procedure Next (Position : in out Cursor) is
1155
   begin
1156
      Position := Next (Position);
1157
   end Next;
1158
 
1159
   function Next
1160
     (Object   : Iterator;
1161
      Position : Cursor) return Cursor
1162
   is
1163
   begin
1164
      if Position.Container = null then
1165
         return No_Element;
1166
      end if;
1167
 
1168
      if Position.Container /= Object.Container then
1169
         raise Program_Error with
1170
           "Position cursor of Next designates wrong set";
1171
      end if;
1172
 
1173
      return Next (Position);
1174
   end Next;
1175
 
1176
   -------------
1177
   -- Overlap --
1178
   -------------
1179
 
1180
   function Overlap (Left, Right : Set) return Boolean is
1181
      Left_Node : Node_Access;
1182
 
1183
   begin
1184
      if Right.Length = 0 then
1185
         return False;
1186
      end if;
1187
 
1188
      if Left'Address = Right'Address then
1189
         return True;
1190
      end if;
1191
 
1192
      Left_Node := HT_Ops.First (Left.HT);
1193
      while Left_Node /= null loop
1194
         if Is_In (Right.HT, Left_Node) then
1195
            return True;
1196
         end if;
1197
 
1198
         Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1199
      end loop;
1200
 
1201
      return False;
1202
   end Overlap;
1203
 
1204
   -------------------
1205
   -- Query_Element --
1206
   -------------------
1207
 
1208
   procedure Query_Element
1209
     (Position : Cursor;
1210
      Process  : not null access procedure (Element : Element_Type))
1211
   is
1212
   begin
1213
      if Position.Node = null then
1214
         raise Constraint_Error with
1215
           "Position cursor of Query_Element equals No_Element";
1216
      end if;
1217
 
1218
      if Position.Node.Element = null then
1219
         raise Program_Error with "bad cursor in Query_Element";
1220
      end if;
1221
 
1222
      pragma Assert (Vet (Position), "bad cursor in Query_Element");
1223
 
1224
      declare
1225
         HT : Hash_Table_Type renames
1226
                Position.Container'Unrestricted_Access.all.HT;
1227
 
1228
         B : Natural renames HT.Busy;
1229
         L : Natural renames HT.Lock;
1230
 
1231
      begin
1232
         B := B + 1;
1233
         L := L + 1;
1234
 
1235
         begin
1236
            Process (Position.Node.Element.all);
1237
         exception
1238
            when others =>
1239
               L := L - 1;
1240
               B := B - 1;
1241
               raise;
1242
         end;
1243
 
1244
         L := L - 1;
1245
         B := B - 1;
1246
      end;
1247
   end Query_Element;
1248
 
1249
   ----------
1250
   -- Read --
1251
   ----------
1252
 
1253
   procedure Read
1254
     (Stream    : not null access Root_Stream_Type'Class;
1255
      Container : out Set)
1256
   is
1257
   begin
1258
      Read_Nodes (Stream, Container.HT);
1259
   end Read;
1260
 
1261
   procedure Read
1262
     (Stream : not null access Root_Stream_Type'Class;
1263
      Item   : out Cursor)
1264
   is
1265
   begin
1266
      raise Program_Error with "attempt to stream set cursor";
1267
   end Read;
1268
 
1269
   procedure Read
1270
     (Stream : not null access Root_Stream_Type'Class;
1271
      Item   : out Constant_Reference_Type)
1272
   is
1273
   begin
1274
      raise Program_Error with "attempt to stream reference";
1275
   end Read;
1276
 
1277
   ---------------
1278
   -- Read_Node --
1279
   ---------------
1280
 
1281
   function Read_Node
1282
     (Stream : not null access Root_Stream_Type'Class) return Node_Access
1283
   is
1284
      X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1285
   begin
1286
      return new Node_Type'(X, null);
1287
   exception
1288
      when others =>
1289
         Free_Element (X);
1290
         raise;
1291
   end Read_Node;
1292
 
1293
   -------------
1294
   -- Replace --
1295
   -------------
1296
 
1297
   procedure Replace
1298
     (Container : in out Set;
1299
      New_Item  : Element_Type)
1300
   is
1301
      Node : constant Node_Access :=
1302
               Element_Keys.Find (Container.HT, New_Item);
1303
 
1304
      X : Element_Access;
1305
      pragma Warnings (Off, X);
1306
 
1307
   begin
1308
      if Node = null then
1309
         raise Constraint_Error with
1310
           "attempt to replace element not in set";
1311
      end if;
1312
 
1313
      if Container.HT.Lock > 0 then
1314
         raise Program_Error with
1315
           "attempt to tamper with elements (set is locked)";
1316
      end if;
1317
 
1318
      X := Node.Element;
1319
 
1320
      Node.Element := new Element_Type'(New_Item);
1321
 
1322
      Free_Element (X);
1323
   end Replace;
1324
 
1325
   ---------------------
1326
   -- Replace_Element --
1327
   ---------------------
1328
 
1329
   procedure Replace_Element
1330
     (Container : in out Set;
1331
      Position  : Cursor;
1332
      New_Item  : Element_Type)
1333
   is
1334
   begin
1335
      if Position.Node = null then
1336
         raise Constraint_Error with "Position cursor equals No_Element";
1337
      end if;
1338
 
1339
      if Position.Node.Element = null then
1340
         raise Program_Error with "bad cursor in Replace_Element";
1341
      end if;
1342
 
1343
      if Position.Container /= Container'Unrestricted_Access then
1344
         raise Program_Error with
1345
           "Position cursor designates wrong set";
1346
      end if;
1347
 
1348
      pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1349
 
1350
      Replace_Element (Container.HT, Position.Node, New_Item);
1351
   end Replace_Element;
1352
 
1353
   ----------------------
1354
   -- Reserve_Capacity --
1355
   ----------------------
1356
 
1357
   procedure Reserve_Capacity
1358
     (Container : in out Set;
1359
      Capacity  : Count_Type)
1360
   is
1361
   begin
1362
      HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1363
   end Reserve_Capacity;
1364
 
1365
   --------------
1366
   -- Set_Next --
1367
   --------------
1368
 
1369
   procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1370
   begin
1371
      Node.Next := Next;
1372
   end Set_Next;
1373
 
1374
   --------------------------
1375
   -- Symmetric_Difference --
1376
   --------------------------
1377
 
1378
   procedure Symmetric_Difference
1379
     (Target : in out Set;
1380
      Source : Set)
1381
   is
1382
   begin
1383
      if Target'Address = Source'Address then
1384
         Clear (Target);
1385
         return;
1386
      end if;
1387
 
1388
      if Target.HT.Busy > 0 then
1389
         raise Program_Error with
1390
           "attempt to tamper with cursors (set is busy)";
1391
      end if;
1392
 
1393
      declare
1394
         N : constant Count_Type := Target.Length + Source.Length;
1395
      begin
1396
         if N > HT_Ops.Capacity (Target.HT) then
1397
            HT_Ops.Reserve_Capacity (Target.HT, N);
1398
         end if;
1399
      end;
1400
 
1401
      if Target.Length = 0 then
1402
         Iterate_Source_When_Empty_Target : declare
1403
            procedure Process (Src_Node : Node_Access);
1404
 
1405
            procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1406
 
1407
            -------------
1408
            -- Process --
1409
            -------------
1410
 
1411
            procedure Process (Src_Node : Node_Access) is
1412
               E : Element_Type renames Src_Node.Element.all;
1413
               B : Buckets_Type renames Target.HT.Buckets.all;
1414
               J : constant Hash_Type := Hash (E) mod B'Length;
1415
               N : Count_Type renames Target.HT.Length;
1416
 
1417
            begin
1418
               declare
1419
                  X : Element_Access := new Element_Type'(E);
1420
               begin
1421
                  B (J) := new Node_Type'(X, B (J));
1422
               exception
1423
                  when others =>
1424
                     Free_Element (X);
1425
                     raise;
1426
               end;
1427
 
1428
               N := N + 1;
1429
            end Process;
1430
 
1431
         --  Start of processing for Iterate_Source_When_Empty_Target
1432
 
1433
         begin
1434
            Iterate (Source.HT);
1435
         end Iterate_Source_When_Empty_Target;
1436
 
1437
      else
1438
         Iterate_Source : declare
1439
            procedure Process (Src_Node : Node_Access);
1440
 
1441
            procedure Iterate is
1442
               new HT_Ops.Generic_Iteration (Process);
1443
 
1444
            -------------
1445
            -- Process --
1446
            -------------
1447
 
1448
            procedure Process (Src_Node : Node_Access) is
1449
               E : Element_Type renames Src_Node.Element.all;
1450
               B : Buckets_Type renames Target.HT.Buckets.all;
1451
               J : constant Hash_Type := Hash (E) mod B'Length;
1452
               N : Count_Type renames Target.HT.Length;
1453
 
1454
            begin
1455
               if B (J) = null then
1456
                  declare
1457
                     X : Element_Access := new Element_Type'(E);
1458
                  begin
1459
                     B (J) := new Node_Type'(X, null);
1460
                  exception
1461
                     when others =>
1462
                        Free_Element (X);
1463
                        raise;
1464
                  end;
1465
 
1466
                  N := N + 1;
1467
 
1468
               elsif Equivalent_Elements (E, B (J).Element.all) then
1469
                  declare
1470
                     X : Node_Access := B (J);
1471
                  begin
1472
                     B (J) := B (J).Next;
1473
                     N := N - 1;
1474
                     Free (X);
1475
                  end;
1476
 
1477
               else
1478
                  declare
1479
                     Prev : Node_Access := B (J);
1480
                     Curr : Node_Access := Prev.Next;
1481
 
1482
                  begin
1483
                     while Curr /= null loop
1484
                        if Equivalent_Elements (E, Curr.Element.all) then
1485
                           Prev.Next := Curr.Next;
1486
                           N := N - 1;
1487
                           Free (Curr);
1488
                           return;
1489
                        end if;
1490
 
1491
                        Prev := Curr;
1492
                        Curr := Prev.Next;
1493
                     end loop;
1494
 
1495
                     declare
1496
                        X : Element_Access := new Element_Type'(E);
1497
                     begin
1498
                        B (J) := new Node_Type'(X, B (J));
1499
                     exception
1500
                        when others =>
1501
                           Free_Element (X);
1502
                           raise;
1503
                     end;
1504
 
1505
                     N := N + 1;
1506
                  end;
1507
               end if;
1508
            end Process;
1509
 
1510
         --  Start of processing for Iterate_Source
1511
 
1512
         begin
1513
            Iterate (Source.HT);
1514
         end Iterate_Source;
1515
      end if;
1516
   end Symmetric_Difference;
1517
 
1518
   function Symmetric_Difference (Left, Right : Set) return Set is
1519
      Buckets : HT_Types.Buckets_Access;
1520
      Length  : Count_Type;
1521
 
1522
   begin
1523
      if Left'Address = Right'Address then
1524
         return Empty_Set;
1525
      end if;
1526
 
1527
      if Right.Length = 0 then
1528
         return Left;
1529
      end if;
1530
 
1531
      if Left.Length = 0 then
1532
         return Right;
1533
      end if;
1534
 
1535
      declare
1536
         Size : constant Hash_Type :=
1537
                  Prime_Numbers.To_Prime (Left.Length + Right.Length);
1538
      begin
1539
         Buckets := HT_Ops.New_Buckets (Length => Size);
1540
      end;
1541
 
1542
      Length := 0;
1543
 
1544
      Iterate_Left : declare
1545
         procedure Process (L_Node : Node_Access);
1546
 
1547
         procedure Iterate is
1548
            new HT_Ops.Generic_Iteration (Process);
1549
 
1550
         -------------
1551
         -- Process --
1552
         -------------
1553
 
1554
         procedure Process (L_Node : Node_Access) is
1555
         begin
1556
            if not Is_In (Right.HT, L_Node) then
1557
               declare
1558
                  E : Element_Type renames L_Node.Element.all;
1559
                  J : constant Hash_Type := Hash (E) mod Buckets'Length;
1560
 
1561
               begin
1562
                  declare
1563
                     X : Element_Access := new Element_Type'(E);
1564
                  begin
1565
                     Buckets (J) := new Node_Type'(X, Buckets (J));
1566
                  exception
1567
                     when others =>
1568
                        Free_Element (X);
1569
                        raise;
1570
                  end;
1571
 
1572
                  Length := Length + 1;
1573
               end;
1574
            end if;
1575
         end Process;
1576
 
1577
      --  Start of processing for Iterate_Left
1578
 
1579
      begin
1580
         Iterate (Left.HT);
1581
      exception
1582
         when others =>
1583
            HT_Ops.Free_Hash_Table (Buckets);
1584
            raise;
1585
      end Iterate_Left;
1586
 
1587
      Iterate_Right : declare
1588
         procedure Process (R_Node : Node_Access);
1589
 
1590
         procedure Iterate is
1591
            new HT_Ops.Generic_Iteration (Process);
1592
 
1593
         -------------
1594
         -- Process --
1595
         -------------
1596
 
1597
         procedure Process (R_Node : Node_Access) is
1598
         begin
1599
            if not Is_In (Left.HT, R_Node) then
1600
               declare
1601
                  E : Element_Type renames R_Node.Element.all;
1602
                  J : constant Hash_Type := Hash (E) mod Buckets'Length;
1603
 
1604
               begin
1605
                  declare
1606
                     X : Element_Access := new Element_Type'(E);
1607
                  begin
1608
                     Buckets (J) := new Node_Type'(X, Buckets (J));
1609
                  exception
1610
                     when others =>
1611
                        Free_Element (X);
1612
                        raise;
1613
                  end;
1614
 
1615
                  Length := Length + 1;
1616
               end;
1617
            end if;
1618
         end Process;
1619
 
1620
      --  Start of processing for Iterate_Right
1621
 
1622
      begin
1623
         Iterate (Right.HT);
1624
      exception
1625
         when others =>
1626
            HT_Ops.Free_Hash_Table (Buckets);
1627
            raise;
1628
      end Iterate_Right;
1629
 
1630
      return (Controlled with HT => (Buckets, Length, 0, 0));
1631
   end Symmetric_Difference;
1632
 
1633
   ------------
1634
   -- To_Set --
1635
   ------------
1636
 
1637
   function To_Set (New_Item : Element_Type) return Set is
1638
      HT       : Hash_Table_Type;
1639
      Node     : Node_Access;
1640
      Inserted : Boolean;
1641
      pragma Unreferenced (Node, Inserted);
1642
   begin
1643
      Insert (HT, New_Item, Node, Inserted);
1644
      return Set'(Controlled with HT);
1645
   end To_Set;
1646
 
1647
   -----------
1648
   -- Union --
1649
   -----------
1650
 
1651
   procedure Union
1652
     (Target : in out Set;
1653
      Source : Set)
1654
   is
1655
      procedure Process (Src_Node : Node_Access);
1656
 
1657
      procedure Iterate is
1658
         new HT_Ops.Generic_Iteration (Process);
1659
 
1660
      -------------
1661
      -- Process --
1662
      -------------
1663
 
1664
      procedure Process (Src_Node : Node_Access) is
1665
         Src : Element_Type renames Src_Node.Element.all;
1666
 
1667
         function New_Node (Next : Node_Access) return Node_Access;
1668
         pragma Inline (New_Node);
1669
 
1670
         procedure Insert is
1671
            new Element_Keys.Generic_Conditional_Insert (New_Node);
1672
 
1673
         --------------
1674
         -- New_Node --
1675
         --------------
1676
 
1677
         function New_Node (Next : Node_Access) return Node_Access is
1678
            Tgt : Element_Access := new Element_Type'(Src);
1679
         begin
1680
            return new Node_Type'(Tgt, Next);
1681
         exception
1682
            when others =>
1683
               Free_Element (Tgt);
1684
               raise;
1685
         end New_Node;
1686
 
1687
         Tgt_Node : Node_Access;
1688
         Success  : Boolean;
1689
         pragma Unreferenced (Tgt_Node, Success);
1690
 
1691
      --  Start of processing for Process
1692
 
1693
      begin
1694
         Insert (Target.HT, Src, Tgt_Node, Success);
1695
      end Process;
1696
 
1697
   --  Start of processing for Union
1698
 
1699
   begin
1700
      if Target'Address = Source'Address then
1701
         return;
1702
      end if;
1703
 
1704
      if Target.HT.Busy > 0 then
1705
         raise Program_Error with
1706
           "attempt to tamper with cursors (set is busy)";
1707
      end if;
1708
 
1709
      declare
1710
         N : constant Count_Type := Target.Length + Source.Length;
1711
      begin
1712
         if N > HT_Ops.Capacity (Target.HT) then
1713
            HT_Ops.Reserve_Capacity (Target.HT, N);
1714
         end if;
1715
      end;
1716
 
1717
      Iterate (Source.HT);
1718
   end Union;
1719
 
1720
   function Union (Left, Right : Set) return Set is
1721
      Buckets : HT_Types.Buckets_Access;
1722
      Length  : Count_Type;
1723
 
1724
   begin
1725
      if Left'Address = Right'Address then
1726
         return Left;
1727
      end if;
1728
 
1729
      if Right.Length = 0 then
1730
         return Left;
1731
      end if;
1732
 
1733
      if Left.Length = 0 then
1734
         return Right;
1735
      end if;
1736
 
1737
      declare
1738
         Size : constant Hash_Type :=
1739
                  Prime_Numbers.To_Prime (Left.Length + Right.Length);
1740
      begin
1741
         Buckets := HT_Ops.New_Buckets (Length => Size);
1742
      end;
1743
 
1744
      Iterate_Left : declare
1745
         procedure Process (L_Node : Node_Access);
1746
 
1747
         procedure Iterate is
1748
            new HT_Ops.Generic_Iteration (Process);
1749
 
1750
         -------------
1751
         -- Process --
1752
         -------------
1753
 
1754
         procedure Process (L_Node : Node_Access) is
1755
            Src    : Element_Type renames L_Node.Element.all;
1756
            J      : constant Hash_Type := Hash (Src) mod Buckets'Length;
1757
            Bucket : Node_Access renames Buckets (J);
1758
            Tgt    : Element_Access := new Element_Type'(Src);
1759
         begin
1760
            Bucket := new Node_Type'(Tgt, Bucket);
1761
         exception
1762
            when others =>
1763
               Free_Element (Tgt);
1764
               raise;
1765
         end Process;
1766
 
1767
      --  Start of processing for Process
1768
 
1769
      begin
1770
         Iterate (Left.HT);
1771
      exception
1772
         when others =>
1773
            HT_Ops.Free_Hash_Table (Buckets);
1774
            raise;
1775
      end Iterate_Left;
1776
 
1777
      Length := Left.Length;
1778
 
1779
      Iterate_Right : declare
1780
         procedure Process (Src_Node : Node_Access);
1781
 
1782
         procedure Iterate is
1783
            new HT_Ops.Generic_Iteration (Process);
1784
 
1785
         -------------
1786
         -- Process --
1787
         -------------
1788
 
1789
         procedure Process (Src_Node : Node_Access) is
1790
            Src : Element_Type renames Src_Node.Element.all;
1791
            Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1792
 
1793
            Tgt_Node : Node_Access := Buckets (Idx);
1794
 
1795
         begin
1796
            while Tgt_Node /= null loop
1797
               if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1798
                  return;
1799
               end if;
1800
               Tgt_Node := Next (Tgt_Node);
1801
            end loop;
1802
 
1803
            declare
1804
               Tgt : Element_Access := new Element_Type'(Src);
1805
            begin
1806
               Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
1807
            exception
1808
               when others =>
1809
                  Free_Element (Tgt);
1810
                  raise;
1811
            end;
1812
 
1813
            Length := Length + 1;
1814
         end Process;
1815
 
1816
      --  Start of processing for Iterate_Right
1817
 
1818
      begin
1819
         Iterate (Right.HT);
1820
      exception
1821
         when others =>
1822
            HT_Ops.Free_Hash_Table (Buckets);
1823
            raise;
1824
      end Iterate_Right;
1825
 
1826
      return (Controlled with HT => (Buckets, Length, 0, 0));
1827
   end Union;
1828
 
1829
   ---------
1830
   -- Vet --
1831
   ---------
1832
 
1833
   function Vet (Position : Cursor) return Boolean is
1834
   begin
1835
      if Position.Node = null then
1836
         return Position.Container = null;
1837
      end if;
1838
 
1839
      if Position.Container = null then
1840
         return False;
1841
      end if;
1842
 
1843
      if Position.Node.Next = Position.Node then
1844
         return False;
1845
      end if;
1846
 
1847
      if Position.Node.Element = null then
1848
         return False;
1849
      end if;
1850
 
1851
      declare
1852
         HT : Hash_Table_Type renames Position.Container.HT;
1853
         X  : Node_Access;
1854
 
1855
      begin
1856
         if HT.Length = 0 then
1857
            return False;
1858
         end if;
1859
 
1860
         if HT.Buckets = null
1861
           or else HT.Buckets'Length = 0
1862
         then
1863
            return False;
1864
         end if;
1865
 
1866
         X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1867
 
1868
         for J in 1 .. HT.Length loop
1869
            if X = Position.Node then
1870
               return True;
1871
            end if;
1872
 
1873
            if X = null then
1874
               return False;
1875
            end if;
1876
 
1877
            if X = X.Next then  --  to prevent unnecessary looping
1878
               return False;
1879
            end if;
1880
 
1881
            X := X.Next;
1882
         end loop;
1883
 
1884
         return False;
1885
      end;
1886
   end Vet;
1887
 
1888
   -----------
1889
   -- Write --
1890
   -----------
1891
 
1892
   procedure Write
1893
     (Stream    : not null access Root_Stream_Type'Class;
1894
      Container : Set)
1895
   is
1896
   begin
1897
      Write_Nodes (Stream, Container.HT);
1898
   end Write;
1899
 
1900
   procedure Write
1901
     (Stream : not null access Root_Stream_Type'Class;
1902
      Item   : Cursor)
1903
   is
1904
   begin
1905
      raise Program_Error with "attempt to stream set cursor";
1906
   end Write;
1907
 
1908
   procedure Write
1909
     (Stream : not null access Root_Stream_Type'Class;
1910
      Item   : Constant_Reference_Type)
1911
   is
1912
   begin
1913
      raise Program_Error with "attempt to stream reference";
1914
   end Write;
1915
 
1916
   ----------------
1917
   -- Write_Node --
1918
   ----------------
1919
 
1920
   procedure Write_Node
1921
     (Stream : not null access Root_Stream_Type'Class;
1922
      Node   : Node_Access)
1923
   is
1924
   begin
1925
      Element_Type'Output (Stream, Node.Element.all);
1926
   end Write_Node;
1927
 
1928
   package body Generic_Keys is
1929
 
1930
      -----------------------
1931
      -- Local Subprograms --
1932
      -----------------------
1933
 
1934
      function Equivalent_Key_Node
1935
        (Key  : Key_Type;
1936
         Node : Node_Access) return Boolean;
1937
      pragma Inline (Equivalent_Key_Node);
1938
 
1939
      --------------------------
1940
      -- Local Instantiations --
1941
      --------------------------
1942
 
1943
      package Key_Keys is
1944
         new Hash_Tables.Generic_Keys
1945
          (HT_Types  => HT_Types,
1946
           Next      => Next,
1947
           Set_Next  => Set_Next,
1948
           Key_Type  => Key_Type,
1949
           Hash      => Hash,
1950
           Equivalent_Keys => Equivalent_Key_Node);
1951
 
1952
      ------------------------
1953
      -- Constant_Reference --
1954
      ------------------------
1955
 
1956
      function Constant_Reference
1957
        (Container : aliased Set;
1958
         Key       : Key_Type) return Constant_Reference_Type
1959
      is
1960
         Node : constant Node_Access :=
1961
                  Key_Keys.Find (Container.HT, Key);
1962
 
1963
      begin
1964
         if Node = null then
1965
            raise Constraint_Error with "Key not in set";
1966
         end if;
1967
 
1968
         if Node.Element = null then
1969
            raise Program_Error with "Node has no element";
1970
         end if;
1971
 
1972
         declare
1973
            HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
1974
            B : Natural renames HT.Busy;
1975
            L : Natural renames HT.Lock;
1976
         begin
1977
            return R : constant Constant_Reference_Type :=
1978
                         (Element => Node.Element.all'Access,
1979
                          Control =>
1980
                            (Controlled with Container'Unrestricted_Access))
1981
            do
1982
               B := B + 1;
1983
               L := L + 1;
1984
            end return;
1985
         end;
1986
      end Constant_Reference;
1987
 
1988
      --------------
1989
      -- Contains --
1990
      --------------
1991
 
1992
      function Contains
1993
        (Container : Set;
1994
         Key       : Key_Type) return Boolean
1995
      is
1996
      begin
1997
         return Find (Container, Key) /= No_Element;
1998
      end Contains;
1999
 
2000
      ------------
2001
      -- Delete --
2002
      ------------
2003
 
2004
      procedure Delete
2005
        (Container : in out Set;
2006
         Key       : Key_Type)
2007
      is
2008
         X : Node_Access;
2009
 
2010
      begin
2011
         Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2012
 
2013
         if X = null then
2014
            raise Constraint_Error with "key not in map";  --  ??? "set"
2015
         end if;
2016
 
2017
         Free (X);
2018
      end Delete;
2019
 
2020
      -------------
2021
      -- Element --
2022
      -------------
2023
 
2024
      function Element
2025
        (Container : Set;
2026
         Key       : Key_Type) return Element_Type
2027
      is
2028
         Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2029
 
2030
      begin
2031
         if Node = null then
2032
            raise Constraint_Error with "key not in map";  --  ??? "set"
2033
         end if;
2034
 
2035
         return Node.Element.all;
2036
      end Element;
2037
 
2038
      -------------------------
2039
      -- Equivalent_Key_Node --
2040
      -------------------------
2041
 
2042
      function Equivalent_Key_Node
2043
        (Key  : Key_Type;
2044
         Node : Node_Access) return Boolean is
2045
      begin
2046
         return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
2047
      end Equivalent_Key_Node;
2048
 
2049
      -------------
2050
      -- Exclude --
2051
      -------------
2052
 
2053
      procedure Exclude
2054
        (Container : in out Set;
2055
         Key       : Key_Type)
2056
      is
2057
         X : Node_Access;
2058
      begin
2059
         Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2060
         Free (X);
2061
      end Exclude;
2062
 
2063
      ----------
2064
      -- Find --
2065
      ----------
2066
 
2067
      function Find
2068
        (Container : Set;
2069
         Key       : Key_Type) return Cursor
2070
      is
2071
         Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2072
      begin
2073
         return (if Node = null then No_Element
2074
                 else Cursor'(Container'Unrestricted_Access, Node));
2075
      end Find;
2076
 
2077
      ---------
2078
      -- Key --
2079
      ---------
2080
 
2081
      function Key (Position : Cursor) return Key_Type is
2082
      begin
2083
         if Position.Node = null then
2084
            raise Constraint_Error with
2085
              "Position cursor equals No_Element";
2086
         end if;
2087
 
2088
         if Position.Node.Element = null then
2089
            raise Program_Error with "Position cursor is bad";
2090
         end if;
2091
 
2092
         pragma Assert (Vet (Position), "bad cursor in function Key");
2093
 
2094
         return Key (Position.Node.Element.all);
2095
      end Key;
2096
 
2097
      ----------
2098
      -- Read --
2099
      ----------
2100
 
2101
      procedure Read
2102
        (Stream : not null access Root_Stream_Type'Class;
2103
         Item   : out Reference_Type)
2104
      is
2105
      begin
2106
         raise Program_Error with "attempt to stream reference";
2107
      end Read;
2108
 
2109
      ------------------------------
2110
      -- Reference_Preserving_Key --
2111
      ------------------------------
2112
 
2113
      function Reference_Preserving_Key
2114
        (Container : aliased in out Set;
2115
         Position  : Cursor) return Reference_Type
2116
      is
2117
      begin
2118
         if Position.Container = null then
2119
            raise Constraint_Error with "Position cursor has no element";
2120
         end if;
2121
 
2122
         if Position.Container /= Container'Unrestricted_Access then
2123
            raise Program_Error with
2124
              "Position cursor designates wrong container";
2125
         end if;
2126
 
2127
         if Position.Node.Element = null then
2128
            raise Program_Error with "Node has no element";
2129
         end if;
2130
 
2131
         pragma Assert
2132
           (Vet (Position),
2133
            "bad cursor in function Reference_Preserving_Key");
2134
 
2135
         --  Some form of finalization will be required in order to actually
2136
         --  check that the key-part of the element designated by Position has
2137
         --  not changed.  ???
2138
 
2139
         return (Element => Position.Node.Element.all'Access);
2140
      end Reference_Preserving_Key;
2141
 
2142
      function Reference_Preserving_Key
2143
        (Container : aliased in out Set;
2144
         Key       : Key_Type) return Reference_Type
2145
      is
2146
         Node : constant Node_Access :=
2147
                  Key_Keys.Find (Container.HT, Key);
2148
 
2149
      begin
2150
         if Node = null then
2151
            raise Constraint_Error with "Key not in set";
2152
         end if;
2153
 
2154
         if Node.Element = null then
2155
            raise Program_Error with "Node has no element";
2156
         end if;
2157
 
2158
         --  Some form of finalization will be required in order to actually
2159
         --  check that the key-part of the element designated by Key has not
2160
         --  changed.  ???
2161
 
2162
         return (Element => Node.Element.all'Access);
2163
      end Reference_Preserving_Key;
2164
 
2165
      -------------
2166
      -- Replace --
2167
      -------------
2168
 
2169
      procedure Replace
2170
        (Container : in out Set;
2171
         Key       : Key_Type;
2172
         New_Item  : Element_Type)
2173
      is
2174
         Node : constant Node_Access :=
2175
                  Key_Keys.Find (Container.HT, Key);
2176
 
2177
      begin
2178
         if Node = null then
2179
            raise Constraint_Error with
2180
              "attempt to replace key not in set";
2181
         end if;
2182
 
2183
         Replace_Element (Container.HT, Node, New_Item);
2184
      end Replace;
2185
 
2186
      -----------------------------------
2187
      -- Update_Element_Preserving_Key --
2188
      -----------------------------------
2189
 
2190
      procedure Update_Element_Preserving_Key
2191
        (Container : in out Set;
2192
         Position  : Cursor;
2193
         Process   : not null access
2194
           procedure (Element : in out Element_Type))
2195
      is
2196
         HT   : Hash_Table_Type renames Container.HT;
2197
         Indx : Hash_Type;
2198
 
2199
      begin
2200
         if Position.Node = null then
2201
            raise Constraint_Error with
2202
              "Position cursor equals No_Element";
2203
         end if;
2204
 
2205
         if Position.Node.Element = null
2206
           or else Position.Node.Next = Position.Node
2207
         then
2208
            raise Program_Error with "Position cursor is bad";
2209
         end if;
2210
 
2211
         if Position.Container /= Container'Unrestricted_Access then
2212
            raise Program_Error with
2213
              "Position cursor designates wrong set";
2214
         end if;
2215
 
2216
         if HT.Buckets = null
2217
           or else HT.Buckets'Length = 0
2218
           or else HT.Length = 0
2219
         then
2220
            raise Program_Error with "Position cursor is bad (set is empty)";
2221
         end if;
2222
 
2223
         pragma Assert
2224
           (Vet (Position),
2225
            "bad cursor in Update_Element_Preserving_Key");
2226
 
2227
         Indx := HT_Ops.Index (HT, Position.Node);
2228
 
2229
         declare
2230
            E : Element_Type renames Position.Node.Element.all;
2231
            K : constant Key_Type := Key (E);
2232
 
2233
            B : Natural renames HT.Busy;
2234
            L : Natural renames HT.Lock;
2235
 
2236
         begin
2237
            B := B + 1;
2238
            L := L + 1;
2239
 
2240
            begin
2241
               Process (E);
2242
            exception
2243
               when others =>
2244
                  L := L - 1;
2245
                  B := B - 1;
2246
                  raise;
2247
            end;
2248
 
2249
            L := L - 1;
2250
            B := B - 1;
2251
 
2252
            if Equivalent_Keys (K, Key (E)) then
2253
               pragma Assert (Hash (K) = Hash (E));
2254
               return;
2255
            end if;
2256
         end;
2257
 
2258
         if HT.Buckets (Indx) = Position.Node then
2259
            HT.Buckets (Indx) := Position.Node.Next;
2260
 
2261
         else
2262
            declare
2263
               Prev : Node_Access := HT.Buckets (Indx);
2264
 
2265
            begin
2266
               while Prev.Next /= Position.Node loop
2267
                  Prev := Prev.Next;
2268
 
2269
                  if Prev = null then
2270
                     raise Program_Error with
2271
                       "Position cursor is bad (node not found)";
2272
                  end if;
2273
               end loop;
2274
 
2275
               Prev.Next := Position.Node.Next;
2276
            end;
2277
         end if;
2278
 
2279
         HT.Length := HT.Length - 1;
2280
 
2281
         declare
2282
            X : Node_Access := Position.Node;
2283
 
2284
         begin
2285
            Free (X);
2286
         end;
2287
 
2288
         raise Program_Error with "key was modified";
2289
      end Update_Element_Preserving_Key;
2290
 
2291
      -----------
2292
      -- Write --
2293
      -----------
2294
 
2295
      procedure Write
2296
        (Stream : not null access Root_Stream_Type'Class;
2297
         Item   : Reference_Type)
2298
      is
2299
      begin
2300
         raise Program_Error with "attempt to stream reference";
2301
      end Write;
2302
 
2303
   end Generic_Keys;
2304
 
2305
end Ada.Containers.Indefinite_Hashed_Sets;

powered by: WebSVN 2.1.0

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