PR target/58115
[official-gcc.git] / gcc / ada / a-cofove.adb
blob240715dca75249e98333f94616075b81ef6810fb
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 then
305 C := Capacity;
306 else
307 raise Constraint_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 -- Delete --
318 ------------
320 procedure Delete
321 (Container : in out Vector;
322 Index : Extended_Index;
323 Count : Count_Type := 1)
325 begin
326 if Index < Index_Type'First then
327 raise Constraint_Error with "Index is out of range (too small)";
328 end if;
330 if Index > Container.Last then
331 if Index > Container.Last + 1 then
332 raise Constraint_Error with "Index is out of range (too large)";
333 end if;
335 return;
336 end if;
338 if Count = 0 then
339 return;
340 end if;
342 declare
343 I_As_Int : constant Int := Int (Index);
344 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
346 Count1 : constant Int'Base := Count_Type'Pos (Count);
347 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
348 N : constant Int'Base := Int'Min (Count1, Count2);
350 J_As_Int : constant Int'Base := I_As_Int + N;
352 begin
353 if J_As_Int > Old_Last_As_Int then
354 Container.Last := Index - 1;
356 else
357 declare
358 EA : Elements_Array renames Container.Elements;
360 II : constant Int'Base := I_As_Int - Int (No_Index);
361 I : constant Count_Type := Count_Type (II);
363 JJ : constant Int'Base := J_As_Int - Int (No_Index);
364 J : constant Count_Type := Count_Type (JJ);
366 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
367 New_Last : constant Index_Type :=
368 Index_Type (New_Last_As_Int);
370 KK : constant Int := New_Last_As_Int - Int (No_Index);
371 K : constant Count_Type := Count_Type (KK);
373 begin
374 EA (I .. K) := EA (J .. Length (Container));
375 Container.Last := New_Last;
376 end;
377 end if;
378 end;
379 end Delete;
381 procedure Delete
382 (Container : in out Vector;
383 Position : in out Cursor;
384 Count : Count_Type := 1)
386 begin
387 if not Position.Valid then
388 raise Constraint_Error with "Position cursor has no element";
389 end if;
391 if Position.Index > Container.Last then
392 raise Program_Error with "Position index is out of range";
393 end if;
395 Delete (Container, Position.Index, Count);
396 Position := No_Element;
397 end Delete;
399 ------------------
400 -- Delete_First --
401 ------------------
403 procedure Delete_First
404 (Container : in out Vector;
405 Count : Count_Type := 1)
407 begin
408 if Count = 0 then
409 return;
410 end if;
412 if Count >= Length (Container) then
413 Clear (Container);
414 return;
415 end if;
417 Delete (Container, Index_Type'First, Count);
418 end Delete_First;
420 -----------------
421 -- Delete_Last --
422 -----------------
424 procedure Delete_Last
425 (Container : in out Vector;
426 Count : Count_Type := 1)
428 Index : Int'Base;
430 begin
431 if Count = 0 then
432 return;
433 end if;
435 Index := Int'Base (Container.Last) - Int'Base (Count);
437 if Index < Index_Type'Pos (Index_Type'First) then
438 Container.Last := No_Index;
439 else
440 Container.Last := Index_Type (Index);
441 end if;
442 end Delete_Last;
444 -------------
445 -- Element --
446 -------------
448 function Element
449 (Container : Vector;
450 Index : Index_Type) return Element_Type
452 begin
453 if Index > Container.Last then
454 raise Constraint_Error with "Index is out of range";
455 end if;
457 declare
458 II : constant Int'Base := Int (Index) - Int (No_Index);
459 I : constant Count_Type := Count_Type (II);
460 begin
461 return Get_Element (Container, I);
462 end;
463 end Element;
465 function Element
466 (Container : Vector;
467 Position : Cursor) return Element_Type
469 Lst : constant Index_Type := Last_Index (Container);
471 begin
472 if not Position.Valid then
473 raise Constraint_Error with "Position cursor has no element";
474 end if;
476 if Position.Index > Lst then
477 raise Constraint_Error with "Position cursor is out of range";
478 end if;
480 declare
481 II : constant Int'Base := Int (Position.Index) - Int (No_Index);
482 I : constant Count_Type := Count_Type (II);
483 begin
484 return Get_Element (Container, I);
485 end;
486 end Element;
488 ----------
489 -- Find --
490 ----------
492 function Find
493 (Container : Vector;
494 Item : Element_Type;
495 Position : Cursor := No_Element) return Cursor
497 K : Count_Type;
498 Last : constant Index_Type := Last_Index (Container);
500 begin
501 if Position.Valid then
502 if Position.Index > Last_Index (Container) then
503 raise Program_Error with "Position index is out of range";
504 end if;
505 end if;
507 K := Count_Type (Int (Position.Index) - Int (No_Index));
509 for J in Position.Index .. Last loop
510 if Get_Element (Container, K) = Item then
511 return Cursor'(Index => J, others => <>);
512 end if;
514 K := K + 1;
515 end loop;
517 return No_Element;
518 end Find;
520 ----------------
521 -- Find_Index --
522 ----------------
524 function Find_Index
525 (Container : Vector;
526 Item : Element_Type;
527 Index : Index_Type := Index_Type'First) return Extended_Index
529 K : Count_Type;
530 Last : constant Index_Type := Last_Index (Container);
532 begin
533 K := Count_Type (Int (Index) - Int (No_Index));
534 for Indx in Index .. Last loop
535 if Get_Element (Container, K) = Item then
536 return Indx;
537 end if;
539 K := K + 1;
540 end loop;
542 return No_Index;
543 end Find_Index;
545 -----------
546 -- First --
547 -----------
549 function First (Container : Vector) return Cursor is
550 begin
551 if Is_Empty (Container) then
552 return No_Element;
553 end if;
555 return (True, Index_Type'First);
556 end First;
558 -------------------
559 -- First_Element --
560 -------------------
562 function First_Element (Container : Vector) return Element_Type is
563 begin
564 if Is_Empty (Container) then
565 raise Constraint_Error with "Container is empty";
566 end if;
568 return Get_Element (Container, 1);
569 end First_Element;
571 -----------------
572 -- First_Index --
573 -----------------
575 function First_Index (Container : Vector) return Index_Type is
576 pragma Unreferenced (Container);
577 begin
578 return Index_Type'First;
579 end First_Index;
581 ---------------------
582 -- Generic_Sorting --
583 ---------------------
585 package body Generic_Sorting is
587 ---------------
588 -- Is_Sorted --
589 ---------------
591 function Is_Sorted (Container : Vector) return Boolean is
592 Last : constant Index_Type := Last_Index (Container);
594 begin
595 if Container.Last <= Last then
596 return True;
597 end if;
599 declare
600 L : constant Count_Type := Length (Container);
601 begin
602 for J in Count_Type range 1 .. L - 1 loop
603 if Get_Element (Container, J + 1) <
604 Get_Element (Container, J)
605 then
606 return False;
607 end if;
608 end loop;
609 end;
611 return True;
612 end Is_Sorted;
614 -----------
615 -- Merge --
616 -----------
618 procedure Merge (Target, Source : in out Vector) is
619 begin
620 declare
621 TA : Elements_Array renames Target.Elements;
622 SA : Elements_Array renames Source.Elements;
624 I, J : Count_Type;
626 begin
627 -- ???
628 -- if Target.Last < Index_Type'First then
629 -- Move (Target => Target, Source => Source);
630 -- return;
631 -- end if;
633 if Target'Address = Source'Address then
634 return;
635 end if;
637 if Source.Last < Index_Type'First then
638 return;
639 end if;
641 -- I think we're missing this check in a-convec.adb... ???
643 I := Length (Target);
644 Set_Length (Target, I + Length (Source));
646 J := Length (Target);
647 while not Is_Empty (Source) loop
648 pragma Assert (Length (Source) <= 1
649 or else not (SA (Length (Source)) <
650 SA (Length (Source) - 1)));
652 if I = 0 then
653 TA (1 .. J) := SA (1 .. Length (Source));
654 Source.Last := No_Index;
655 return;
656 end if;
658 pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
660 if SA (Length (Source)) < TA (I) then
661 TA (J) := TA (I);
662 I := I - 1;
664 else
665 TA (J) := SA (Length (Source));
666 Source.Last := Source.Last - 1;
667 end if;
669 J := J - 1;
670 end loop;
671 end;
672 end Merge;
674 ----------
675 -- Sort --
676 ----------
678 procedure Sort (Container : in out Vector)
680 procedure Sort is
681 new Generic_Array_Sort
682 (Index_Type => Count_Type,
683 Element_Type => Element_Type,
684 Array_Type => Elements_Array,
685 "<" => "<");
687 begin
688 if Container.Last <= Index_Type'First then
689 return;
690 end if;
692 Sort (Container.Elements (1 .. Length (Container)));
693 end Sort;
695 end Generic_Sorting;
697 -----------------
698 -- Get_Element --
699 -----------------
701 function Get_Element
702 (Container : Vector;
703 Position : Count_Type) return Element_Type
705 begin
706 return Container.Elements (Position);
707 end Get_Element;
709 -----------------
710 -- Has_Element --
711 -----------------
713 function Has_Element
714 (Container : Vector;
715 Position : Cursor) return Boolean
717 begin
718 if not Position.Valid then
719 return False;
720 else
721 return Position.Index <= Last_Index (Container);
722 end if;
723 end Has_Element;
725 ------------
726 -- Insert --
727 ------------
729 procedure Insert
730 (Container : in out Vector;
731 Before : Extended_Index;
732 New_Item : Element_Type;
733 Count : Count_Type := 1)
735 N : constant Int := Count_Type'Pos (Count);
737 First : constant Int := Int (Index_Type'First);
738 New_Last_As_Int : Int'Base;
739 New_Last : Index_Type;
740 New_Length : UInt;
741 Max_Length : constant UInt := UInt (Container.Capacity);
743 begin
744 if Before < Index_Type'First then
745 raise Constraint_Error with
746 "Before index is out of range (too small)";
747 end if;
749 if Before > Container.Last
750 and then Before > Container.Last + 1
751 then
752 raise Constraint_Error with
753 "Before index is out of range (too large)";
754 end if;
756 if Count = 0 then
757 return;
758 end if;
760 declare
761 Old_Last_As_Int : constant Int := Int (Container.Last);
763 begin
764 if Old_Last_As_Int > Int'Last - N then
765 raise Constraint_Error with "new length is out of range";
766 end if;
768 New_Last_As_Int := Old_Last_As_Int + N;
770 if New_Last_As_Int > Int (Index_Type'Last) then
771 raise Constraint_Error with "new length is out of range";
772 end if;
774 New_Length := UInt (New_Last_As_Int - First + Int'(1));
776 if New_Length > Max_Length then
777 raise Constraint_Error with "new length is out of range";
778 end if;
780 New_Last := Index_Type (New_Last_As_Int);
782 -- Resolve issue of capacity vs. max index ???
783 end;
785 declare
786 EA : Elements_Array renames Container.Elements;
788 BB : constant Int'Base := Int (Before) - Int (No_Index);
789 B : constant Count_Type := Count_Type (BB);
791 LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
792 L : constant Count_Type := Count_Type (LL);
794 begin
795 if Before <= Container.Last then
796 declare
797 II : constant Int'Base := BB + N;
798 I : constant Count_Type := Count_Type (II);
799 begin
800 EA (I .. L) := EA (B .. Length (Container));
801 EA (B .. I - 1) := (others => New_Item);
802 end;
804 else
805 EA (B .. L) := (others => New_Item);
806 end if;
807 end;
809 Container.Last := New_Last;
810 end Insert;
812 procedure Insert
813 (Container : in out Vector;
814 Before : Extended_Index;
815 New_Item : Vector)
817 N : constant Count_Type := Length (New_Item);
819 begin
820 if Before < Index_Type'First then
821 raise Constraint_Error with
822 "Before index is out of range (too small)";
823 end if;
825 if Before > Container.Last
826 and then Before > Container.Last + 1
827 then
828 raise Constraint_Error with
829 "Before index is out of range (too large)";
830 end if;
832 if N = 0 then
833 return;
834 end if;
836 Insert_Space (Container, Before, Count => N);
838 declare
839 Dst_Last_As_Int : constant Int'Base :=
840 Int (Before) + Int (N) - 1 - Int (No_Index);
842 Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
844 BB : constant Int'Base := Int (Before) - Int (No_Index);
845 B : constant Count_Type := Count_Type (BB);
847 begin
848 if Container'Address /= New_Item'Address then
849 Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
850 return;
851 end if;
853 declare
854 Src : Elements_Array renames Container.Elements (1 .. B - 1);
856 Index_As_Int : constant Int'Base := BB + Src'Length - 1;
858 Index : constant Count_Type := Count_Type (Index_As_Int);
860 Dst : Elements_Array renames Container.Elements (B .. Index);
862 begin
863 Dst := Src;
864 end;
866 if Dst_Last = Length (Container) then
867 return;
868 end if;
870 declare
871 Src : Elements_Array renames
872 Container.Elements (Dst_Last + 1 .. Length (Container));
874 Index_As_Int : constant Int'Base :=
875 Dst_Last_As_Int - Src'Length + 1;
877 Index : constant Count_Type := Count_Type (Index_As_Int);
879 Dst : Elements_Array renames
880 Container.Elements (Index .. Dst_Last);
882 begin
883 Dst := Src;
884 end;
885 end;
886 end Insert;
888 procedure Insert
889 (Container : in out Vector;
890 Before : Cursor;
891 New_Item : Vector)
893 Index : Index_Type'Base;
895 begin
896 if Is_Empty (New_Item) then
897 return;
898 end if;
900 if not Before.Valid
901 or else Before.Index > Container.Last
902 then
903 if Container.Last = Index_Type'Last then
904 raise Constraint_Error with
905 "vector is already at its maximum length";
906 end if;
908 Index := Container.Last + 1;
910 else
911 Index := Before.Index;
912 end if;
914 Insert (Container, Index, New_Item);
915 end Insert;
917 procedure Insert
918 (Container : in out Vector;
919 Before : Cursor;
920 New_Item : Vector;
921 Position : out Cursor)
923 Index : Index_Type'Base;
925 begin
926 if Is_Empty (New_Item) then
927 if not Before.Valid
928 or else Before.Index > Container.Last
929 then
930 Position := No_Element;
931 else
932 Position := (True, Before.Index);
933 end if;
935 return;
936 end if;
938 if not Before.Valid
939 or else Before.Index > Container.Last
940 then
941 if Container.Last = Index_Type'Last then
942 raise Constraint_Error with
943 "vector is already at its maximum length";
944 end if;
946 Index := Container.Last + 1;
948 else
949 Index := Before.Index;
950 end if;
952 Insert (Container, Index, New_Item);
954 Position := Cursor'(True, Index);
955 end Insert;
957 procedure Insert
958 (Container : in out Vector;
959 Before : Cursor;
960 New_Item : Element_Type;
961 Count : Count_Type := 1)
963 Index : Index_Type'Base;
965 begin
966 if Count = 0 then
967 return;
968 end if;
970 if not Before.Valid
971 or else Before.Index > Container.Last
972 then
973 if Container.Last = Index_Type'Last then
974 raise Constraint_Error with
975 "vector is already at its maximum length";
976 end if;
978 Index := Container.Last + 1;
980 else
981 Index := Before.Index;
982 end if;
984 Insert (Container, Index, New_Item, Count);
985 end Insert;
987 procedure Insert
988 (Container : in out Vector;
989 Before : Cursor;
990 New_Item : Element_Type;
991 Position : out Cursor;
992 Count : Count_Type := 1)
994 Index : Index_Type'Base;
996 begin
997 if Count = 0 then
998 if not Before.Valid
999 or else Before.Index > Container.Last
1000 then
1001 Position := No_Element;
1002 else
1003 Position := (True, Before.Index);
1004 end if;
1006 return;
1007 end if;
1009 if not Before.Valid
1010 or else Before.Index > Container.Last
1011 then
1012 if Container.Last = Index_Type'Last then
1013 raise Constraint_Error with
1014 "vector is already at its maximum length";
1015 end if;
1017 Index := Container.Last + 1;
1019 else
1020 Index := Before.Index;
1021 end if;
1023 Insert (Container, Index, New_Item, Count);
1025 Position := Cursor'(True, Index);
1026 end Insert;
1028 ------------------
1029 -- Insert_Space --
1030 ------------------
1032 procedure Insert_Space
1033 (Container : in out Vector;
1034 Before : Extended_Index;
1035 Count : Count_Type := 1)
1037 N : constant Int := Count_Type'Pos (Count);
1039 First : constant Int := Int (Index_Type'First);
1040 New_Last_As_Int : Int'Base;
1041 New_Last : Index_Type;
1042 New_Length : UInt;
1043 Max_Length : constant UInt := UInt (Count_Type'Last);
1045 begin
1046 if Before < Index_Type'First then
1047 raise Constraint_Error with
1048 "Before index is out of range (too small)";
1049 end if;
1051 if Before > Container.Last
1052 and then Before > Container.Last + 1
1053 then
1054 raise Constraint_Error with
1055 "Before index is out of range (too large)";
1056 end if;
1058 if Count = 0 then
1059 return;
1060 end if;
1062 declare
1063 Old_Last_As_Int : constant Int := Int (Container.Last);
1065 begin
1066 if Old_Last_As_Int > Int'Last - N then
1067 raise Constraint_Error with "new length is out of range";
1068 end if;
1070 New_Last_As_Int := Old_Last_As_Int + N;
1072 if New_Last_As_Int > Int (Index_Type'Last) then
1073 raise Constraint_Error with "new length is out of range";
1074 end if;
1076 New_Length := UInt (New_Last_As_Int - First + Int'(1));
1078 if New_Length > Max_Length then
1079 raise Constraint_Error with "new length is out of range";
1080 end if;
1082 New_Last := Index_Type (New_Last_As_Int);
1084 -- Resolve issue of capacity vs. max index ???
1085 end;
1087 declare
1088 EA : Elements_Array renames Container.Elements;
1090 BB : constant Int'Base := Int (Before) - Int (No_Index);
1091 B : constant Count_Type := Count_Type (BB);
1093 LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
1094 L : constant Count_Type := Count_Type (LL);
1096 begin
1097 if Before <= Container.Last then
1098 declare
1099 II : constant Int'Base := BB + N;
1100 I : constant Count_Type := Count_Type (II);
1101 begin
1102 EA (I .. L) := EA (B .. Length (Container));
1103 end;
1104 end if;
1105 end;
1107 Container.Last := New_Last;
1108 end Insert_Space;
1110 --------------
1111 -- Is_Empty --
1112 --------------
1114 function Is_Empty (Container : Vector) return Boolean is
1115 begin
1116 return Last_Index (Container) < Index_Type'First;
1117 end Is_Empty;
1119 ----------
1120 -- Last --
1121 ----------
1123 function Last (Container : Vector) return Cursor is
1124 begin
1125 if Is_Empty (Container) then
1126 return No_Element;
1127 end if;
1129 return (True, Last_Index (Container));
1130 end Last;
1132 ------------------
1133 -- Last_Element --
1134 ------------------
1136 function Last_Element (Container : Vector) return Element_Type is
1137 begin
1138 if Is_Empty (Container) then
1139 raise Constraint_Error with "Container is empty";
1140 end if;
1142 return Get_Element (Container, Length (Container));
1143 end Last_Element;
1145 ----------------
1146 -- Last_Index --
1147 ----------------
1149 function Last_Index (Container : Vector) return Extended_Index is
1150 begin
1151 return Container.Last;
1152 end Last_Index;
1154 ------------
1155 -- Length --
1156 ------------
1158 function Length (Container : Vector) return Count_Type is
1159 L : constant Int := Int (Last_Index (Container));
1160 F : constant Int := Int (Index_Type'First);
1161 N : constant Int'Base := L - F + 1;
1163 begin
1164 return Count_Type (N);
1165 end Length;
1167 ----------
1168 -- Left --
1169 ----------
1171 function Left (Container : Vector; Position : Cursor) return Vector is
1172 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1174 begin
1175 if Position = No_Element then
1176 return C;
1177 end if;
1179 if not Has_Element (Container, Position) then
1180 raise Constraint_Error;
1181 end if;
1183 while C.Last /= Position.Index - 1 loop
1184 Delete_Last (C);
1185 end loop;
1186 return C;
1187 end Left;
1189 ----------
1190 -- Move --
1191 ----------
1193 procedure Move
1194 (Target : in out Vector;
1195 Source : in out Vector)
1197 N : constant Count_Type := Length (Source);
1199 begin
1200 if Target'Address = Source'Address then
1201 return;
1202 end if;
1204 if N > Target.Capacity then
1205 raise Constraint_Error with -- correct exception here???
1206 "length of Source is greater than capacity of Target";
1207 end if;
1209 -- We could also write this as a loop, and incrementally
1210 -- copy elements from source to target.
1212 Target.Last := No_Index; -- in case array assignment files
1213 Target.Elements (1 .. N) := Source.Elements (1 .. N);
1215 Target.Last := Source.Last;
1216 Source.Last := No_Index;
1217 end Move;
1219 ----------
1220 -- Next --
1221 ----------
1223 function Next (Container : Vector; Position : Cursor) return Cursor is
1224 begin
1225 if not Position.Valid then
1226 return No_Element;
1227 end if;
1229 if Position.Index < Last_Index (Container) then
1230 return (True, Position.Index + 1);
1231 end if;
1233 return No_Element;
1234 end Next;
1236 ----------
1237 -- Next --
1238 ----------
1240 procedure Next (Container : Vector; Position : in out Cursor) is
1241 begin
1242 if not Position.Valid then
1243 return;
1244 end if;
1246 if Position.Index < Last_Index (Container) then
1247 Position.Index := Position.Index + 1;
1248 else
1249 Position := No_Element;
1250 end if;
1251 end Next;
1253 -------------
1254 -- Prepend --
1255 -------------
1257 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1258 begin
1259 Insert (Container, Index_Type'First, New_Item);
1260 end Prepend;
1262 procedure Prepend
1263 (Container : in out Vector;
1264 New_Item : Element_Type;
1265 Count : Count_Type := 1)
1267 begin
1268 Insert (Container,
1269 Index_Type'First,
1270 New_Item,
1271 Count);
1272 end Prepend;
1274 --------------
1275 -- Previous --
1276 --------------
1278 procedure Previous (Container : Vector; Position : in out Cursor) is
1279 begin
1280 if not Position.Valid then
1281 return;
1282 end if;
1284 if Position.Index > Index_Type'First and
1285 Position.Index <= Last_Index (Container) then
1286 Position.Index := Position.Index - 1;
1287 else
1288 Position := No_Element;
1289 end if;
1290 end Previous;
1292 function Previous (Container : Vector; Position : Cursor) return Cursor is
1293 begin
1294 if not Position.Valid then
1295 return No_Element;
1296 end if;
1298 if Position.Index > Index_Type'First and
1299 Position.Index <= Last_Index (Container) then
1300 return (True, Position.Index - 1);
1301 end if;
1303 return No_Element;
1304 end Previous;
1306 ---------------------
1307 -- Replace_Element --
1308 ---------------------
1310 procedure Replace_Element
1311 (Container : in out Vector;
1312 Index : Index_Type;
1313 New_Item : Element_Type)
1315 begin
1316 if Index > Container.Last then
1317 raise Constraint_Error with "Index is out of range";
1318 end if;
1320 declare
1321 II : constant Int'Base := Int (Index) - Int (No_Index);
1322 I : constant Count_Type := Count_Type (II);
1324 begin
1325 Container.Elements (I) := New_Item;
1326 end;
1327 end Replace_Element;
1329 procedure Replace_Element
1330 (Container : in out Vector;
1331 Position : Cursor;
1332 New_Item : Element_Type)
1334 begin
1335 if not Position.Valid then
1336 raise Constraint_Error with "Position cursor has no element";
1337 end if;
1339 if Position.Index > Container.Last then
1340 raise Constraint_Error with "Position cursor is out of range";
1341 end if;
1343 declare
1344 II : constant Int'Base := Int (Position.Index) - Int (No_Index);
1345 I : constant Count_Type := Count_Type (II);
1346 begin
1347 Container.Elements (I) := New_Item;
1348 end;
1349 end Replace_Element;
1351 ----------------------
1352 -- Reserve_Capacity --
1353 ----------------------
1355 procedure Reserve_Capacity
1356 (Container : in out Vector;
1357 Capacity : Count_Type)
1359 begin
1360 if Capacity > Container.Capacity then
1361 raise Constraint_Error with "Capacity is out of range";
1362 end if;
1363 end Reserve_Capacity;
1365 ----------------------
1366 -- Reverse_Elements --
1367 ----------------------
1369 procedure Reverse_Elements (Container : in out Vector) is
1370 begin
1371 if Length (Container) <= 1 then
1372 return;
1373 end if;
1375 declare
1376 I, J : Count_Type;
1377 E : Elements_Array renames Container.Elements;
1379 begin
1380 I := 1;
1381 J := Length (Container);
1382 while I < J loop
1383 declare
1384 EI : constant Element_Type := E (I);
1385 begin
1386 E (I) := E (J);
1387 E (J) := EI;
1388 end;
1390 I := I + 1;
1391 J := J - 1;
1392 end loop;
1393 end;
1394 end Reverse_Elements;
1396 ------------------
1397 -- Reverse_Find --
1398 ------------------
1400 function Reverse_Find
1401 (Container : Vector;
1402 Item : Element_Type;
1403 Position : Cursor := No_Element) return Cursor
1405 Last : Index_Type'Base;
1406 K : Count_Type;
1408 begin
1409 if not Position.Valid
1410 or else Position.Index > Last_Index (Container)
1411 then
1412 Last := Last_Index (Container);
1413 else
1414 Last := Position.Index;
1415 end if;
1417 K := Count_Type (Int (Last) - Int (No_Index));
1418 for Indx in reverse Index_Type'First .. Last loop
1419 if Get_Element (Container, K) = Item then
1420 return (True, Indx);
1421 end if;
1423 K := K - 1;
1424 end loop;
1426 return No_Element;
1427 end Reverse_Find;
1429 ------------------------
1430 -- Reverse_Find_Index --
1431 ------------------------
1433 function Reverse_Find_Index
1434 (Container : Vector;
1435 Item : Element_Type;
1436 Index : Index_Type := Index_Type'Last) return Extended_Index
1438 Last : Index_Type'Base;
1439 K : Count_Type;
1441 begin
1442 if Index > Last_Index (Container) then
1443 Last := Last_Index (Container);
1444 else
1445 Last := Index;
1446 end if;
1448 K := Count_Type (Int (Last) - Int (No_Index));
1449 for Indx in reverse Index_Type'First .. Last loop
1450 if Get_Element (Container, K) = Item then
1451 return Indx;
1452 end if;
1454 K := K - 1;
1455 end loop;
1457 return No_Index;
1458 end Reverse_Find_Index;
1460 -----------
1461 -- Right --
1462 -----------
1464 function Right (Container : Vector; Position : Cursor) return Vector is
1465 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1467 begin
1468 if Position = No_Element then
1469 Clear (C);
1470 return C;
1471 end if;
1473 if not Has_Element (Container, Position) then
1474 raise Constraint_Error;
1475 end if;
1477 while C.Last /= Container.Last - Position.Index + 1 loop
1478 Delete_First (C);
1479 end loop;
1481 return C;
1482 end Right;
1484 ----------------
1485 -- Set_Length --
1486 ----------------
1488 procedure Set_Length
1489 (Container : in out Vector;
1490 New_Length : Count_Type)
1492 begin
1493 if New_Length = Formal_Vectors.Length (Container) then
1494 return;
1495 end if;
1497 if New_Length > Container.Capacity then
1498 raise Constraint_Error; -- ???
1499 end if;
1501 declare
1502 Last_As_Int : constant Int'Base :=
1503 Int (Index_Type'First) + Int (New_Length) - 1;
1504 begin
1505 Container.Last := Index_Type'Base (Last_As_Int);
1506 end;
1507 end Set_Length;
1509 ----------
1510 -- Swap --
1511 ----------
1513 procedure Swap (Container : in out Vector; I, J : Index_Type) is
1514 begin
1515 if I > Container.Last then
1516 raise Constraint_Error with "I index is out of range";
1517 end if;
1519 if J > Container.Last then
1520 raise Constraint_Error with "J index is out of range";
1521 end if;
1523 if I = J then
1524 return;
1525 end if;
1527 declare
1528 II : constant Int'Base := Int (I) - Int (No_Index);
1529 JJ : constant Int'Base := Int (J) - Int (No_Index);
1531 EI : Element_Type renames Container.Elements (Count_Type (II));
1532 EJ : Element_Type renames Container.Elements (Count_Type (JJ));
1534 EI_Copy : constant Element_Type := EI;
1536 begin
1537 EI := EJ;
1538 EJ := EI_Copy;
1539 end;
1540 end Swap;
1542 procedure Swap (Container : in out Vector; I, J : Cursor) is
1543 begin
1544 if not I.Valid then
1545 raise Constraint_Error with "I cursor has no element";
1546 end if;
1548 if not J.Valid then
1549 raise Constraint_Error with "J cursor has no element";
1550 end if;
1552 Swap (Container, I.Index, J.Index);
1553 end Swap;
1555 ---------------
1556 -- To_Cursor --
1557 ---------------
1559 function To_Cursor
1560 (Container : Vector;
1561 Index : Extended_Index) return Cursor
1563 begin
1564 if Index not in Index_Type'First .. Last_Index (Container) then
1565 return No_Element;
1566 end if;
1568 return Cursor'(True, Index);
1569 end To_Cursor;
1571 --------------
1572 -- To_Index --
1573 --------------
1575 function To_Index (Position : Cursor) return Extended_Index is
1576 begin
1577 if not Position.Valid then
1578 return No_Index;
1579 end if;
1581 return Position.Index;
1582 end To_Index;
1584 ---------------
1585 -- To_Vector --
1586 ---------------
1588 function To_Vector
1589 (New_Item : Element_Type;
1590 Length : Count_Type) return Vector
1592 begin
1593 if Length = 0 then
1594 return Empty_Vector;
1595 end if;
1597 declare
1598 First : constant Int := Int (Index_Type'First);
1599 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1600 Last : Index_Type;
1602 begin
1603 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1604 raise Constraint_Error with "Length is out of range"; -- ???
1605 end if;
1607 Last := Index_Type (Last_As_Int);
1609 return (Length, (others => New_Item), Last => Last,
1610 others => <>);
1611 end;
1612 end To_Vector;
1614 end Ada.Containers.Formal_Vectors;