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

Subversion Repositories openrisc

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

powered by: WebSVN 2.1.0

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