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

Subversion Repositories openrisc_me

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

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

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