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-- 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 28with Ada.Containers.Generic_Array_Sort; 29with Ada.Unchecked_Deallocation; 30 31with System; use type System.Address; 32 33package body Ada.Containers.Formal_Vectors with 34 SPARK_Mode => Off 35is 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 644end Ada.Containers.Formal_Vectors; 645