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-cihama.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT LIBRARY COMPONENTS                          --
4
--                                                                          --
5
--                  ADA.CONTAINERS.INDEFINITE_HASHED_MAPS                   --
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.Containers.Hash_Tables.Generic_Operations;
31
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
32
 
33
with Ada.Containers.Hash_Tables.Generic_Keys;
34
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
35
 
36
with Ada.Unchecked_Deallocation;
37
 
38
package body Ada.Containers.Indefinite_Hashed_Maps is
39
 
40
   procedure Free_Key is
41
      new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
42
 
43
   procedure Free_Element is
44
      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
45
 
46
   -----------------------
47
   -- Local Subprograms --
48
   -----------------------
49
 
50
   function Copy_Node (Node : Node_Access) return Node_Access;
51
   pragma Inline (Copy_Node);
52
 
53
   function Equivalent_Key_Node
54
     (Key  : Key_Type;
55
      Node : Node_Access) return Boolean;
56
   pragma Inline (Equivalent_Key_Node);
57
 
58
   function Find_Equal_Key
59
     (R_HT   : Hash_Table_Type;
60
      L_Node : Node_Access) return Boolean;
61
 
62
   procedure Free (X : in out Node_Access);
63
   --  pragma Inline (Free);
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 : not null access Root_Stream_Type'Class) return Node_Access;
73
 
74
   procedure Set_Next (Node : Node_Access; Next : Node_Access);
75
   pragma Inline (Set_Next);
76
 
77
   function Vet (Position : Cursor) return Boolean;
78
 
79
   procedure Write_Node
80
     (Stream : not null access Root_Stream_Type'Class;
81
      Node   : Node_Access);
82
 
83
   --------------------------
84
   -- Local Instantiations --
85
   --------------------------
86
 
87
   package HT_Ops is new Ada.Containers.Hash_Tables.Generic_Operations
88
     (HT_Types  => HT_Types,
89
      Hash_Node => Hash_Node,
90
      Next      => Next,
91
      Set_Next  => Set_Next,
92
      Copy_Node => Copy_Node,
93
      Free      => Free);
94
 
95
   package Key_Ops is new Hash_Tables.Generic_Keys
96
     (HT_Types        => HT_Types,
97
      Next            => Next,
98
      Set_Next        => Set_Next,
99
      Key_Type        => Key_Type,
100
      Hash            => Hash,
101
      Equivalent_Keys => Equivalent_Key_Node);
102
 
103
   ---------
104
   -- "=" --
105
   ---------
106
 
107
   function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
108
 
109
   overriding function "=" (Left, Right : Map) return Boolean is
110
   begin
111
      return Is_Equal (Left.HT, Right.HT);
112
   end "=";
113
 
114
   ------------
115
   -- Adjust --
116
   ------------
117
 
118
   procedure Adjust (Container : in out Map) is
119
   begin
120
      HT_Ops.Adjust (Container.HT);
121
   end Adjust;
122
 
123
   --------------
124
   -- Capacity --
125
   --------------
126
 
127
   function Capacity (Container : Map) return Count_Type is
128
   begin
129
      return HT_Ops.Capacity (Container.HT);
130
   end Capacity;
131
 
132
   -----------
133
   -- Clear --
134
   -----------
135
 
136
   procedure Clear (Container : in out Map) is
137
   begin
138
      HT_Ops.Clear (Container.HT);
139
   end Clear;
140
 
141
   --------------
142
   -- Contains --
143
   --------------
144
 
145
   function Contains (Container : Map; Key : Key_Type) return Boolean is
146
   begin
147
      return Find (Container, Key) /= No_Element;
148
   end Contains;
149
 
150
   ---------------
151
   -- Copy_Node --
152
   ---------------
153
 
154
   function Copy_Node (Node : Node_Access) return Node_Access is
155
      K : Key_Access := new Key_Type'(Node.Key.all);
156
      E : Element_Access;
157
 
158
   begin
159
      E := new Element_Type'(Node.Element.all);
160
      return new Node_Type'(K, E, null);
161
 
162
   exception
163
      when others =>
164
         Free_Key (K);
165
         Free_Element (E);
166
         raise;
167
   end Copy_Node;
168
 
169
   ------------
170
   -- Delete --
171
   ------------
172
 
173
   procedure Delete (Container : in out Map; Key : Key_Type) is
174
      X : Node_Access;
175
 
176
   begin
177
      Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
178
 
179
      if X = null then
180
         raise Constraint_Error with "attempt to delete key not in map";
181
      end if;
182
 
183
      Free (X);
184
   end Delete;
185
 
186
   procedure Delete (Container : in out Map; Position : in out Cursor) is
187
   begin
188
      if Position.Node = null then
189
         raise Constraint_Error with
190
           "Position cursor of Delete equals No_Element";
191
      end if;
192
 
193
      if Position.Container /= Container'Unrestricted_Access then
194
         raise Program_Error with
195
           "Position cursor of Delete designates wrong map";
196
      end if;
197
 
198
      if Container.HT.Busy > 0 then
199
         raise Program_Error with
200
           "Delete attempted to tamper with elements (map is busy)";
201
      end if;
202
 
203
      pragma Assert (Vet (Position), "bad cursor in Delete");
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 with
221
           "no element available because key not in map";
222
      end if;
223
 
224
      return Node.Element.all;
225
   end Element;
226
 
227
   function Element (Position : Cursor) return Element_Type is
228
   begin
229
      if Position.Node = null then
230
         raise Constraint_Error with
231
           "Position cursor of function Element equals No_Element";
232
      end if;
233
 
234
      if Position.Node.Element = null then
235
         raise Program_Error with
236
           "Position cursor of function Element is bad";
237
      end if;
238
 
239
      pragma Assert (Vet (Position), "bad cursor in function Element");
240
 
241
      return Position.Node.Element.all;
242
   end Element;
243
 
244
   -------------------------
245
   -- Equivalent_Key_Node --
246
   -------------------------
247
 
248
   function Equivalent_Key_Node
249
     (Key  : Key_Type;
250
      Node : Node_Access) return Boolean
251
   is
252
   begin
253
      return Equivalent_Keys (Key, Node.Key.all);
254
   end Equivalent_Key_Node;
255
 
256
   ---------------------
257
   -- Equivalent_Keys --
258
   ---------------------
259
 
260
   function Equivalent_Keys (Left, Right : Cursor) return Boolean is
261
   begin
262
      if Left.Node = null then
263
         raise Constraint_Error with
264
           "Left cursor of Equivalent_Keys equals No_Element";
265
      end if;
266
 
267
      if Right.Node = null then
268
         raise Constraint_Error with
269
           "Right cursor of Equivalent_Keys equals No_Element";
270
      end if;
271
 
272
      if Left.Node.Key = null then
273
         raise Program_Error with
274
           "Left cursor of Equivalent_Keys is bad";
275
      end if;
276
 
277
      if Right.Node.Key = null then
278
         raise Program_Error with
279
           "Right cursor of Equivalent_Keys is bad";
280
      end if;
281
 
282
      pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
283
      pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
284
 
285
      return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
286
   end Equivalent_Keys;
287
 
288
   function Equivalent_Keys
289
     (Left  : Cursor;
290
      Right : Key_Type) return Boolean
291
   is
292
   begin
293
      if Left.Node = null then
294
         raise Constraint_Error with
295
           "Left cursor of Equivalent_Keys equals No_Element";
296
      end if;
297
 
298
      if Left.Node.Key = null then
299
         raise Program_Error with
300
           "Left cursor of Equivalent_Keys is bad";
301
      end if;
302
 
303
      pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
304
 
305
      return Equivalent_Keys (Left.Node.Key.all, Right);
306
   end Equivalent_Keys;
307
 
308
   function Equivalent_Keys
309
     (Left  : Key_Type;
310
      Right : Cursor) return Boolean
311
   is
312
   begin
313
      if Right.Node = null then
314
         raise Constraint_Error with
315
           "Right cursor of Equivalent_Keys equals No_Element";
316
      end if;
317
 
318
      if Right.Node.Key = null then
319
         raise Program_Error with
320
           "Right cursor of Equivalent_Keys is bad";
321
      end if;
322
 
323
      pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
324
 
325
      return Equivalent_Keys (Left, Right.Node.Key.all);
326
   end Equivalent_Keys;
327
 
328
   -------------
329
   -- Exclude --
330
   -------------
331
 
332
   procedure Exclude (Container : in out Map; Key : Key_Type) is
333
      X : Node_Access;
334
   begin
335
      Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
336
      Free (X);
337
   end Exclude;
338
 
339
   --------------
340
   -- Finalize --
341
   --------------
342
 
343
   procedure Finalize (Container : in out Map) is
344
   begin
345
      HT_Ops.Finalize (Container.HT);
346
   end Finalize;
347
 
348
   ----------
349
   -- Find --
350
   ----------
351
 
352
   function Find (Container : Map; Key : Key_Type) return Cursor is
353
      Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
354
 
355
   begin
356
      if Node = null then
357
         return No_Element;
358
      end if;
359
 
360
      return Cursor'(Container'Unchecked_Access, Node);
361
   end Find;
362
 
363
   --------------------
364
   -- Find_Equal_Key --
365
   --------------------
366
 
367
   function Find_Equal_Key
368
     (R_HT   : Hash_Table_Type;
369
      L_Node : Node_Access) return Boolean
370
   is
371
      R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all);
372
      R_Node  : Node_Access := R_HT.Buckets (R_Index);
373
 
374
   begin
375
      while R_Node /= null loop
376
         if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
377
            return L_Node.Element.all = R_Node.Element.all;
378
         end if;
379
 
380
         R_Node := R_Node.Next;
381
      end loop;
382
 
383
      return False;
384
   end Find_Equal_Key;
385
 
386
   -----------
387
   -- First --
388
   -----------
389
 
390
   function First (Container : Map) return Cursor is
391
      Node : constant Node_Access := HT_Ops.First (Container.HT);
392
 
393
   begin
394
      if Node = null then
395
         return No_Element;
396
      end if;
397
 
398
      return Cursor'(Container'Unchecked_Access, Node);
399
   end First;
400
 
401
   ----------
402
   -- Free --
403
   ----------
404
 
405
   procedure Free (X : in out Node_Access) is
406
      procedure Deallocate is
407
         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
408
   begin
409
      if X = null then
410
         return;
411
      end if;
412
 
413
      X.Next := X;  --  detect mischief (in Vet)
414
 
415
      begin
416
         Free_Key (X.Key);
417
      exception
418
         when others =>
419
            X.Key := null;
420
 
421
            begin
422
               Free_Element (X.Element);
423
            exception
424
               when others =>
425
                  X.Element := null;
426
            end;
427
 
428
            Deallocate (X);
429
            raise;
430
      end;
431
 
432
      begin
433
         Free_Element (X.Element);
434
      exception
435
         when others =>
436
            X.Element := null;
437
 
438
            Deallocate (X);
439
            raise;
440
      end;
441
 
442
      Deallocate (X);
443
   end Free;
444
 
445
   -----------------
446
   -- Has_Element --
447
   -----------------
448
 
449
   function Has_Element (Position : Cursor) return Boolean is
450
   begin
451
      pragma Assert (Vet (Position), "bad cursor in Has_Element");
452
      return Position.Node /= null;
453
   end Has_Element;
454
 
455
   ---------------
456
   -- Hash_Node --
457
   ---------------
458
 
459
   function Hash_Node (Node : Node_Access) return Hash_Type is
460
   begin
461
      return Hash (Node.Key.all);
462
   end Hash_Node;
463
 
464
   -------------
465
   -- Include --
466
   -------------
467
 
468
   procedure Include
469
     (Container : in out Map;
470
      Key       : Key_Type;
471
      New_Item  : Element_Type)
472
   is
473
      Position : Cursor;
474
      Inserted : Boolean;
475
 
476
      K : Key_Access;
477
      E : Element_Access;
478
 
479
   begin
480
      Insert (Container, Key, New_Item, Position, Inserted);
481
 
482
      if not Inserted then
483
         if Container.HT.Lock > 0 then
484
            raise Program_Error with
485
              "Include attempted to tamper with cursors (map is locked)";
486
         end if;
487
 
488
         K := Position.Node.Key;
489
         E := Position.Node.Element;
490
 
491
         Position.Node.Key := new Key_Type'(Key);
492
 
493
         begin
494
            Position.Node.Element := new Element_Type'(New_Item);
495
         exception
496
            when others =>
497
               Free_Key (K);
498
               raise;
499
         end;
500
 
501
         Free_Key (K);
502
         Free_Element (E);
503
      end if;
504
   end Include;
505
 
506
   ------------
507
   -- Insert --
508
   ------------
509
 
510
   procedure Insert
511
     (Container : in out Map;
512
      Key       : Key_Type;
513
      New_Item  : Element_Type;
514
      Position  : out Cursor;
515
      Inserted  : out Boolean)
516
   is
517
      function New_Node (Next : Node_Access) return Node_Access;
518
 
519
      procedure Local_Insert is
520
        new Key_Ops.Generic_Conditional_Insert (New_Node);
521
 
522
      --------------
523
      -- New_Node --
524
      --------------
525
 
526
      function New_Node (Next : Node_Access) return Node_Access is
527
         K  : Key_Access := new Key_Type'(Key);
528
         E  : Element_Access;
529
 
530
      begin
531
         E := new Element_Type'(New_Item);
532
         return new Node_Type'(K, E, Next);
533
      exception
534
         when others =>
535
            Free_Key (K);
536
            Free_Element (E);
537
            raise;
538
      end New_Node;
539
 
540
      HT : Hash_Table_Type renames Container.HT;
541
 
542
   --  Start of processing for Insert
543
 
544
   begin
545
      if HT_Ops.Capacity (HT) = 0 then
546
         HT_Ops.Reserve_Capacity (HT, 1);
547
      end if;
548
 
549
      Local_Insert (HT, Key, Position.Node, Inserted);
550
 
551
      if Inserted
552
        and then HT.Length > HT_Ops.Capacity (HT)
553
      then
554
         HT_Ops.Reserve_Capacity (HT, HT.Length);
555
      end if;
556
 
557
      Position.Container := Container'Unchecked_Access;
558
   end Insert;
559
 
560
   procedure Insert
561
     (Container : in out Map;
562
      Key       : Key_Type;
563
      New_Item  : Element_Type)
564
   is
565
      Position : Cursor;
566
      pragma Unreferenced (Position);
567
 
568
      Inserted : Boolean;
569
 
570
   begin
571
      Insert (Container, Key, New_Item, Position, Inserted);
572
 
573
      if not Inserted then
574
         raise Constraint_Error with
575
           "attempt to insert key already in map";
576
      end if;
577
   end Insert;
578
 
579
   --------------
580
   -- Is_Empty --
581
   --------------
582
 
583
   function Is_Empty (Container : Map) return Boolean is
584
   begin
585
      return Container.HT.Length = 0;
586
   end Is_Empty;
587
 
588
   -------------
589
   -- Iterate --
590
   -------------
591
 
592
   procedure Iterate
593
     (Container : Map;
594
      Process   : not null access procedure (Position : Cursor))
595
   is
596
      procedure Process_Node (Node : Node_Access);
597
      pragma Inline (Process_Node);
598
 
599
      procedure Local_Iterate is
600
         new HT_Ops.Generic_Iteration (Process_Node);
601
 
602
      ------------------
603
      -- Process_Node --
604
      ------------------
605
 
606
      procedure Process_Node (Node : Node_Access) is
607
      begin
608
         Process (Cursor'(Container'Unchecked_Access, Node));
609
      end Process_Node;
610
 
611
      B : Natural renames Container'Unrestricted_Access.HT.Busy;
612
 
613
   --  Start of processing Iterate
614
 
615
   begin
616
      B := B + 1;
617
 
618
      begin
619
         Local_Iterate (Container.HT);
620
      exception
621
         when others =>
622
            B := B - 1;
623
            raise;
624
      end;
625
 
626
      B := B - 1;
627
   end Iterate;
628
 
629
   ---------
630
   -- Key --
631
   ---------
632
 
633
   function Key (Position : Cursor) return Key_Type is
634
   begin
635
      if Position.Node = null then
636
         raise Constraint_Error with
637
           "Position cursor of function Key equals No_Element";
638
      end if;
639
 
640
      if Position.Node.Key = null then
641
         raise Program_Error with
642
           "Position cursor of function Key is bad";
643
      end if;
644
 
645
      pragma Assert (Vet (Position), "bad cursor in function Key");
646
 
647
      return Position.Node.Key.all;
648
   end Key;
649
 
650
   ------------
651
   -- Length --
652
   ------------
653
 
654
   function Length (Container : Map) return Count_Type is
655
   begin
656
      return Container.HT.Length;
657
   end Length;
658
 
659
   ----------
660
   -- Move --
661
   ----------
662
 
663
   procedure Move
664
     (Target : in out Map;
665
      Source : in out Map)
666
   is
667
   begin
668
      HT_Ops.Move (Target => Target.HT, Source => Source.HT);
669
   end Move;
670
 
671
   ----------
672
   -- Next --
673
   ----------
674
 
675
   function Next (Node : Node_Access) return Node_Access is
676
   begin
677
      return Node.Next;
678
   end Next;
679
 
680
   procedure Next (Position : in out Cursor) is
681
   begin
682
      Position := Next (Position);
683
   end Next;
684
 
685
   function Next (Position : Cursor) return Cursor is
686
   begin
687
      if Position.Node = null then
688
         return No_Element;
689
      end if;
690
 
691
      if Position.Node.Key = null
692
        or else Position.Node.Element = null
693
      then
694
         raise Program_Error with "Position cursor of Next is bad";
695
      end if;
696
 
697
      pragma Assert (Vet (Position), "Position cursor of Next is bad");
698
 
699
      declare
700
         HT   : Hash_Table_Type renames Position.Container.HT;
701
         Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
702
 
703
      begin
704
         if Node = null then
705
            return No_Element;
706
         end if;
707
 
708
         return Cursor'(Position.Container, Node);
709
      end;
710
   end Next;
711
 
712
   -------------------
713
   -- Query_Element --
714
   -------------------
715
 
716
   procedure Query_Element
717
     (Position : Cursor;
718
      Process  : not null access procedure (Key     : Key_Type;
719
                                            Element : Element_Type))
720
   is
721
   begin
722
      if Position.Node = null then
723
         raise Constraint_Error with
724
           "Position cursor of Query_Element equals No_Element";
725
      end if;
726
 
727
      if Position.Node.Key = null
728
        or else Position.Node.Element = null
729
      then
730
         raise Program_Error with
731
           "Position cursor of Query_Element is bad";
732
      end if;
733
 
734
      pragma Assert (Vet (Position), "bad cursor in Query_Element");
735
 
736
      declare
737
         M  : Map renames Position.Container.all;
738
         HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
739
 
740
         B : Natural renames HT.Busy;
741
         L : Natural renames HT.Lock;
742
 
743
      begin
744
         B := B + 1;
745
         L := L + 1;
746
 
747
         declare
748
            K : Key_Type renames Position.Node.Key.all;
749
            E : Element_Type renames Position.Node.Element.all;
750
 
751
         begin
752
            Process (K, E);
753
         exception
754
            when others =>
755
               L := L - 1;
756
               B := B - 1;
757
               raise;
758
         end;
759
 
760
         L := L - 1;
761
         B := B - 1;
762
      end;
763
   end Query_Element;
764
 
765
   ----------
766
   -- Read --
767
   ----------
768
 
769
   procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
770
 
771
   procedure Read
772
     (Stream    : not null access Root_Stream_Type'Class;
773
      Container : out Map)
774
   is
775
   begin
776
      Read_Nodes (Stream, Container.HT);
777
   end Read;
778
 
779
   procedure Read
780
     (Stream : not null access Root_Stream_Type'Class;
781
      Item   : out Cursor)
782
   is
783
   begin
784
      raise Program_Error with "attempt to stream map cursor";
785
   end Read;
786
 
787
   ---------------
788
   -- Read_Node --
789
   ---------------
790
 
791
   function Read_Node
792
     (Stream : not null access Root_Stream_Type'Class) return Node_Access
793
   is
794
      Node : Node_Access := new Node_Type;
795
 
796
   begin
797
      begin
798
         Node.Key := new Key_Type'(Key_Type'Input (Stream));
799
      exception
800
         when others =>
801
            Free (Node);
802
            raise;
803
      end;
804
 
805
      begin
806
         Node.Element := new Element_Type'(Element_Type'Input (Stream));
807
      exception
808
         when others =>
809
            Free_Key (Node.Key);
810
            Free (Node);
811
            raise;
812
      end;
813
 
814
      return Node;
815
   end Read_Node;
816
 
817
   -------------
818
   -- Replace --
819
   -------------
820
 
821
   procedure Replace
822
     (Container : in out Map;
823
      Key       : Key_Type;
824
      New_Item  : Element_Type)
825
   is
826
      Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
827
 
828
      K : Key_Access;
829
      E : Element_Access;
830
 
831
   begin
832
      if Node = null then
833
         raise Constraint_Error with
834
           "attempt to replace key not in map";
835
      end if;
836
 
837
      if Container.HT.Lock > 0 then
838
         raise Program_Error with
839
           "Replace attempted to tamper with cursors (map is locked)";
840
      end if;
841
 
842
      K := Node.Key;
843
      E := Node.Element;
844
 
845
      Node.Key := new Key_Type'(Key);
846
 
847
      begin
848
         Node.Element := new Element_Type'(New_Item);
849
      exception
850
         when others =>
851
            Free_Key (K);
852
            raise;
853
      end;
854
 
855
      Free_Key (K);
856
      Free_Element (E);
857
   end Replace;
858
 
859
   ---------------------
860
   -- Replace_Element --
861
   ---------------------
862
 
863
   procedure Replace_Element
864
     (Container : in out Map;
865
      Position  : Cursor;
866
      New_Item  : Element_Type)
867
   is
868
   begin
869
      if Position.Node = null then
870
         raise Constraint_Error with
871
           "Position cursor of Replace_Element equals No_Element";
872
      end if;
873
 
874
      if Position.Node.Key = null
875
        or else Position.Node.Element = null
876
      then
877
         raise Program_Error with
878
           "Position cursor of Replace_Element is bad";
879
      end if;
880
 
881
      if Position.Container /= Container'Unrestricted_Access then
882
         raise Program_Error with
883
           "Position cursor of Replace_Element designates wrong map";
884
      end if;
885
 
886
      if Position.Container.HT.Lock > 0 then
887
         raise Program_Error with
888
           "Replace_Element attempted to tamper with cursors (map is locked)";
889
      end if;
890
 
891
      pragma Assert (Vet (Position), "bad cursor in Replace_Element");
892
 
893
      declare
894
         X : Element_Access := Position.Node.Element;
895
 
896
      begin
897
         Position.Node.Element := new Element_Type'(New_Item);
898
         Free_Element (X);
899
      end;
900
   end Replace_Element;
901
 
902
   ----------------------
903
   -- Reserve_Capacity --
904
   ----------------------
905
 
906
   procedure Reserve_Capacity
907
     (Container : in out Map;
908
      Capacity  : Count_Type)
909
   is
910
   begin
911
      HT_Ops.Reserve_Capacity (Container.HT, Capacity);
912
   end Reserve_Capacity;
913
 
914
   --------------
915
   -- Set_Next --
916
   --------------
917
 
918
   procedure Set_Next (Node : Node_Access; Next : Node_Access) is
919
   begin
920
      Node.Next := Next;
921
   end Set_Next;
922
 
923
   --------------------
924
   -- Update_Element --
925
   --------------------
926
 
927
   procedure Update_Element
928
     (Container : in out Map;
929
      Position  : Cursor;
930
      Process   : not null access procedure (Key     : Key_Type;
931
                                             Element : in out Element_Type))
932
   is
933
   begin
934
      if Position.Node = null then
935
         raise Constraint_Error with
936
           "Position cursor of Update_Element equals No_Element";
937
      end if;
938
 
939
      if Position.Node.Key = null
940
        or else Position.Node.Element = null
941
      then
942
         raise Program_Error with
943
           "Position cursor of Update_Element is bad";
944
      end if;
945
 
946
      if Position.Container /= Container'Unrestricted_Access then
947
         raise Program_Error with
948
           "Position cursor of Update_Element designates wrong map";
949
      end if;
950
 
951
      pragma Assert (Vet (Position), "bad cursor in Update_Element");
952
 
953
      declare
954
         HT : Hash_Table_Type renames Container.HT;
955
 
956
         B : Natural renames HT.Busy;
957
         L : Natural renames HT.Lock;
958
 
959
      begin
960
         B := B + 1;
961
         L := L + 1;
962
 
963
         declare
964
            K : Key_Type renames Position.Node.Key.all;
965
            E : Element_Type renames Position.Node.Element.all;
966
 
967
         begin
968
            Process (K, E);
969
 
970
         exception
971
            when others =>
972
               L := L - 1;
973
               B := B - 1;
974
               raise;
975
         end;
976
 
977
         L := L - 1;
978
         B := B - 1;
979
      end;
980
   end Update_Element;
981
 
982
   ---------
983
   -- Vet --
984
   ---------
985
 
986
   function Vet (Position : Cursor) return Boolean is
987
   begin
988
      if Position.Node = null then
989
         return Position.Container = null;
990
      end if;
991
 
992
      if Position.Container = null then
993
         return False;
994
      end if;
995
 
996
      if Position.Node.Next = Position.Node then
997
         return False;
998
      end if;
999
 
1000
      if Position.Node.Key = null then
1001
         return False;
1002
      end if;
1003
 
1004
      if Position.Node.Element = null then
1005
         return False;
1006
      end if;
1007
 
1008
      declare
1009
         HT : Hash_Table_Type renames Position.Container.HT;
1010
         X  : Node_Access;
1011
 
1012
      begin
1013
         if HT.Length = 0 then
1014
            return False;
1015
         end if;
1016
 
1017
         if HT.Buckets = null
1018
           or else HT.Buckets'Length = 0
1019
         then
1020
            return False;
1021
         end if;
1022
 
1023
         X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all));
1024
 
1025
         for J in 1 .. HT.Length loop
1026
            if X = Position.Node then
1027
               return True;
1028
            end if;
1029
 
1030
            if X = null then
1031
               return False;
1032
            end if;
1033
 
1034
            if X = X.Next then -- to prevent endless loop
1035
               return False;
1036
            end if;
1037
 
1038
            X := X.Next;
1039
         end loop;
1040
 
1041
         return False;
1042
      end;
1043
   end Vet;
1044
 
1045
   -----------
1046
   -- Write --
1047
   -----------
1048
 
1049
   procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1050
 
1051
   procedure Write
1052
     (Stream    : not null access Root_Stream_Type'Class;
1053
      Container : Map)
1054
   is
1055
   begin
1056
      Write_Nodes (Stream, Container.HT);
1057
   end Write;
1058
 
1059
   procedure Write
1060
     (Stream : not null access Root_Stream_Type'Class;
1061
      Item   : Cursor)
1062
   is
1063
   begin
1064
      raise Program_Error with "attempt to stream map cursor";
1065
   end Write;
1066
 
1067
   ----------------
1068
   -- Write_Node --
1069
   ----------------
1070
 
1071
   procedure Write_Node
1072
     (Stream : not null access Root_Stream_Type'Class;
1073
      Node   : Node_Access)
1074
   is
1075
   begin
1076
      Key_Type'Output (Stream, Node.Key.all);
1077
      Element_Type'Output (Stream, Node.Element.all);
1078
   end Write_Node;
1079
 
1080
end Ada.Containers.Indefinite_Hashed_Maps;

powered by: WebSVN 2.1.0

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