Daily bump.
[official-gcc.git] / gcc / ada / a-cofove.adb
bloba12f8c243dff5c490517eff1ba628d082e7d397b
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2010-2013, 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 ------------------------------------------------------------------------------
28 with Ada.Containers.Generic_Array_Sort;
29 with System; use type System.Address;
31 package body Ada.Containers.Formal_Vectors is
33 type Int is range System.Min_Int .. System.Max_Int;
34 type UInt is mod System.Max_Binary_Modulus;
36 function Get_Element
37 (Container : Vector;
38 Position : Count_Type) return Element_Type;
40 procedure Insert_Space
41 (Container : in out Vector;
42 Before : Extended_Index;
43 Count : Count_Type := 1);
45 ---------
46 -- "&" --
47 ---------
49 function "&" (Left, Right : Vector) return Vector is
50 LN : constant Count_Type := Length (Left);
51 RN : constant Count_Type := Length (Right);
53 begin
54 if LN = 0 then
55 if RN = 0 then
56 return Empty_Vector;
57 end if;
59 declare
60 E : constant Elements_Array (1 .. Length (Right)) :=
61 Right.Elements (1 .. RN);
62 begin
63 return (Length (Right), E, Last => Right.Last, others => <>);
64 end;
65 end if;
67 if RN = 0 then
68 declare
69 E : constant Elements_Array (1 .. Length (Left)) :=
70 Left.Elements (1 .. LN);
71 begin
72 return (Length (Left), E, Last => Left.Last, others => <>);
73 end;
74 end if;
76 declare
77 N : constant Int'Base := Int (LN) + Int (RN);
78 Last_As_Int : Int'Base;
80 begin
81 if Int (No_Index) > Int'Last - N then
82 raise Constraint_Error with "new length is out of range";
83 end if;
85 Last_As_Int := Int (No_Index) + N;
87 if Last_As_Int > Int (Index_Type'Last) then
88 raise Constraint_Error with "new length is out of range";
89 end if;
91 -- TODO: should check whether length > max capacity (cnt_t'last) ???
93 declare
94 Last : constant Index_Type := Index_Type (Last_As_Int);
96 LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
97 RE : Elements_Array renames Right.Elements (1 .. RN);
99 Capacity : constant Count_Type := Length (Left) + Length (Right);
101 begin
102 return (Capacity, LE & RE, Last => Last, others => <>);
103 end;
104 end;
105 end "&";
107 function "&" (Left : Vector; Right : Element_Type) return Vector is
108 LN : constant Count_Type := Length (Left);
109 Last_As_Int : Int'Base;
111 begin
112 if LN = 0 then
113 return (1, (1 .. 1 => Right), Index_Type'First, others => <>);
114 end if;
116 if Int (Index_Type'First) > Int'Last - Int (LN) then
117 raise Constraint_Error with "new length is out of range";
118 end if;
120 Last_As_Int := Int (Index_Type'First) + Int (LN);
122 if Last_As_Int > Int (Index_Type'Last) then
123 raise Constraint_Error with "new length is out of range";
124 end if;
126 declare
127 Last : constant Index_Type := Index_Type (Last_As_Int);
128 LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
130 Capacity : constant Count_Type := Length (Left) + 1;
132 begin
133 return (Capacity, LE & Right, Last => Last, others => <>);
134 end;
135 end "&";
137 function "&" (Left : Element_Type; Right : Vector) return Vector is
138 RN : constant Count_Type := Length (Right);
139 Last_As_Int : Int'Base;
141 begin
142 if RN = 0 then
143 return (1, (1 .. 1 => Left),
144 Index_Type'First, others => <>);
145 end if;
147 if Int (Index_Type'First) > Int'Last - Int (RN) then
148 raise Constraint_Error with "new length is out of range";
149 end if;
151 Last_As_Int := Int (Index_Type'First) + Int (RN);
153 if Last_As_Int > Int (Index_Type'Last) then
154 raise Constraint_Error with "new length is out of range";
155 end if;
157 declare
158 Last : constant Index_Type := Index_Type (Last_As_Int);
159 RE : Elements_Array renames Right.Elements (1 .. RN);
160 Capacity : constant Count_Type := 1 + Length (Right);
161 begin
162 return (Capacity, Left & RE, Last => Last, others => <>);
163 end;
164 end "&";
166 function "&" (Left, Right : Element_Type) return Vector is
167 begin
168 if Index_Type'First >= Index_Type'Last then
169 raise Constraint_Error with "new length is out of range";
170 end if;
172 declare
173 Last : constant Index_Type := Index_Type'First + 1;
174 begin
175 return (2, (Left, Right), Last => Last, others => <>);
176 end;
177 end "&";
179 ---------
180 -- "=" --
181 ---------
183 function "=" (Left, Right : Vector) return Boolean is
184 begin
185 if Left'Address = Right'Address then
186 return True;
187 end if;
189 if Length (Left) /= Length (Right) then
190 return False;
191 end if;
193 for J in Count_Type range 1 .. Length (Left) loop
194 if Get_Element (Left, J) /= Get_Element (Right, J) then
195 return False;
196 end if;
197 end loop;
199 return True;
200 end "=";
202 ------------
203 -- Append --
204 ------------
206 procedure Append (Container : in out Vector; New_Item : Vector) is
207 begin
208 if Is_Empty (New_Item) then
209 return;
210 end if;
212 if Container.Last = Index_Type'Last then
213 raise Constraint_Error with "vector is already at its maximum length";
214 end if;
216 Insert (Container, Container.Last + 1, New_Item);
217 end Append;
219 procedure Append
220 (Container : in out Vector;
221 New_Item : Element_Type;
222 Count : Count_Type := 1)
224 begin
225 if Count = 0 then
226 return;
227 end if;
229 if Container.Last = Index_Type'Last then
230 raise Constraint_Error with "vector is already at its maximum length";
231 end if;
233 -- TODO: should check whether length > max capacity (cnt_t'last) ???
235 Insert (Container, Container.Last + 1, New_Item, Count);
236 end Append;
238 ------------
239 -- Assign --
240 ------------
242 procedure Assign (Target : in out Vector; Source : Vector) is
243 LS : constant Count_Type := Length (Source);
245 begin
246 if Target'Address = Source'Address then
247 return;
248 end if;
250 if Target.Capacity < LS then
251 raise Constraint_Error;
252 end if;
254 Clear (Target);
256 Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
257 Target.Last := Source.Last;
258 end Assign;
260 --------------
261 -- Capacity --
262 --------------
264 function Capacity (Container : Vector) return Count_Type is
265 begin
266 return Container.Elements'Length;
267 end Capacity;
269 -----------
270 -- Clear --
271 -----------
273 procedure Clear (Container : in out Vector) is
274 begin
275 Container.Last := No_Index;
276 end Clear;
278 --------------
279 -- Contains --
280 --------------
282 function Contains
283 (Container : Vector;
284 Item : Element_Type) return Boolean
286 begin
287 return Find_Index (Container, Item) /= No_Index;
288 end Contains;
290 ----------
291 -- Copy --
292 ----------
294 function Copy
295 (Source : Vector;
296 Capacity : Count_Type := 0) return Vector
298 LS : constant Count_Type := Length (Source);
299 C : Count_Type;
301 begin
302 if Capacity = 0 then
303 C := LS;
304 elsif Capacity >= LS and then Capacity in Capacity_Range then
305 C := Capacity;
306 else
307 raise Capacity_Error;
308 end if;
310 return Target : Vector (C) do
311 Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
312 Target.Last := Source.Last;
313 end return;
314 end Copy;
316 ---------------------
317 -- Current_To_Last --
318 ---------------------
320 function Current_To_Last
321 (Container : Vector;
322 Current : Cursor) return Vector
324 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
326 begin
327 if Current = No_Element then
328 Clear (C);
329 return C;
331 elsif not Has_Element (Container, Current) then
332 raise Constraint_Error;
334 else
335 while C.Last /= Container.Last - Current.Index + 1 loop
336 Delete_First (C);
337 end loop;
339 return C;
340 end if;
341 end Current_To_Last;
343 ------------
344 -- Delete --
345 ------------
347 procedure Delete
348 (Container : in out Vector;
349 Index : Extended_Index;
350 Count : Count_Type := 1)
352 begin
353 if Index < Index_Type'First then
354 raise Constraint_Error with "Index is out of range (too small)";
355 end if;
357 if Index > Container.Last then
358 if Index > Container.Last + 1 then
359 raise Constraint_Error with "Index is out of range (too large)";
360 end if;
362 return;
363 end if;
365 if Count = 0 then
366 return;
367 end if;
369 declare
370 I_As_Int : constant Int := Int (Index);
371 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
373 Count1 : constant Int'Base := Count_Type'Pos (Count);
374 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
375 N : constant Int'Base := Int'Min (Count1, Count2);
377 J_As_Int : constant Int'Base := I_As_Int + N;
379 begin
380 if J_As_Int > Old_Last_As_Int then
381 Container.Last := Index - 1;
383 else
384 declare
385 EA : Elements_Array renames Container.Elements;
387 II : constant Int'Base := I_As_Int - Int (No_Index);
388 I : constant Count_Type := Count_Type (II);
390 JJ : constant Int'Base := J_As_Int - Int (No_Index);
391 J : constant Count_Type := Count_Type (JJ);
393 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
394 New_Last : constant Index_Type :=
395 Index_Type (New_Last_As_Int);
397 KK : constant Int := New_Last_As_Int - Int (No_Index);
398 K : constant Count_Type := Count_Type (KK);
400 begin
401 EA (I .. K) := EA (J .. Length (Container));
402 Container.Last := New_Last;
403 end;
404 end if;
405 end;
406 end Delete;
408 procedure Delete
409 (Container : in out Vector;
410 Position : in out Cursor;
411 Count : Count_Type := 1)
413 begin
414 if not Position.Valid then
415 raise Constraint_Error with "Position cursor has no element";
416 end if;
418 if Position.Index > Container.Last then
419 raise Program_Error with "Position index is out of range";
420 end if;
422 Delete (Container, Position.Index, Count);
423 Position := No_Element;
424 end Delete;
426 ------------------
427 -- Delete_First --
428 ------------------
430 procedure Delete_First
431 (Container : in out Vector;
432 Count : Count_Type := 1)
434 begin
435 if Count = 0 then
436 return;
437 end if;
439 if Count >= Length (Container) then
440 Clear (Container);
441 return;
442 end if;
444 Delete (Container, Index_Type'First, Count);
445 end Delete_First;
447 -----------------
448 -- Delete_Last --
449 -----------------
451 procedure Delete_Last
452 (Container : in out Vector;
453 Count : Count_Type := 1)
455 Index : Int'Base;
457 begin
458 if Count = 0 then
459 return;
460 end if;
462 Index := Int'Base (Container.Last) - Int'Base (Count);
464 if Index < Index_Type'Pos (Index_Type'First) then
465 Container.Last := No_Index;
466 else
467 Container.Last := Index_Type (Index);
468 end if;
469 end Delete_Last;
471 -------------
472 -- Element --
473 -------------
475 function Element
476 (Container : Vector;
477 Index : Index_Type) return Element_Type
479 begin
480 if Index > Container.Last then
481 raise Constraint_Error with "Index is out of range";
482 end if;
484 declare
485 II : constant Int'Base := Int (Index) - Int (No_Index);
486 I : constant Count_Type := Count_Type (II);
487 begin
488 return Get_Element (Container, I);
489 end;
490 end Element;
492 function Element
493 (Container : Vector;
494 Position : Cursor) return Element_Type
496 Lst : constant Index_Type := Last_Index (Container);
498 begin
499 if not Position.Valid then
500 raise Constraint_Error with "Position cursor has no element";
501 end if;
503 if Position.Index > Lst then
504 raise Constraint_Error with "Position cursor is out of range";
505 end if;
507 declare
508 II : constant Int'Base := Int (Position.Index) - Int (No_Index);
509 I : constant Count_Type := Count_Type (II);
510 begin
511 return Get_Element (Container, I);
512 end;
513 end Element;
515 ----------
516 -- Find --
517 ----------
519 function Find
520 (Container : Vector;
521 Item : Element_Type;
522 Position : Cursor := No_Element) return Cursor
524 K : Count_Type;
525 Last : constant Index_Type := Last_Index (Container);
527 begin
528 if Position.Valid then
529 if Position.Index > Last_Index (Container) then
530 raise Program_Error with "Position index is out of range";
531 end if;
532 end if;
534 K := Count_Type (Int (Position.Index) - Int (No_Index));
536 for J in Position.Index .. Last loop
537 if Get_Element (Container, K) = Item then
538 return Cursor'(Index => J, others => <>);
539 end if;
541 K := K + 1;
542 end loop;
544 return No_Element;
545 end Find;
547 ----------------
548 -- Find_Index --
549 ----------------
551 function Find_Index
552 (Container : Vector;
553 Item : Element_Type;
554 Index : Index_Type := Index_Type'First) return Extended_Index
556 K : Count_Type;
557 Last : constant Index_Type := Last_Index (Container);
559 begin
560 K := Count_Type (Int (Index) - Int (No_Index));
561 for Indx in Index .. Last loop
562 if Get_Element (Container, K) = Item then
563 return Indx;
564 end if;
566 K := K + 1;
567 end loop;
569 return No_Index;
570 end Find_Index;
572 -----------
573 -- First --
574 -----------
576 function First (Container : Vector) return Cursor is
577 begin
578 if Is_Empty (Container) then
579 return No_Element;
580 end if;
582 return (True, Index_Type'First);
583 end First;
585 -------------------
586 -- First_Element --
587 -------------------
589 function First_Element (Container : Vector) return Element_Type is
590 begin
591 if Is_Empty (Container) then
592 raise Constraint_Error with "Container is empty";
593 end if;
595 return Get_Element (Container, 1);
596 end First_Element;
598 -----------------
599 -- First_Index --
600 -----------------
602 function First_Index (Container : Vector) return Index_Type is
603 pragma Unreferenced (Container);
604 begin
605 return Index_Type'First;
606 end First_Index;
608 -----------------------
609 -- First_To_Previous --
610 -----------------------
612 function First_To_Previous
613 (Container : Vector;
614 Current : Cursor) return Vector
616 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
618 begin
619 if Current = No_Element then
620 return C;
622 elsif not Has_Element (Container, Current) then
623 raise Constraint_Error;
625 else
626 while C.Last /= Current.Index - 1 loop
627 Delete_Last (C);
628 end loop;
630 return C;
631 end if;
632 end First_To_Previous;
634 ---------------------
635 -- Generic_Sorting --
636 ---------------------
638 package body Generic_Sorting is
640 ---------------
641 -- Is_Sorted --
642 ---------------
644 function Is_Sorted (Container : Vector) return Boolean is
645 Last : constant Index_Type := Last_Index (Container);
647 begin
648 if Container.Last <= Last then
649 return True;
650 end if;
652 declare
653 L : constant Count_Type := Length (Container);
654 begin
655 for J in Count_Type range 1 .. L - 1 loop
656 if Get_Element (Container, J + 1) <
657 Get_Element (Container, J)
658 then
659 return False;
660 end if;
661 end loop;
662 end;
664 return True;
665 end Is_Sorted;
667 -----------
668 -- Merge --
669 -----------
671 procedure Merge (Target, Source : in out Vector) is
672 begin
673 declare
674 TA : Elements_Array renames Target.Elements;
675 SA : Elements_Array renames Source.Elements;
677 I, J : Count_Type;
679 begin
680 -- ???
681 -- if Target.Last < Index_Type'First then
682 -- Move (Target => Target, Source => Source);
683 -- return;
684 -- end if;
686 if Target'Address = Source'Address then
687 return;
688 end if;
690 if Source.Last < Index_Type'First then
691 return;
692 end if;
694 -- I think we're missing this check in a-convec.adb... ???
696 I := Length (Target);
697 Set_Length (Target, I + Length (Source));
699 J := Length (Target);
700 while not Is_Empty (Source) loop
701 pragma Assert (Length (Source) <= 1
702 or else not (SA (Length (Source)) <
703 SA (Length (Source) - 1)));
705 if I = 0 then
706 TA (1 .. J) := SA (1 .. Length (Source));
707 Source.Last := No_Index;
708 return;
709 end if;
711 pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
713 if SA (Length (Source)) < TA (I) then
714 TA (J) := TA (I);
715 I := I - 1;
717 else
718 TA (J) := SA (Length (Source));
719 Source.Last := Source.Last - 1;
720 end if;
722 J := J - 1;
723 end loop;
724 end;
725 end Merge;
727 ----------
728 -- Sort --
729 ----------
731 procedure Sort (Container : in out Vector)
733 procedure Sort is
734 new Generic_Array_Sort
735 (Index_Type => Count_Type,
736 Element_Type => Element_Type,
737 Array_Type => Elements_Array,
738 "<" => "<");
740 begin
741 if Container.Last <= Index_Type'First then
742 return;
743 end if;
745 Sort (Container.Elements (1 .. Length (Container)));
746 end Sort;
748 end Generic_Sorting;
750 -----------------
751 -- Get_Element --
752 -----------------
754 function Get_Element
755 (Container : Vector;
756 Position : Count_Type) return Element_Type
758 begin
759 return Container.Elements (Position);
760 end Get_Element;
762 -----------------
763 -- Has_Element --
764 -----------------
766 function Has_Element
767 (Container : Vector;
768 Position : Cursor) return Boolean
770 begin
771 if not Position.Valid then
772 return False;
773 else
774 return Position.Index <= Last_Index (Container);
775 end if;
776 end Has_Element;
778 ------------
779 -- Insert --
780 ------------
782 procedure Insert
783 (Container : in out Vector;
784 Before : Extended_Index;
785 New_Item : Element_Type;
786 Count : Count_Type := 1)
788 N : constant Int := Count_Type'Pos (Count);
790 First : constant Int := Int (Index_Type'First);
791 New_Last_As_Int : Int'Base;
792 New_Last : Index_Type;
793 New_Length : UInt;
794 Max_Length : constant UInt := UInt (Container.Capacity);
796 begin
797 if Before < Index_Type'First then
798 raise Constraint_Error with
799 "Before index is out of range (too small)";
800 end if;
802 if Before > Container.Last
803 and then Before > Container.Last + 1
804 then
805 raise Constraint_Error with
806 "Before index is out of range (too large)";
807 end if;
809 if Count = 0 then
810 return;
811 end if;
813 declare
814 Old_Last_As_Int : constant Int := Int (Container.Last);
816 begin
817 if Old_Last_As_Int > Int'Last - N then
818 raise Constraint_Error with "new length is out of range";
819 end if;
821 New_Last_As_Int := Old_Last_As_Int + N;
823 if New_Last_As_Int > Int (Index_Type'Last) then
824 raise Constraint_Error with "new length is out of range";
825 end if;
827 New_Length := UInt (New_Last_As_Int - First + Int'(1));
829 if New_Length > Max_Length then
830 raise Constraint_Error with "new length is out of range";
831 end if;
833 New_Last := Index_Type (New_Last_As_Int);
835 -- Resolve issue of capacity vs. max index ???
836 end;
838 declare
839 EA : Elements_Array renames Container.Elements;
841 BB : constant Int'Base := Int (Before) - Int (No_Index);
842 B : constant Count_Type := Count_Type (BB);
844 LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
845 L : constant Count_Type := Count_Type (LL);
847 begin
848 if Before <= Container.Last then
849 declare
850 II : constant Int'Base := BB + N;
851 I : constant Count_Type := Count_Type (II);
852 begin
853 EA (I .. L) := EA (B .. Length (Container));
854 EA (B .. I - 1) := (others => New_Item);
855 end;
857 else
858 EA (B .. L) := (others => New_Item);
859 end if;
860 end;
862 Container.Last := New_Last;
863 end Insert;
865 procedure Insert
866 (Container : in out Vector;
867 Before : Extended_Index;
868 New_Item : Vector)
870 N : constant Count_Type := Length (New_Item);
872 begin
873 if Before < Index_Type'First then
874 raise Constraint_Error with
875 "Before index is out of range (too small)";
876 end if;
878 if Before > Container.Last
879 and then Before > Container.Last + 1
880 then
881 raise Constraint_Error with
882 "Before index is out of range (too large)";
883 end if;
885 if N = 0 then
886 return;
887 end if;
889 Insert_Space (Container, Before, Count => N);
891 declare
892 Dst_Last_As_Int : constant Int'Base :=
893 Int (Before) + Int (N) - 1 - Int (No_Index);
895 Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
897 BB : constant Int'Base := Int (Before) - Int (No_Index);
898 B : constant Count_Type := Count_Type (BB);
900 begin
901 if Container'Address /= New_Item'Address then
902 Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
903 return;
904 end if;
906 declare
907 Src : Elements_Array renames Container.Elements (1 .. B - 1);
909 Index_As_Int : constant Int'Base := BB + Src'Length - 1;
911 Index : constant Count_Type := Count_Type (Index_As_Int);
913 Dst : Elements_Array renames Container.Elements (B .. Index);
915 begin
916 Dst := Src;
917 end;
919 if Dst_Last = Length (Container) then
920 return;
921 end if;
923 declare
924 Src : Elements_Array renames
925 Container.Elements (Dst_Last + 1 .. Length (Container));
927 Index_As_Int : constant Int'Base :=
928 Dst_Last_As_Int - Src'Length + 1;
930 Index : constant Count_Type := Count_Type (Index_As_Int);
932 Dst : Elements_Array renames
933 Container.Elements (Index .. Dst_Last);
935 begin
936 Dst := Src;
937 end;
938 end;
939 end Insert;
941 procedure Insert
942 (Container : in out Vector;
943 Before : Cursor;
944 New_Item : Vector)
946 Index : Index_Type'Base;
948 begin
949 if Is_Empty (New_Item) then
950 return;
951 end if;
953 if not Before.Valid
954 or else Before.Index > Container.Last
955 then
956 if Container.Last = Index_Type'Last then
957 raise Constraint_Error with
958 "vector is already at its maximum length";
959 end if;
961 Index := Container.Last + 1;
963 else
964 Index := Before.Index;
965 end if;
967 Insert (Container, Index, New_Item);
968 end Insert;
970 procedure Insert
971 (Container : in out Vector;
972 Before : Cursor;
973 New_Item : Vector;
974 Position : out Cursor)
976 Index : Index_Type'Base;
978 begin
979 if Is_Empty (New_Item) then
980 if not Before.Valid
981 or else Before.Index > Container.Last
982 then
983 Position := No_Element;
984 else
985 Position := (True, Before.Index);
986 end if;
988 return;
989 end if;
991 if not Before.Valid
992 or else Before.Index > Container.Last
993 then
994 if Container.Last = Index_Type'Last then
995 raise Constraint_Error with
996 "vector is already at its maximum length";
997 end if;
999 Index := Container.Last + 1;
1001 else
1002 Index := Before.Index;
1003 end if;
1005 Insert (Container, Index, New_Item);
1007 Position := Cursor'(True, Index);
1008 end Insert;
1010 procedure Insert
1011 (Container : in out Vector;
1012 Before : Cursor;
1013 New_Item : Element_Type;
1014 Count : Count_Type := 1)
1016 Index : Index_Type'Base;
1018 begin
1019 if Count = 0 then
1020 return;
1021 end if;
1023 if not Before.Valid
1024 or else Before.Index > Container.Last
1025 then
1026 if Container.Last = Index_Type'Last then
1027 raise Constraint_Error with
1028 "vector is already at its maximum length";
1029 end if;
1031 Index := Container.Last + 1;
1033 else
1034 Index := Before.Index;
1035 end if;
1037 Insert (Container, Index, New_Item, Count);
1038 end Insert;
1040 procedure Insert
1041 (Container : in out Vector;
1042 Before : Cursor;
1043 New_Item : Element_Type;
1044 Position : out Cursor;
1045 Count : Count_Type := 1)
1047 Index : Index_Type'Base;
1049 begin
1050 if Count = 0 then
1051 if not Before.Valid
1052 or else Before.Index > Container.Last
1053 then
1054 Position := No_Element;
1055 else
1056 Position := (True, Before.Index);
1057 end if;
1059 return;
1060 end if;
1062 if not Before.Valid
1063 or else Before.Index > Container.Last
1064 then
1065 if Container.Last = Index_Type'Last then
1066 raise Constraint_Error with
1067 "vector is already at its maximum length";
1068 end if;
1070 Index := Container.Last + 1;
1072 else
1073 Index := Before.Index;
1074 end if;
1076 Insert (Container, Index, New_Item, Count);
1078 Position := Cursor'(True, Index);
1079 end Insert;
1081 ------------------
1082 -- Insert_Space --
1083 ------------------
1085 procedure Insert_Space
1086 (Container : in out Vector;
1087 Before : Extended_Index;
1088 Count : Count_Type := 1)
1090 N : constant Int := Count_Type'Pos (Count);
1092 First : constant Int := Int (Index_Type'First);
1093 New_Last_As_Int : Int'Base;
1094 New_Last : Index_Type;
1095 New_Length : UInt;
1096 Max_Length : constant UInt := UInt (Count_Type'Last);
1098 begin
1099 if Before < Index_Type'First then
1100 raise Constraint_Error with
1101 "Before index is out of range (too small)";
1102 end if;
1104 if Before > Container.Last
1105 and then Before > Container.Last + 1
1106 then
1107 raise Constraint_Error with
1108 "Before index is out of range (too large)";
1109 end if;
1111 if Count = 0 then
1112 return;
1113 end if;
1115 declare
1116 Old_Last_As_Int : constant Int := Int (Container.Last);
1118 begin
1119 if Old_Last_As_Int > Int'Last - N then
1120 raise Constraint_Error with "new length is out of range";
1121 end if;
1123 New_Last_As_Int := Old_Last_As_Int + N;
1125 if New_Last_As_Int > Int (Index_Type'Last) then
1126 raise Constraint_Error with "new length is out of range";
1127 end if;
1129 New_Length := UInt (New_Last_As_Int - First + Int'(1));
1131 if New_Length > Max_Length then
1132 raise Constraint_Error with "new length is out of range";
1133 end if;
1135 New_Last := Index_Type (New_Last_As_Int);
1137 -- Resolve issue of capacity vs. max index ???
1138 end;
1140 declare
1141 EA : Elements_Array renames Container.Elements;
1143 BB : constant Int'Base := Int (Before) - Int (No_Index);
1144 B : constant Count_Type := Count_Type (BB);
1146 LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
1147 L : constant Count_Type := Count_Type (LL);
1149 begin
1150 if Before <= Container.Last then
1151 declare
1152 II : constant Int'Base := BB + N;
1153 I : constant Count_Type := Count_Type (II);
1154 begin
1155 EA (I .. L) := EA (B .. Length (Container));
1156 end;
1157 end if;
1158 end;
1160 Container.Last := New_Last;
1161 end Insert_Space;
1163 --------------
1164 -- Is_Empty --
1165 --------------
1167 function Is_Empty (Container : Vector) return Boolean is
1168 begin
1169 return Last_Index (Container) < Index_Type'First;
1170 end Is_Empty;
1172 ----------
1173 -- Last --
1174 ----------
1176 function Last (Container : Vector) return Cursor is
1177 begin
1178 if Is_Empty (Container) then
1179 return No_Element;
1180 end if;
1182 return (True, Last_Index (Container));
1183 end Last;
1185 ------------------
1186 -- Last_Element --
1187 ------------------
1189 function Last_Element (Container : Vector) return Element_Type is
1190 begin
1191 if Is_Empty (Container) then
1192 raise Constraint_Error with "Container is empty";
1193 end if;
1195 return Get_Element (Container, Length (Container));
1196 end Last_Element;
1198 ----------------
1199 -- Last_Index --
1200 ----------------
1202 function Last_Index (Container : Vector) return Extended_Index is
1203 begin
1204 return Container.Last;
1205 end Last_Index;
1207 ------------
1208 -- Length --
1209 ------------
1211 function Length (Container : Vector) return Count_Type is
1212 L : constant Int := Int (Last_Index (Container));
1213 F : constant Int := Int (Index_Type'First);
1214 N : constant Int'Base := L - F + 1;
1216 begin
1217 return Count_Type (N);
1218 end Length;
1220 ----------
1221 -- Move --
1222 ----------
1224 procedure Move
1225 (Target : in out Vector;
1226 Source : in out Vector)
1228 N : constant Count_Type := Length (Source);
1230 begin
1231 if Target'Address = Source'Address then
1232 return;
1233 end if;
1235 if N > Target.Capacity then
1236 raise Constraint_Error with -- correct exception here???
1237 "length of Source is greater than capacity of Target";
1238 end if;
1240 -- We could also write this as a loop, and incrementally
1241 -- copy elements from source to target.
1243 Target.Last := No_Index; -- in case array assignment files
1244 Target.Elements (1 .. N) := Source.Elements (1 .. N);
1246 Target.Last := Source.Last;
1247 Source.Last := No_Index;
1248 end Move;
1250 ----------
1251 -- Next --
1252 ----------
1254 function Next (Container : Vector; Position : Cursor) return Cursor is
1255 begin
1256 if not Position.Valid then
1257 return No_Element;
1258 end if;
1260 if Position.Index < Last_Index (Container) then
1261 return (True, Position.Index + 1);
1262 end if;
1264 return No_Element;
1265 end Next;
1267 ----------
1268 -- Next --
1269 ----------
1271 procedure Next (Container : Vector; Position : in out Cursor) is
1272 begin
1273 if not Position.Valid then
1274 return;
1275 end if;
1277 if Position.Index < Last_Index (Container) then
1278 Position.Index := Position.Index + 1;
1279 else
1280 Position := No_Element;
1281 end if;
1282 end Next;
1284 -------------
1285 -- Prepend --
1286 -------------
1288 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1289 begin
1290 Insert (Container, Index_Type'First, New_Item);
1291 end Prepend;
1293 procedure Prepend
1294 (Container : in out Vector;
1295 New_Item : Element_Type;
1296 Count : Count_Type := 1)
1298 begin
1299 Insert (Container,
1300 Index_Type'First,
1301 New_Item,
1302 Count);
1303 end Prepend;
1305 --------------
1306 -- Previous --
1307 --------------
1309 procedure Previous (Container : Vector; Position : in out Cursor) is
1310 begin
1311 if not Position.Valid then
1312 return;
1313 end if;
1315 if Position.Index > Index_Type'First
1316 and then Position.Index <= Last_Index (Container)
1317 then
1318 Position.Index := Position.Index - 1;
1319 else
1320 Position := No_Element;
1321 end if;
1322 end Previous;
1324 function Previous (Container : Vector; Position : Cursor) return Cursor is
1325 begin
1326 if not Position.Valid then
1327 return No_Element;
1328 end if;
1330 if Position.Index > Index_Type'First
1331 and then Position.Index <= Last_Index (Container)
1332 then
1333 return (True, Position.Index - 1);
1334 end if;
1336 return No_Element;
1337 end Previous;
1339 ---------------------
1340 -- Replace_Element --
1341 ---------------------
1343 procedure Replace_Element
1344 (Container : in out Vector;
1345 Index : Index_Type;
1346 New_Item : Element_Type)
1348 begin
1349 if Index > Container.Last then
1350 raise Constraint_Error with "Index is out of range";
1351 end if;
1353 declare
1354 II : constant Int'Base := Int (Index) - Int (No_Index);
1355 I : constant Count_Type := Count_Type (II);
1357 begin
1358 Container.Elements (I) := New_Item;
1359 end;
1360 end Replace_Element;
1362 procedure Replace_Element
1363 (Container : in out Vector;
1364 Position : Cursor;
1365 New_Item : Element_Type)
1367 begin
1368 if not Position.Valid then
1369 raise Constraint_Error with "Position cursor has no element";
1370 end if;
1372 if Position.Index > Container.Last then
1373 raise Constraint_Error with "Position cursor is out of range";
1374 end if;
1376 declare
1377 II : constant Int'Base := Int (Position.Index) - Int (No_Index);
1378 I : constant Count_Type := Count_Type (II);
1379 begin
1380 Container.Elements (I) := New_Item;
1381 end;
1382 end Replace_Element;
1384 ----------------------
1385 -- Reserve_Capacity --
1386 ----------------------
1388 procedure Reserve_Capacity
1389 (Container : in out Vector;
1390 Capacity : Count_Type)
1392 begin
1393 if Capacity > Container.Capacity then
1394 raise Constraint_Error with "Capacity is out of range";
1395 end if;
1396 end Reserve_Capacity;
1398 ----------------------
1399 -- Reverse_Elements --
1400 ----------------------
1402 procedure Reverse_Elements (Container : in out Vector) is
1403 begin
1404 if Length (Container) <= 1 then
1405 return;
1406 end if;
1408 declare
1409 I, J : Count_Type;
1410 E : Elements_Array renames Container.Elements;
1412 begin
1413 I := 1;
1414 J := Length (Container);
1415 while I < J loop
1416 declare
1417 EI : constant Element_Type := E (I);
1418 begin
1419 E (I) := E (J);
1420 E (J) := EI;
1421 end;
1423 I := I + 1;
1424 J := J - 1;
1425 end loop;
1426 end;
1427 end Reverse_Elements;
1429 ------------------
1430 -- Reverse_Find --
1431 ------------------
1433 function Reverse_Find
1434 (Container : Vector;
1435 Item : Element_Type;
1436 Position : Cursor := No_Element) return Cursor
1438 Last : Index_Type'Base;
1439 K : Count_Type;
1441 begin
1442 if not Position.Valid
1443 or else Position.Index > Last_Index (Container)
1444 then
1445 Last := Last_Index (Container);
1446 else
1447 Last := Position.Index;
1448 end if;
1450 K := Count_Type (Int (Last) - Int (No_Index));
1451 for Indx in reverse Index_Type'First .. Last loop
1452 if Get_Element (Container, K) = Item then
1453 return (True, Indx);
1454 end if;
1456 K := K - 1;
1457 end loop;
1459 return No_Element;
1460 end Reverse_Find;
1462 ------------------------
1463 -- Reverse_Find_Index --
1464 ------------------------
1466 function Reverse_Find_Index
1467 (Container : Vector;
1468 Item : Element_Type;
1469 Index : Index_Type := Index_Type'Last) return Extended_Index
1471 Last : Index_Type'Base;
1472 K : Count_Type;
1474 begin
1475 if Index > Last_Index (Container) then
1476 Last := Last_Index (Container);
1477 else
1478 Last := Index;
1479 end if;
1481 K := Count_Type (Int (Last) - Int (No_Index));
1482 for Indx in reverse Index_Type'First .. Last loop
1483 if Get_Element (Container, K) = Item then
1484 return Indx;
1485 end if;
1487 K := K - 1;
1488 end loop;
1490 return No_Index;
1491 end Reverse_Find_Index;
1493 ----------------
1494 -- Set_Length --
1495 ----------------
1497 procedure Set_Length
1498 (Container : in out Vector;
1499 New_Length : Count_Type)
1501 begin
1502 if New_Length = Formal_Vectors.Length (Container) then
1503 return;
1504 end if;
1506 if New_Length > Container.Capacity then
1507 raise Constraint_Error; -- ???
1508 end if;
1510 declare
1511 Last_As_Int : constant Int'Base :=
1512 Int (Index_Type'First) + Int (New_Length) - 1;
1513 begin
1514 Container.Last := Index_Type'Base (Last_As_Int);
1515 end;
1516 end Set_Length;
1518 ------------------
1519 -- Strict_Equal --
1520 ------------------
1522 function Strict_Equal (Left, Right : Vector) return Boolean is
1523 begin
1524 -- On bounded vectors, cursors are indexes. As a consequence, two
1525 -- vectors always have the same cursor at the same position and
1526 -- Strict_Equal is simply =
1528 return Left = Right;
1529 end Strict_Equal;
1531 ----------
1532 -- Swap --
1533 ----------
1535 procedure Swap (Container : in out Vector; I, J : Index_Type) is
1536 begin
1537 if I > Container.Last then
1538 raise Constraint_Error with "I index is out of range";
1539 end if;
1541 if J > Container.Last then
1542 raise Constraint_Error with "J index is out of range";
1543 end if;
1545 if I = J then
1546 return;
1547 end if;
1549 declare
1550 II : constant Int'Base := Int (I) - Int (No_Index);
1551 JJ : constant Int'Base := Int (J) - Int (No_Index);
1553 EI : Element_Type renames Container.Elements (Count_Type (II));
1554 EJ : Element_Type renames Container.Elements (Count_Type (JJ));
1556 EI_Copy : constant Element_Type := EI;
1558 begin
1559 EI := EJ;
1560 EJ := EI_Copy;
1561 end;
1562 end Swap;
1564 procedure Swap (Container : in out Vector; I, J : Cursor) is
1565 begin
1566 if not I.Valid then
1567 raise Constraint_Error with "I cursor has no element";
1568 end if;
1570 if not J.Valid then
1571 raise Constraint_Error with "J cursor has no element";
1572 end if;
1574 Swap (Container, I.Index, J.Index);
1575 end Swap;
1577 ---------------
1578 -- To_Cursor --
1579 ---------------
1581 function To_Cursor
1582 (Container : Vector;
1583 Index : Extended_Index) return Cursor
1585 begin
1586 if Index not in Index_Type'First .. Last_Index (Container) then
1587 return No_Element;
1588 end if;
1590 return Cursor'(True, Index);
1591 end To_Cursor;
1593 --------------
1594 -- To_Index --
1595 --------------
1597 function To_Index (Position : Cursor) return Extended_Index is
1598 begin
1599 if not Position.Valid then
1600 return No_Index;
1601 end if;
1603 return Position.Index;
1604 end To_Index;
1606 ---------------
1607 -- To_Vector --
1608 ---------------
1610 function To_Vector
1611 (New_Item : Element_Type;
1612 Length : Count_Type) return Vector
1614 begin
1615 if Length = 0 then
1616 return Empty_Vector;
1617 end if;
1619 declare
1620 First : constant Int := Int (Index_Type'First);
1621 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1622 Last : Index_Type;
1624 begin
1625 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1626 raise Constraint_Error with "Length is out of range"; -- ???
1627 end if;
1629 Last := Index_Type (Last_As_Int);
1631 return (Length, (others => New_Item), Last => Last,
1632 others => <>);
1633 end;
1634 end To_Vector;
1636 end Ada.Containers.Formal_Vectors;