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

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [a-cohama.adb] - Blame information for rev 16

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 12 jlechner
------------------------------------------------------------------------------
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 _ M A P S           --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- This specification is derived from the Ada Reference Manual for use with --
12
-- GNAT. The copyright notice above, and the license provisions that follow --
13
-- apply solely to the  contents of the part following the private keyword. --
14
--                                                                          --
15
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
16
-- terms of the  GNU General Public License as published  by the Free Soft- --
17
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
18
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
19
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
20
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
21
-- for  more details.  You should have  received  a copy of the GNU General --
22
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
23
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
24
-- Boston, MA 02110-1301, USA.                                              --
25
--                                                                          --
26
-- As a special exception,  if other files  instantiate  generics from this --
27
-- unit, or you link  this unit with other files  to produce an executable, --
28
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
29
-- covered  by the  GNU  General  Public  License.  This exception does not --
30
-- however invalidate  any other reasons why  the executable file  might be --
31
-- covered by the  GNU Public License.                                      --
32
--                                                                          --
33
-- This unit was originally developed by Matthew J Heaney.                  --
34
------------------------------------------------------------------------------
35
 
36
with Ada.Unchecked_Deallocation;
37
 
38
with Ada.Containers.Hash_Tables.Generic_Operations;
39
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
40
 
41
with Ada.Containers.Hash_Tables.Generic_Keys;
42
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
43
 
44
package body Ada.Containers.Hashed_Maps is
45
 
46
   -----------------------
47
   -- Local Subprograms --
48
   -----------------------
49
 
50
   function Copy_Node
51
     (Source : Node_Access) return Node_Access;
52
   pragma Inline (Copy_Node);
53
 
54
   function Equivalent_Key_Node
55
     (Key  : Key_Type;
56
      Node : Node_Access) return Boolean;
57
   pragma Inline (Equivalent_Key_Node);
58
 
59
   procedure Free (X : in out Node_Access);
60
 
61
   function Find_Equal_Key
62
     (R_HT   : Hash_Table_Type;
63
      L_Node : Node_Access) return Boolean;
64
 
65
   function Hash_Node (Node : Node_Access) return Hash_Type;
66
   pragma Inline (Hash_Node);
67
 
68
   function Next (Node : Node_Access) return Node_Access;
69
   pragma Inline (Next);
70
 
71
   function Read_Node
72
     (Stream : access Root_Stream_Type'Class) return Node_Access;
73
   pragma Inline (Read_Node);
74
 
75
   procedure Set_Next (Node : Node_Access; Next : Node_Access);
76
   pragma Inline (Set_Next);
77
 
78
   function Vet (Position : Cursor) return Boolean;
79
 
80
   procedure Write_Node
81
     (Stream : access Root_Stream_Type'Class;
82
      Node   : Node_Access);
83
   pragma Inline (Write_Node);
84
 
85
   --------------------------
86
   -- Local Instantiations --
87
   --------------------------
88
 
89
   package HT_Ops is
90
      new Hash_Tables.Generic_Operations
91
       (HT_Types          => HT_Types,
92
        Hash_Node         => Hash_Node,
93
        Next              => Next,
94
        Set_Next          => Set_Next,
95
        Copy_Node         => Copy_Node,
96
        Free              => Free);
97
 
98
   package Key_Ops is
99
      new Hash_Tables.Generic_Keys
100
       (HT_Types  => HT_Types,
101
        Next      => Next,
102
        Set_Next  => Set_Next,
103
        Key_Type  => Key_Type,
104
        Hash      => Hash,
105
        Equivalent_Keys => Equivalent_Key_Node);
106
 
107
   function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
108
 
109
   procedure Read_Nodes  is new HT_Ops.Generic_Read (Read_Node);
110
   procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
111
 
112
   ---------
113
   -- "=" --
114
   ---------
115
 
116
   function "=" (Left, Right : Map) return Boolean is
117
   begin
118
      return Is_Equal (Left.HT, Right.HT);
119
   end "=";
120
 
121
   ------------
122
   -- Adjust --
123
   ------------
124
 
125
   procedure Adjust (Container : in out Map) is
126
   begin
127
      HT_Ops.Adjust (Container.HT);
128
   end Adjust;
129
 
130
   --------------
131
   -- Capacity --
132
   --------------
133
 
134
   function Capacity (Container : Map) return Count_Type is
135
   begin
136
      return HT_Ops.Capacity (Container.HT);
137
   end Capacity;
138
 
139
   -----------
140
   -- Clear --
141
   -----------
142
 
143
   procedure Clear (Container : in out Map) is
144
   begin
145
      HT_Ops.Clear (Container.HT);
146
   end Clear;
147
 
148
   --------------
149
   -- Contains --
150
   --------------
151
 
152
   function Contains (Container : Map; Key : Key_Type) return Boolean is
153
   begin
154
      return Find (Container, Key) /= No_Element;
155
   end Contains;
156
 
157
   ---------------
158
   -- Copy_Node --
159
   ---------------
160
 
161
   function Copy_Node
162
     (Source : Node_Access) return Node_Access
163
   is
164
      Target : constant Node_Access :=
165
                 new Node_Type'(Key     => Source.Key,
166
                                Element => Source.Element,
167
                                Next    => null);
168
   begin
169
      return Target;
170
   end Copy_Node;
171
 
172
   ------------
173
   -- Delete --
174
   ------------
175
 
176
   procedure Delete (Container : in out Map; Key : Key_Type) is
177
      X : Node_Access;
178
 
179
   begin
180
      Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
181
 
182
      if X = null then
183
         raise Constraint_Error;
184
      end if;
185
 
186
      Free (X);
187
   end Delete;
188
 
189
   procedure Delete (Container : in out Map; Position : in out Cursor) is
190
   begin
191
      pragma Assert (Vet (Position), "bad cursor in Delete");
192
 
193
      if Position.Node = null then
194
         raise Constraint_Error;
195
      end if;
196
 
197
      if Position.Container /= Container'Unrestricted_Access then
198
         raise Program_Error;
199
      end if;
200
 
201
      if Container.HT.Busy > 0 then
202
         raise Program_Error;
203
      end if;
204
 
205
      HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
206
 
207
      Free (Position.Node);
208
      Position.Container := null;
209
   end Delete;
210
 
211
   -------------
212
   -- Element --
213
   -------------
214
 
215
   function Element (Container : Map; Key : Key_Type) return Element_Type is
216
      Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
217
 
218
   begin
219
      if Node = null then
220
         raise Constraint_Error;
221
      end if;
222
 
223
      return Node.Element;
224
   end Element;
225
 
226
   function Element (Position : Cursor) return Element_Type is
227
   begin
228
      pragma Assert (Vet (Position), "bad cursor in function Element");
229
 
230
      if Position.Node = null then
231
         raise Constraint_Error;
232
      end if;
233
 
234
      return Position.Node.Element;
235
   end Element;
236
 
237
   -------------------------
238
   -- Equivalent_Key_Node --
239
   -------------------------
240
 
241
   function Equivalent_Key_Node
242
     (Key  : Key_Type;
243
      Node : Node_Access) return Boolean is
244
   begin
245
      return Equivalent_Keys (Key, Node.Key);
246
   end Equivalent_Key_Node;
247
 
248
   ---------------------
249
   -- Equivalent_Keys --
250
   ---------------------
251
 
252
   function Equivalent_Keys (Left, Right : Cursor)
253
     return Boolean is
254
   begin
255
      pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
256
      pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
257
 
258
      if Left.Node = null
259
        or else Right.Node = null
260
      then
261
         raise Constraint_Error;
262
      end if;
263
 
264
      return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
265
   end Equivalent_Keys;
266
 
267
   function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
268
   begin
269
      pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
270
 
271
      if Left.Node = null then
272
         raise Constraint_Error;
273
      end if;
274
 
275
      return Equivalent_Keys (Left.Node.Key, Right);
276
   end Equivalent_Keys;
277
 
278
   function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
279
   begin
280
      pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
281
 
282
      if Right.Node = null then
283
         raise Constraint_Error;
284
      end if;
285
 
286
      return Equivalent_Keys (Left, Right.Node.Key);
287
   end Equivalent_Keys;
288
 
289
   -------------
290
   -- Exclude --
291
   -------------
292
 
293
   procedure Exclude (Container : in out Map; Key : Key_Type) is
294
      X : Node_Access;
295
   begin
296
      Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
297
      Free (X);
298
   end Exclude;
299
 
300
   --------------
301
   -- Finalize --
302
   --------------
303
 
304
   procedure Finalize (Container : in out Map) is
305
   begin
306
      HT_Ops.Finalize (Container.HT);
307
   end Finalize;
308
 
309
   ----------
310
   -- Find --
311
   ----------
312
 
313
   function Find (Container : Map; Key : Key_Type) return Cursor is
314
      Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
315
 
316
   begin
317
      if Node = null then
318
         return No_Element;
319
      end if;
320
 
321
      return Cursor'(Container'Unchecked_Access, Node);
322
   end Find;
323
 
324
   --------------------
325
   -- Find_Equal_Key --
326
   --------------------
327
 
328
   function Find_Equal_Key
329
     (R_HT   : Hash_Table_Type;
330
      L_Node : Node_Access) return Boolean
331
   is
332
      R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
333
      R_Node  : Node_Access := R_HT.Buckets (R_Index);
334
 
335
   begin
336
      while R_Node /= null loop
337
         if Equivalent_Keys (L_Node.Key, R_Node.Key) then
338
            return L_Node.Element = R_Node.Element;
339
         end if;
340
 
341
         R_Node := R_Node.Next;
342
      end loop;
343
 
344
      return False;
345
   end Find_Equal_Key;
346
 
347
   -----------
348
   -- First --
349
   -----------
350
 
351
   function First (Container : Map) return Cursor is
352
      Node : constant Node_Access := HT_Ops.First (Container.HT);
353
 
354
   begin
355
      if Node = null then
356
         return No_Element;
357
      end if;
358
 
359
      return Cursor'(Container'Unchecked_Access, Node);
360
   end First;
361
 
362
   ----------
363
   -- Free --
364
   ----------
365
 
366
   procedure Free (X : in out Node_Access) is
367
      procedure Deallocate is
368
         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
369
   begin
370
      if X /= null then
371
         X.Next := X;     --  detect mischief (in Vet)
372
         Deallocate (X);
373
      end if;
374
   end Free;
375
 
376
   -----------------
377
   -- Has_Element --
378
   -----------------
379
 
380
   function Has_Element (Position : Cursor) return Boolean is
381
   begin
382
      pragma Assert (Vet (Position), "bad cursor in Has_Element");
383
      return Position.Node /= null;
384
   end Has_Element;
385
 
386
   ---------------
387
   -- Hash_Node --
388
   ---------------
389
 
390
   function Hash_Node (Node : Node_Access) return Hash_Type is
391
   begin
392
      return Hash (Node.Key);
393
   end Hash_Node;
394
 
395
   -------------
396
   -- Include --
397
   -------------
398
 
399
   procedure Include
400
     (Container : in out Map;
401
      Key       : Key_Type;
402
      New_Item  : Element_Type)
403
   is
404
      Position : Cursor;
405
      Inserted : Boolean;
406
 
407
   begin
408
      Insert (Container, Key, New_Item, Position, Inserted);
409
 
410
      if not Inserted then
411
         if Container.HT.Lock > 0 then
412
            raise Program_Error;
413
         end if;
414
 
415
         Position.Node.Key := Key;
416
         Position.Node.Element := New_Item;
417
      end if;
418
   end Include;
419
 
420
   ------------
421
   -- Insert --
422
   ------------
423
 
424
   procedure Insert
425
     (Container : in out Map;
426
      Key       : Key_Type;
427
      Position  : out Cursor;
428
      Inserted  : out Boolean)
429
   is
430
      function New_Node (Next : Node_Access) return Node_Access;
431
      pragma Inline (New_Node);
432
 
433
      procedure Local_Insert is
434
        new Key_Ops.Generic_Conditional_Insert (New_Node);
435
 
436
      --------------
437
      -- New_Node --
438
      --------------
439
 
440
      function New_Node (Next : Node_Access) return Node_Access is
441
         Node : Node_Access := new Node_Type; --  Ada 2005 aggregate possible?
442
 
443
      begin
444
         Node.Key := Key;
445
         Node.Next := Next;
446
 
447
         return Node;
448
 
449
      exception
450
         when others =>
451
            Free (Node);
452
            raise;
453
      end New_Node;
454
 
455
      HT : Hash_Table_Type renames Container.HT;
456
 
457
   --  Start of processing for Insert
458
 
459
   begin
460
      if HT_Ops.Capacity (HT) = 0 then
461
         HT_Ops.Reserve_Capacity (HT, 1);
462
      end if;
463
 
464
      Local_Insert (HT, Key, Position.Node, Inserted);
465
 
466
      if Inserted
467
        and then HT.Length > HT_Ops.Capacity (HT)
468
      then
469
         HT_Ops.Reserve_Capacity (HT, HT.Length);
470
      end if;
471
 
472
      Position.Container := Container'Unchecked_Access;
473
   end Insert;
474
 
475
   procedure Insert
476
     (Container : in out Map;
477
      Key       : Key_Type;
478
      New_Item  : Element_Type;
479
      Position  : out Cursor;
480
      Inserted  : out Boolean)
481
   is
482
      function New_Node (Next : Node_Access) return Node_Access;
483
      pragma Inline (New_Node);
484
 
485
      procedure Local_Insert is
486
        new Key_Ops.Generic_Conditional_Insert (New_Node);
487
 
488
      --------------
489
      -- New_Node --
490
      --------------
491
 
492
      function New_Node (Next : Node_Access) return Node_Access is
493
         Node : constant Node_Access := new Node_Type'(Key, New_Item, Next);
494
      begin
495
         return Node;
496
      end New_Node;
497
 
498
      HT : Hash_Table_Type renames Container.HT;
499
 
500
   --  Start of processing for Insert
501
 
502
   begin
503
      if HT_Ops.Capacity (HT) = 0 then
504
         HT_Ops.Reserve_Capacity (HT, 1);
505
      end if;
506
 
507
      Local_Insert (HT, Key, Position.Node, Inserted);
508
 
509
      if Inserted
510
        and then HT.Length > HT_Ops.Capacity (HT)
511
      then
512
         HT_Ops.Reserve_Capacity (HT, HT.Length);
513
      end if;
514
 
515
      Position.Container := Container'Unchecked_Access;
516
   end Insert;
517
 
518
   procedure Insert
519
     (Container : in out Map;
520
      Key       : Key_Type;
521
      New_Item  : Element_Type)
522
   is
523
      Position : Cursor;
524
      Inserted : Boolean;
525
 
526
   begin
527
      Insert (Container, Key, New_Item, Position, Inserted);
528
 
529
      if not Inserted then
530
         raise Constraint_Error;
531
      end if;
532
   end Insert;
533
 
534
   --------------
535
   -- Is_Empty --
536
   --------------
537
 
538
   function Is_Empty (Container : Map) return Boolean is
539
   begin
540
      return Container.HT.Length = 0;
541
   end Is_Empty;
542
 
543
   -------------
544
   -- Iterate --
545
   -------------
546
 
547
   procedure Iterate
548
     (Container : Map;
549
      Process   : not null access procedure (Position : Cursor))
550
   is
551
      procedure Process_Node (Node : Node_Access);
552
      pragma Inline (Process_Node);
553
 
554
      procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
555
 
556
      ------------------
557
      -- Process_Node --
558
      ------------------
559
 
560
      procedure Process_Node (Node : Node_Access) is
561
      begin
562
         Process (Cursor'(Container'Unchecked_Access, Node));
563
      end Process_Node;
564
 
565
   --  Start of processing for Iterate
566
 
567
   begin
568
      Local_Iterate (Container.HT);
569
   end Iterate;
570
 
571
   ---------
572
   -- Key --
573
   ---------
574
 
575
   function Key (Position : Cursor) return Key_Type is
576
   begin
577
      pragma Assert (Vet (Position), "bad cursor in function Key");
578
 
579
      if Position.Node = null then
580
         raise Constraint_Error;
581
      end if;
582
 
583
      return Position.Node.Key;
584
   end Key;
585
 
586
   ------------
587
   -- Length --
588
   ------------
589
 
590
   function Length (Container : Map) return Count_Type is
591
   begin
592
      return Container.HT.Length;
593
   end Length;
594
 
595
   ----------
596
   -- Move --
597
   ----------
598
 
599
   procedure Move
600
     (Target : in out Map;
601
      Source : in out Map)
602
   is
603
   begin
604
      HT_Ops.Move (Target => Target.HT, Source => Source.HT);
605
   end Move;
606
 
607
   ----------
608
   -- Next --
609
   ----------
610
 
611
   function Next (Node : Node_Access) return Node_Access is
612
   begin
613
      return Node.Next;
614
   end Next;
615
 
616
   function Next (Position : Cursor) return Cursor is
617
   begin
618
      pragma Assert (Vet (Position), "bad cursor in function Next");
619
 
620
      if Position.Node = null then
621
         return No_Element;
622
      end if;
623
 
624
      declare
625
         HT   : Hash_Table_Type renames Position.Container.HT;
626
         Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
627
 
628
      begin
629
         if Node = null then
630
            return No_Element;
631
         end if;
632
 
633
         return Cursor'(Position.Container, Node);
634
      end;
635
   end Next;
636
 
637
   procedure Next (Position : in out Cursor) is
638
   begin
639
      Position := Next (Position);
640
   end Next;
641
 
642
   -------------------
643
   -- Query_Element --
644
   -------------------
645
 
646
   procedure Query_Element
647
     (Position : Cursor;
648
      Process  : not null access
649
                   procedure (Key : Key_Type; Element : Element_Type))
650
   is
651
   begin
652
      pragma Assert (Vet (Position), "bad cursor in Query_Element");
653
 
654
      if Position.Node = null then
655
         raise Constraint_Error;
656
      end if;
657
 
658
      declare
659
         M  : Map renames Position.Container.all;
660
         HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
661
 
662
         B : Natural renames HT.Busy;
663
         L : Natural renames HT.Lock;
664
 
665
      begin
666
         B := B + 1;
667
         L := L + 1;
668
 
669
         declare
670
            K : Key_Type renames Position.Node.Key;
671
            E : Element_Type renames Position.Node.Element;
672
 
673
         begin
674
            Process (K, E);
675
         exception
676
            when others =>
677
               L := L - 1;
678
               B := B - 1;
679
               raise;
680
         end;
681
 
682
         L := L - 1;
683
         B := B - 1;
684
      end;
685
   end Query_Element;
686
 
687
   ----------
688
   -- Read --
689
   ----------
690
 
691
   procedure Read
692
     (Stream    : access Root_Stream_Type'Class;
693
      Container : out Map)
694
   is
695
   begin
696
      Read_Nodes (Stream, Container.HT);
697
   end Read;
698
 
699
   procedure Read
700
     (Stream : access Root_Stream_Type'Class;
701
      Item   : out Cursor)
702
   is
703
   begin
704
      raise Program_Error;
705
   end Read;
706
 
707
   ---------------
708
   -- Read_Node --
709
   ---------------
710
 
711
   function Read_Node
712
     (Stream : access Root_Stream_Type'Class) return Node_Access
713
   is
714
      Node : Node_Access := new Node_Type;
715
 
716
   begin
717
      Key_Type'Read (Stream, Node.Key);
718
      Element_Type'Read (Stream, Node.Element);
719
      return Node;
720
 
721
   exception
722
      when others =>
723
         Free (Node);
724
         raise;
725
   end Read_Node;
726
 
727
   -------------
728
   -- Replace --
729
   -------------
730
 
731
   procedure Replace
732
     (Container : in out Map;
733
      Key       : Key_Type;
734
      New_Item  : Element_Type)
735
   is
736
      Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
737
 
738
   begin
739
      if Node = null then
740
         raise Constraint_Error;
741
      end if;
742
 
743
      if Container.HT.Lock > 0 then
744
         raise Program_Error;
745
      end if;
746
 
747
      Node.Key := Key;
748
      Node.Element := New_Item;
749
   end Replace;
750
 
751
   ---------------------
752
   -- Replace_Element --
753
   ---------------------
754
 
755
   procedure Replace_Element
756
     (Container : in out Map;
757
      Position  : Cursor;
758
      New_Item  : Element_Type)
759
   is
760
   begin
761
      pragma Assert (Vet (Position), "bad cursor in Replace_Element");
762
 
763
      if Position.Node = null then
764
         raise Constraint_Error;
765
      end if;
766
 
767
      if Position.Container /= Container'Unrestricted_Access then
768
         raise Program_Error;
769
      end if;
770
 
771
      if Position.Container.HT.Lock > 0 then
772
         raise Program_Error;
773
      end if;
774
 
775
      Position.Node.Element := New_Item;
776
   end Replace_Element;
777
 
778
   ----------------------
779
   -- Reserve_Capacity --
780
   ----------------------
781
 
782
   procedure Reserve_Capacity
783
     (Container : in out Map;
784
      Capacity  : Count_Type)
785
   is
786
   begin
787
      HT_Ops.Reserve_Capacity (Container.HT, Capacity);
788
   end Reserve_Capacity;
789
 
790
   --------------
791
   -- Set_Next --
792
   --------------
793
 
794
   procedure Set_Next (Node : Node_Access; Next : Node_Access) is
795
   begin
796
      Node.Next := Next;
797
   end Set_Next;
798
 
799
   --------------------
800
   -- Update_Element --
801
   --------------------
802
 
803
   procedure Update_Element
804
     (Container : in out Map;
805
      Position  : Cursor;
806
      Process   : not null access procedure (Key     : Key_Type;
807
                                             Element : in out Element_Type))
808
   is
809
   begin
810
      pragma Assert (Vet (Position), "bad cursor in Update_Element");
811
 
812
      if Position.Node = null then
813
         raise Constraint_Error;
814
      end if;
815
 
816
      if Position.Container /= Container'Unrestricted_Access then
817
         raise Program_Error;
818
      end if;
819
 
820
      declare
821
         HT : Hash_Table_Type renames Container.HT;
822
         B  : Natural renames HT.Busy;
823
         L  : Natural renames HT.Lock;
824
 
825
      begin
826
         B := B + 1;
827
         L := L + 1;
828
 
829
         declare
830
            K : Key_Type renames Position.Node.Key;
831
            E : Element_Type renames Position.Node.Element;
832
         begin
833
            Process (K, E);
834
         exception
835
            when others =>
836
               L := L - 1;
837
               B := B - 1;
838
               raise;
839
         end;
840
 
841
         L := L - 1;
842
         B := B - 1;
843
      end;
844
   end Update_Element;
845
 
846
   ---------
847
   -- Vet --
848
   ---------
849
 
850
   function Vet (Position : Cursor) return Boolean is
851
   begin
852
      if Position.Node = null then
853
         return Position.Container = null;
854
      end if;
855
 
856
      if Position.Container = null then
857
         return False;
858
      end if;
859
 
860
      if Position.Node.Next = Position.Node then
861
         return False;
862
      end if;
863
 
864
      declare
865
         HT : Hash_Table_Type renames Position.Container.HT;
866
         X  : Node_Access;
867
 
868
      begin
869
         if HT.Length = 0 then
870
            return False;
871
         end if;
872
 
873
         if HT.Buckets = null
874
           or else HT.Buckets'Length = 0
875
         then
876
            return False;
877
         end if;
878
 
879
         X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key));
880
 
881
         for J in 1 .. HT.Length loop
882
            if X = Position.Node then
883
               return True;
884
            end if;
885
 
886
            if X = null then
887
               return False;
888
            end if;
889
 
890
            if X = X.Next then  --  to prevent endless loop
891
               return False;
892
            end if;
893
 
894
            X := X.Next;
895
         end loop;
896
 
897
         return False;
898
      end;
899
   end Vet;
900
 
901
   -----------
902
   -- Write --
903
   -----------
904
 
905
   procedure Write
906
     (Stream    : access Root_Stream_Type'Class;
907
      Container : Map)
908
   is
909
   begin
910
      Write_Nodes (Stream, Container.HT);
911
   end Write;
912
 
913
   procedure Write
914
     (Stream : access Root_Stream_Type'Class;
915
      Item   : Cursor)
916
   is
917
   begin
918
      raise Program_Error;
919
   end Write;
920
 
921
   ----------------
922
   -- Write_Node --
923
   ----------------
924
 
925
   procedure Write_Node
926
     (Stream : access Root_Stream_Type'Class;
927
      Node   : Node_Access)
928
   is
929
   begin
930
      Key_Type'Write (Stream, Node.Key);
931
      Element_Type'Write (Stream, Node.Element);
932
   end Write_Node;
933
 
934
end Ada.Containers.Hashed_Maps;

powered by: WebSVN 2.1.0

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