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