File : a-cofove.adb
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-2015, 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 -- --
19 -- --
20 -- --
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
28 with Ada.Containers.Generic_Array_Sort;
29 with Ada.Unchecked_Deallocation;
30
31 with System; use type System.Address;
32
33 package body Ada.Containers.Formal_Vectors with
34 SPARK_Mode => Off
35 is
36
37 Growth_Factor : constant := 2;
38 -- When growing a container, multiply current capacity by this. Doubling
39 -- leads to amortized linear-time copying.
40
41 type Int is range System.Min_Int .. System.Max_Int;
42 type UInt is mod System.Max_Binary_Modulus;
43
44 procedure Free is
45 new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr);
46
47 type Maximal_Array_Ptr is access all Elements_Array (Array_Index)
48 with Storage_Size => 0;
49 type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index)
50 with Storage_Size => 0;
51
52 function Elems (Container : in out Vector) return Maximal_Array_Ptr;
53 function Elemsc
54 (Container : Vector) return Maximal_Array_Ptr_Const;
55 -- Returns a pointer to the Elements array currently in use -- either
56 -- Container.Elements_Ptr or a pointer to Container.Elements. We work with
57 -- pointers to a bogus array subtype that is constrained with the maximum
58 -- possible bounds. This means that the pointer is a thin pointer. This is
59 -- necessary because 'Unrestricted_Access doesn't work when it produces
60 -- access-to-unconstrained and is returned from a function.
61 --
62 -- Note that this is dangerous: make sure calls to this use an indexed
63 -- component or slice that is within the bounds 1 .. Length (Container).
64
65 function Get_Element
66 (Container : Vector;
67 Position : Capacity_Range) return Element_Type;
68
69 ---------
70 -- "=" --
71 ---------
72
73 function "=" (Left, Right : Vector) return Boolean is
74 begin
75 if Left'Address = Right'Address then
76 return True;
77 end if;
78
79 if Length (Left) /= Length (Right) then
80 return False;
81 end if;
82
83 for J in 1 .. Length (Left) loop
84 if Get_Element (Left, J) /= Get_Element (Right, J) then
85 return False;
86 end if;
87 end loop;
88
89 return True;
90 end "=";
91
92 ------------
93 -- Append --
94 ------------
95
96 procedure Append (Container : in out Vector; New_Item : Vector) is
97 begin
98 for X in First_Index (New_Item) .. Last_Index (New_Item) loop
99 Append (Container, Element (New_Item, X));
100 end loop;
101 end Append;
102
103 procedure Append
104 (Container : in out Vector;
105 New_Item : Element_Type)
106 is
107 New_Length : constant UInt := UInt (Length (Container) + 1);
108 begin
109 if not Bounded and then
110 Capacity (Container) < Capacity_Range (New_Length)
111 then
112 Reserve_Capacity
113 (Container,
114 Capacity_Range'Max (Capacity (Container) * Growth_Factor,
115 Capacity_Range (New_Length)));
116 end if;
117
118 if Container.Last = Index_Type'Last then
119 raise Constraint_Error with "vector is already at its maximum length";
120 end if;
121
122 -- TODO: should check whether length > max capacity (cnt_t'last) ???
123
124 Container.Last := Container.Last + 1;
125 Elems (Container) (Length (Container)) := New_Item;
126 end Append;
127
128 ------------
129 -- Assign --
130 ------------
131
132 procedure Assign (Target : in out Vector; Source : Vector) is
133 LS : constant Capacity_Range := Length (Source);
134
135 begin
136 if Target'Address = Source'Address then
137 return;
138 end if;
139
140 if Bounded and then Target.Capacity < LS then
141 raise Constraint_Error;
142 end if;
143
144 Clear (Target);
145 Append (Target, Source);
146 end Assign;
147
148 --------------
149 -- Capacity --
150 --------------
151
152 function Capacity (Container : Vector) return Capacity_Range is
153 begin
154 return (if Container.Elements_Ptr = null
155 then Container.Elements'Length
156 else Container.Elements_Ptr.all'Length);
157 end Capacity;
158
159 -----------
160 -- Clear --
161 -----------
162
163 procedure Clear (Container : in out Vector) is
164 begin
165 Container.Last := No_Index;
166
167 -- Free element, note that this is OK if Elements_Ptr is null
168
169 Free (Container.Elements_Ptr);
170 end Clear;
171
172 --------------
173 -- Contains --
174 --------------
175
176 function Contains
177 (Container : Vector;
178 Item : Element_Type) return Boolean
179 is
180 begin
181 return Find_Index (Container, Item) /= No_Index;
182 end Contains;
183
184 ----------
185 -- Copy --
186 ----------
187
188 function Copy
189 (Source : Vector;
190 Capacity : Capacity_Range := 0) return Vector
191 is
192 LS : constant Capacity_Range := Length (Source);
193 C : Capacity_Range;
194
195 begin
196 if Capacity = 0 then
197 C := LS;
198 elsif Capacity >= LS then
199 C := Capacity;
200 else
201 raise Capacity_Error;
202 end if;
203
204 return Target : Vector (C) do
205 Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS);
206 Target.Last := Source.Last;
207 end return;
208 end Copy;
209
210 ---------------------
211 -- Current_To_Last --
212 ---------------------
213
214 function Current_To_Last
215 (Container : Vector;
216 Current : Index_Type) return Vector
217 is
218 begin
219 return Result : Vector (Count_Type (Container.Last - Current + 1))
220 do
221 for X in Current .. Container.Last loop
222 Append (Result, Element (Container, X));
223 end loop;
224 end return;
225 end Current_To_Last;
226
227 -----------------
228 -- Delete_Last --
229 -----------------
230
231 procedure Delete_Last
232 (Container : in out Vector)
233 is
234 Count : constant Capacity_Range := 1;
235 Index : Int'Base;
236
237 begin
238 Index := Int'Base (Container.Last) - Int'Base (Count);
239
240 if Index < Index_Type'Pos (Index_Type'First) then
241 Container.Last := No_Index;
242 else
243 Container.Last := Index_Type (Index);
244 end if;
245 end Delete_Last;
246
247 -------------
248 -- Element --
249 -------------
250
251 function Element
252 (Container : Vector;
253 Index : Index_Type) return Element_Type
254 is
255 begin
256 if Index > Container.Last then
257 raise Constraint_Error with "Index is out of range";
258 end if;
259
260 declare
261 II : constant Int'Base := Int (Index) - Int (No_Index);
262 I : constant Capacity_Range := Capacity_Range (II);
263 begin
264 return Get_Element (Container, I);
265 end;
266 end Element;
267
268 --------------
269 -- Elements --
270 --------------
271
272 function Elems (Container : in out Vector) return Maximal_Array_Ptr is
273 begin
274 return (if Container.Elements_Ptr = null
275 then Container.Elements'Unrestricted_Access
276 else Container.Elements_Ptr.all'Unrestricted_Access);
277 end Elems;
278
279 function Elemsc
280 (Container : Vector) return Maximal_Array_Ptr_Const is
281 begin
282 return (if Container.Elements_Ptr = null
283 then Container.Elements'Unrestricted_Access
284 else Container.Elements_Ptr.all'Unrestricted_Access);
285 end Elemsc;
286
287 ----------------
288 -- Find_Index --
289 ----------------
290
291 function Find_Index
292 (Container : Vector;
293 Item : Element_Type;
294 Index : Index_Type := Index_Type'First) return Extended_Index
295 is
296 K : Capacity_Range;
297 Last : constant Index_Type := Last_Index (Container);
298
299 begin
300 K := Capacity_Range (Int (Index) - Int (No_Index));
301 for Indx in Index .. Last loop
302 if Get_Element (Container, K) = Item then
303 return Indx;
304 end if;
305
306 K := K + 1;
307 end loop;
308
309 return No_Index;
310 end Find_Index;
311
312 -------------------
313 -- First_Element --
314 -------------------
315
316 function First_Element (Container : Vector) return Element_Type is
317 begin
318 if Is_Empty (Container) then
319 raise Constraint_Error with "Container is empty";
320 else
321 return Get_Element (Container, 1);
322 end if;
323 end First_Element;
324
325 -----------------
326 -- First_Index --
327 -----------------
328
329 function First_Index (Container : Vector) return Index_Type is
330 pragma Unreferenced (Container);
331 begin
332 return Index_Type'First;
333 end First_Index;
334
335 -----------------------
336 -- First_To_Previous --
337 -----------------------
338
339 function First_To_Previous
340 (Container : Vector;
341 Current : Index_Type) return Vector
342 is
343 begin
344 return Result : Vector
345 (Count_Type (Current - First_Index (Container)))
346 do
347 for X in First_Index (Container) .. Current - 1 loop
348 Append (Result, Element (Container, X));
349 end loop;
350 end return;
351 end First_To_Previous;
352
353 ---------------------
354 -- Generic_Sorting --
355 ---------------------
356
357 package body Generic_Sorting with SPARK_Mode => Off is
358
359 ---------------
360 -- Is_Sorted --
361 ---------------
362
363 function Is_Sorted (Container : Vector) return Boolean is
364 L : constant Capacity_Range := Length (Container);
365 begin
366 for J in 1 .. L - 1 loop
367 if Get_Element (Container, J + 1) <
368 Get_Element (Container, J)
369 then
370 return False;
371 end if;
372 end loop;
373
374 return True;
375 end Is_Sorted;
376
377 ----------
378 -- Sort --
379 ----------
380
381 procedure Sort (Container : in out Vector)
382 is
383 procedure Sort is
384 new Generic_Array_Sort
385 (Index_Type => Array_Index,
386 Element_Type => Element_Type,
387 Array_Type => Elements_Array,
388 "<" => "<");
389
390 Len : constant Capacity_Range := Length (Container);
391 begin
392 if Container.Last <= Index_Type'First then
393 return;
394 else
395 Sort (Elems (Container) (1 .. Len));
396 end if;
397 end Sort;
398
399 end Generic_Sorting;
400
401 -----------------
402 -- Get_Element --
403 -----------------
404
405 function Get_Element
406 (Container : Vector;
407 Position : Capacity_Range) return Element_Type
408 is
409 begin
410 return Elemsc (Container) (Position);
411 end Get_Element;
412
413 -----------------
414 -- Has_Element --
415 -----------------
416
417 function Has_Element
418 (Container : Vector; Position : Extended_Index) return Boolean is
419 begin
420 return Position in First_Index (Container) .. Last_Index (Container);
421 end Has_Element;
422
423 --------------
424 -- Is_Empty --
425 --------------
426
427 function Is_Empty (Container : Vector) return Boolean is
428 begin
429 return Last_Index (Container) < Index_Type'First;
430 end Is_Empty;
431
432 ------------------
433 -- Last_Element --
434 ------------------
435
436 function Last_Element (Container : Vector) return Element_Type is
437 begin
438 if Is_Empty (Container) then
439 raise Constraint_Error with "Container is empty";
440 else
441 return Get_Element (Container, Length (Container));
442 end if;
443 end Last_Element;
444
445 ----------------
446 -- Last_Index --
447 ----------------
448
449 function Last_Index (Container : Vector) return Extended_Index is
450 begin
451 return Container.Last;
452 end Last_Index;
453
454 ------------
455 -- Length --
456 ------------
457
458 function Length (Container : Vector) return Capacity_Range is
459 L : constant Int := Int (Last_Index (Container));
460 F : constant Int := Int (Index_Type'First);
461 N : constant Int'Base := L - F + 1;
462 begin
463 return Capacity_Range (N);
464 end Length;
465
466 ---------------------
467 -- Replace_Element --
468 ---------------------
469
470 procedure Replace_Element
471 (Container : in out Vector;
472 Index : Index_Type;
473 New_Item : Element_Type)
474 is
475 begin
476 if Index > Container.Last then
477 raise Constraint_Error with "Index is out of range";
478 end if;
479
480 declare
481 II : constant Int'Base := Int (Index) - Int (No_Index);
482 I : constant Capacity_Range := Capacity_Range (II);
483 begin
484 Elems (Container) (I) := New_Item;
485 end;
486 end Replace_Element;
487
488 ----------------------
489 -- Reserve_Capacity --
490 ----------------------
491
492 procedure Reserve_Capacity
493 (Container : in out Vector;
494 Capacity : Capacity_Range)
495 is
496 begin
497 if Bounded then
498 if Capacity > Container.Capacity then
499 raise Constraint_Error with "Capacity is out of range";
500 end if;
501 else
502 if Capacity > Formal_Vectors.Capacity (Container) then
503 declare
504 New_Elements : constant Elements_Array_Ptr :=
505 new Elements_Array (1 .. Capacity);
506 L : constant Capacity_Range := Length (Container);
507 begin
508 New_Elements (1 .. L) := Elemsc (Container) (1 .. L);
509 Free (Container.Elements_Ptr);
510 Container.Elements_Ptr := New_Elements;
511 end;
512 end if;
513 end if;
514 end Reserve_Capacity;
515
516 ----------------------
517 -- Reverse_Elements --
518 ----------------------
519
520 procedure Reverse_Elements (Container : in out Vector) is
521 begin
522 if Length (Container) <= 1 then
523 return;
524 end if;
525
526 declare
527 I, J : Capacity_Range;
528 E : Elements_Array renames
529 Elems (Container) (1 .. Length (Container));
530
531 begin
532 I := 1;
533 J := Length (Container);
534 while I < J loop
535 declare
536 EI : constant Element_Type := E (I);
537 begin
538 E (I) := E (J);
539 E (J) := EI;
540 end;
541
542 I := I + 1;
543 J := J - 1;
544 end loop;
545 end;
546 end Reverse_Elements;
547
548 ------------------------
549 -- Reverse_Find_Index --
550 ------------------------
551
552 function Reverse_Find_Index
553 (Container : Vector;
554 Item : Element_Type;
555 Index : Index_Type := Index_Type'Last) return Extended_Index
556 is
557 Last : Index_Type'Base;
558 K : Capacity_Range;
559
560 begin
561 if Index > Last_Index (Container) then
562 Last := Last_Index (Container);
563 else
564 Last := Index;
565 end if;
566
567 K := Capacity_Range (Int (Last) - Int (No_Index));
568 for Indx in reverse Index_Type'First .. Last loop
569 if Get_Element (Container, K) = Item then
570 return Indx;
571 end if;
572
573 K := K - 1;
574 end loop;
575
576 return No_Index;
577 end Reverse_Find_Index;
578
579 ----------
580 -- Swap --
581 ----------
582
583 procedure Swap (Container : in out Vector; I, J : Index_Type) is
584 begin
585 if I > Container.Last then
586 raise Constraint_Error with "I index is out of range";
587 end if;
588
589 if J > Container.Last then
590 raise Constraint_Error with "J index is out of range";
591 end if;
592
593 if I = J then
594 return;
595 end if;
596
597 declare
598 II : constant Int'Base := Int (I) - Int (No_Index);
599 JJ : constant Int'Base := Int (J) - Int (No_Index);
600
601 EI : Element_Type renames Elems (Container) (Capacity_Range (II));
602 EJ : Element_Type renames Elems (Container) (Capacity_Range (JJ));
603
604 EI_Copy : constant Element_Type := EI;
605
606 begin
607 EI := EJ;
608 EJ := EI_Copy;
609 end;
610 end Swap;
611
612 ---------------
613 -- To_Vector --
614 ---------------
615
616 function To_Vector
617 (New_Item : Element_Type;
618 Length : Capacity_Range) return Vector
619 is
620 begin
621 if Length = 0 then
622 return Empty_Vector;
623 end if;
624
625 declare
626 First : constant Int := Int (Index_Type'First);
627 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
628 Last : Index_Type;
629
630 begin
631 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
632 raise Constraint_Error with "Length is out of range"; -- ???
633 end if;
634
635 Last := Index_Type (Last_As_Int);
636
637 return (Capacity => Length,
638 Last => Last,
639 Elements_Ptr => <>,
640 Elements => (others => New_Item));
641 end;
642 end To_Vector;
643
644 end Ada.Containers.Formal_Vectors;