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