Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 1 | ------------------------------------------------------------------------------ |
| 2 | -- -- |
| 3 | -- GNAT LIBRARY COMPONENTS -- |
| 4 | -- -- |
| 5 | -- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- |
| 6 | -- -- |
| 7 | -- B o d y -- |
| 8 | -- -- |
| 9 | -- Copyright (C) 2004-2012, 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 | -- This unit was originally developed by Matthew J Heaney. -- |
| 28 | ------------------------------------------------------------------------------ |
| 29 | |
| 30 | with Ada.Containers.Generic_Array_Sort; |
| 31 | with Ada.Finalization; use Ada.Finalization; |
| 32 | |
| 33 | with System; use type System.Address; |
| 34 | |
| 35 | package body Ada.Containers.Bounded_Vectors is |
| 36 | |
| 37 | type Iterator is new Limited_Controlled and |
| 38 | Vector_Iterator_Interfaces.Reversible_Iterator with |
| 39 | record |
| 40 | Container : Vector_Access; |
| 41 | Index : Index_Type'Base; |
| 42 | end record; |
| 43 | |
| 44 | overriding procedure Finalize (Object : in out Iterator); |
| 45 | |
| 46 | overriding function First (Object : Iterator) return Cursor; |
| 47 | overriding function Last (Object : Iterator) return Cursor; |
| 48 | |
| 49 | overriding function Next |
| 50 | (Object : Iterator; |
| 51 | Position : Cursor) return Cursor; |
| 52 | |
| 53 | overriding function Previous |
| 54 | (Object : Iterator; |
| 55 | Position : Cursor) return Cursor; |
| 56 | |
| 57 | ----------------------- |
| 58 | -- Local Subprograms -- |
| 59 | ----------------------- |
| 60 | |
| 61 | function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; |
| 62 | |
| 63 | --------- |
| 64 | -- "&" -- |
| 65 | --------- |
| 66 | |
| 67 | function "&" (Left, Right : Vector) return Vector is |
| 68 | LN : constant Count_Type := Length (Left); |
| 69 | RN : constant Count_Type := Length (Right); |
| 70 | N : Count_Type'Base; -- length of result |
| 71 | J : Count_Type'Base; -- for computing intermediate index values |
| 72 | Last : Index_Type'Base; -- Last index of result |
| 73 | |
| 74 | begin |
| 75 | -- We decide that the capacity of the result is the sum of the lengths |
| 76 | -- of the vector parameters. We could decide to make it larger, but we |
| 77 | -- have no basis for knowing how much larger, so we just allocate the |
| 78 | -- minimum amount of storage. |
| 79 | |
| 80 | -- Here we handle the easy cases first, when one of the vector |
| 81 | -- parameters is empty. (We say "easy" because there's nothing to |
| 82 | -- compute, that can potentially overflow.) |
| 83 | |
| 84 | if LN = 0 then |
| 85 | if RN = 0 then |
| 86 | return Empty_Vector; |
| 87 | end if; |
| 88 | |
| 89 | return Vector'(Capacity => RN, |
| 90 | Elements => Right.Elements (1 .. RN), |
| 91 | Last => Right.Last, |
| 92 | others => <>); |
| 93 | end if; |
| 94 | |
| 95 | if RN = 0 then |
| 96 | return Vector'(Capacity => LN, |
| 97 | Elements => Left.Elements (1 .. LN), |
| 98 | Last => Left.Last, |
| 99 | others => <>); |
| 100 | end if; |
| 101 | |
| 102 | -- Neither of the vector parameters is empty, so must compute the length |
| 103 | -- of the result vector and its last index. (This is the harder case, |
| 104 | -- because our computations must avoid overflow.) |
| 105 | |
| 106 | -- There are two constraints we need to satisfy. The first constraint is |
| 107 | -- that a container cannot have more than Count_Type'Last elements, so |
| 108 | -- we must check the sum of the combined lengths. Note that we cannot |
| 109 | -- simply add the lengths, because of the possibility of overflow. |
| 110 | |
| 111 | if LN > Count_Type'Last - RN then |
| 112 | raise Constraint_Error with "new length is out of range"; |
| 113 | end if; |
| 114 | |
| 115 | -- It is now safe compute the length of the new vector, without fear of |
| 116 | -- overflow. |
| 117 | |
| 118 | N := LN + RN; |
| 119 | |
| 120 | -- The second constraint is that the new Last index value cannot |
| 121 | -- exceed Index_Type'Last. We use the wider of Index_Type'Base and |
| 122 | -- Count_Type'Base as the type for intermediate values. |
| 123 | |
| 124 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 125 | -- We perform a two-part test. First we determine whether the |
| 126 | -- computed Last value lies in the base range of the type, and then |
| 127 | -- determine whether it lies in the range of the index (sub)type. |
| 128 | |
| 129 | -- Last must satisfy this relation: |
| 130 | -- First + Length - 1 <= Last |
| 131 | -- We regroup terms: |
| 132 | -- First - 1 <= Last - Length |
| 133 | -- Which can rewrite as: |
| 134 | -- No_Index <= Last - Length |
| 135 | |
| 136 | if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then |
| 137 | raise Constraint_Error with "new length is out of range"; |
| 138 | end if; |
| 139 | |
| 140 | -- We now know that the computed value of Last is within the base |
| 141 | -- range of the type, so it is safe to compute its value: |
| 142 | |
| 143 | Last := No_Index + Index_Type'Base (N); |
| 144 | |
| 145 | -- Finally we test whether the value is within the range of the |
| 146 | -- generic actual index subtype: |
| 147 | |
| 148 | if Last > Index_Type'Last then |
| 149 | raise Constraint_Error with "new length is out of range"; |
| 150 | end if; |
| 151 | |
| 152 | elsif Index_Type'First <= 0 then |
| 153 | -- Here we can compute Last directly, in the normal way. We know that |
| 154 | -- No_Index is less than 0, so there is no danger of overflow when |
| 155 | -- adding the (positive) value of length. |
| 156 | |
| 157 | J := Count_Type'Base (No_Index) + N; -- Last |
| 158 | |
| 159 | if J > Count_Type'Base (Index_Type'Last) then |
| 160 | raise Constraint_Error with "new length is out of range"; |
| 161 | end if; |
| 162 | |
| 163 | -- We know that the computed value (having type Count_Type) of Last |
| 164 | -- is within the range of the generic actual index subtype, so it is |
| 165 | -- safe to convert to Index_Type: |
| 166 | |
| 167 | Last := Index_Type'Base (J); |
| 168 | |
| 169 | else |
| 170 | -- Here Index_Type'First (and Index_Type'Last) is positive, so we |
| 171 | -- must test the length indirectly (by working backwards from the |
| 172 | -- largest possible value of Last), in order to prevent overflow. |
| 173 | |
| 174 | J := Count_Type'Base (Index_Type'Last) - N; -- No_Index |
| 175 | |
| 176 | if J < Count_Type'Base (No_Index) then |
| 177 | raise Constraint_Error with "new length is out of range"; |
| 178 | end if; |
| 179 | |
| 180 | -- We have determined that the result length would not create a Last |
| 181 | -- index value outside of the range of Index_Type, so we can now |
| 182 | -- safely compute its value. |
| 183 | |
| 184 | Last := Index_Type'Base (Count_Type'Base (No_Index) + N); |
| 185 | end if; |
| 186 | |
| 187 | declare |
| 188 | LE : Elements_Array renames Left.Elements (1 .. LN); |
| 189 | RE : Elements_Array renames Right.Elements (1 .. RN); |
| 190 | |
| 191 | begin |
| 192 | return Vector'(Capacity => N, |
| 193 | Elements => LE & RE, |
| 194 | Last => Last, |
| 195 | others => <>); |
| 196 | end; |
| 197 | end "&"; |
| 198 | |
| 199 | function "&" (Left : Vector; Right : Element_Type) return Vector is |
| 200 | LN : constant Count_Type := Length (Left); |
| 201 | |
| 202 | begin |
| 203 | -- We decide that the capacity of the result is the sum of the lengths |
| 204 | -- of the parameters. We could decide to make it larger, but we have no |
| 205 | -- basis for knowing how much larger, so we just allocate the minimum |
| 206 | -- amount of storage. |
| 207 | |
| 208 | -- We must compute the length of the result vector and its last index, |
| 209 | -- but in such a way that overflow is avoided. We must satisfy two |
| 210 | -- constraints: the new length cannot exceed Count_Type'Last, and the |
| 211 | -- new Last index cannot exceed Index_Type'Last. |
| 212 | |
| 213 | if LN = Count_Type'Last then |
| 214 | raise Constraint_Error with "new length is out of range"; |
| 215 | end if; |
| 216 | |
| 217 | if Left.Last >= Index_Type'Last then |
| 218 | raise Constraint_Error with "new length is out of range"; |
| 219 | end if; |
| 220 | |
| 221 | return Vector'(Capacity => LN + 1, |
| 222 | Elements => Left.Elements (1 .. LN) & Right, |
| 223 | Last => Left.Last + 1, |
| 224 | others => <>); |
| 225 | end "&"; |
| 226 | |
| 227 | function "&" (Left : Element_Type; Right : Vector) return Vector is |
| 228 | RN : constant Count_Type := Length (Right); |
| 229 | |
| 230 | begin |
| 231 | -- We decide that the capacity of the result is the sum of the lengths |
| 232 | -- of the parameters. We could decide to make it larger, but we have no |
| 233 | -- basis for knowing how much larger, so we just allocate the minimum |
| 234 | -- amount of storage. |
| 235 | |
| 236 | -- We compute the length of the result vector and its last index, but in |
| 237 | -- such a way that overflow is avoided. We must satisfy two constraints: |
| 238 | -- the new length cannot exceed Count_Type'Last, and the new Last index |
| 239 | -- cannot exceed Index_Type'Last. |
| 240 | |
| 241 | if RN = Count_Type'Last then |
| 242 | raise Constraint_Error with "new length is out of range"; |
| 243 | end if; |
| 244 | |
| 245 | if Right.Last >= Index_Type'Last then |
| 246 | raise Constraint_Error with "new length is out of range"; |
| 247 | end if; |
| 248 | |
| 249 | return Vector'(Capacity => 1 + RN, |
| 250 | Elements => Left & Right.Elements (1 .. RN), |
| 251 | Last => Right.Last + 1, |
| 252 | others => <>); |
| 253 | end "&"; |
| 254 | |
| 255 | function "&" (Left, Right : Element_Type) return Vector is |
| 256 | begin |
| 257 | -- We decide that the capacity of the result is the sum of the lengths |
| 258 | -- of the parameters. We could decide to make it larger, but we have no |
| 259 | -- basis for knowing how much larger, so we just allocate the minimum |
| 260 | -- amount of storage. |
| 261 | |
| 262 | -- We must compute the length of the result vector and its last index, |
| 263 | -- but in such a way that overflow is avoided. We must satisfy two |
| 264 | -- constraints: the new length cannot exceed Count_Type'Last (here, we |
| 265 | -- know that that condition is satisfied), and the new Last index cannot |
| 266 | -- exceed Index_Type'Last. |
| 267 | |
| 268 | if Index_Type'First >= Index_Type'Last then |
| 269 | raise Constraint_Error with "new length is out of range"; |
| 270 | end if; |
| 271 | |
| 272 | return Vector'(Capacity => 2, |
| 273 | Elements => (Left, Right), |
| 274 | Last => Index_Type'First + 1, |
| 275 | others => <>); |
| 276 | end "&"; |
| 277 | |
| 278 | --------- |
| 279 | -- "=" -- |
| 280 | --------- |
| 281 | |
| 282 | overriding function "=" (Left, Right : Vector) return Boolean is |
| 283 | begin |
| 284 | if Left'Address = Right'Address then |
| 285 | return True; |
| 286 | end if; |
| 287 | |
| 288 | if Left.Last /= Right.Last then |
| 289 | return False; |
| 290 | end if; |
| 291 | |
| 292 | for J in Count_Type range 1 .. Left.Length loop |
| 293 | if Left.Elements (J) /= Right.Elements (J) then |
| 294 | return False; |
| 295 | end if; |
| 296 | end loop; |
| 297 | |
| 298 | return True; |
| 299 | end "="; |
| 300 | |
| 301 | ------------ |
| 302 | -- Assign -- |
| 303 | ------------ |
| 304 | |
| 305 | procedure Assign (Target : in out Vector; Source : Vector) is |
| 306 | begin |
| 307 | if Target'Address = Source'Address then |
| 308 | return; |
| 309 | end if; |
| 310 | |
| 311 | if Target.Capacity < Source.Length then |
| 312 | raise Capacity_Error -- ??? |
| 313 | with "Target capacity is less than Source length"; |
| 314 | end if; |
| 315 | |
| 316 | Target.Clear; |
| 317 | |
| 318 | Target.Elements (1 .. Source.Length) := |
| 319 | Source.Elements (1 .. Source.Length); |
| 320 | |
| 321 | Target.Last := Source.Last; |
| 322 | end Assign; |
| 323 | |
| 324 | ------------ |
| 325 | -- Append -- |
| 326 | ------------ |
| 327 | |
| 328 | procedure Append (Container : in out Vector; New_Item : Vector) is |
| 329 | begin |
| 330 | if New_Item.Is_Empty then |
| 331 | return; |
| 332 | end if; |
| 333 | |
| 334 | if Container.Last >= Index_Type'Last then |
| 335 | raise Constraint_Error with "vector is already at its maximum length"; |
| 336 | end if; |
| 337 | |
| 338 | Container.Insert (Container.Last + 1, New_Item); |
| 339 | end Append; |
| 340 | |
| 341 | procedure Append |
| 342 | (Container : in out Vector; |
| 343 | New_Item : Element_Type; |
| 344 | Count : Count_Type := 1) |
| 345 | is |
| 346 | begin |
| 347 | if Count = 0 then |
| 348 | return; |
| 349 | end if; |
| 350 | |
| 351 | if Container.Last >= Index_Type'Last then |
| 352 | raise Constraint_Error with "vector is already at its maximum length"; |
| 353 | end if; |
| 354 | |
| 355 | Container.Insert (Container.Last + 1, New_Item, Count); |
| 356 | end Append; |
| 357 | |
| 358 | -------------- |
| 359 | -- Capacity -- |
| 360 | -------------- |
| 361 | |
| 362 | function Capacity (Container : Vector) return Count_Type is |
| 363 | begin |
| 364 | return Container.Elements'Length; |
| 365 | end Capacity; |
| 366 | |
| 367 | ----------- |
| 368 | -- Clear -- |
| 369 | ----------- |
| 370 | |
| 371 | procedure Clear (Container : in out Vector) is |
| 372 | begin |
| 373 | if Container.Busy > 0 then |
| 374 | raise Program_Error with |
| 375 | "attempt to tamper with cursors (vector is busy)"; |
| 376 | end if; |
| 377 | |
| 378 | Container.Last := No_Index; |
| 379 | end Clear; |
| 380 | |
| 381 | ------------------------ |
| 382 | -- Constant_Reference -- |
| 383 | ------------------------ |
| 384 | |
| 385 | function Constant_Reference |
| 386 | (Container : aliased Vector; |
| 387 | Position : Cursor) return Constant_Reference_Type |
| 388 | is |
| 389 | begin |
| 390 | if Position.Container = null then |
| 391 | raise Constraint_Error with "Position cursor has no element"; |
| 392 | end if; |
| 393 | |
| 394 | if Position.Container /= Container'Unrestricted_Access then |
| 395 | raise Program_Error with "Position cursor denotes wrong container"; |
| 396 | end if; |
| 397 | |
| 398 | if Position.Index > Position.Container.Last then |
| 399 | raise Constraint_Error with "Position cursor is out of range"; |
| 400 | end if; |
| 401 | |
| 402 | declare |
| 403 | A : Elements_Array renames Container.Elements; |
| 404 | I : constant Count_Type := To_Array_Index (Position.Index); |
| 405 | begin |
| 406 | return (Element => A (I)'Access); |
| 407 | end; |
| 408 | end Constant_Reference; |
| 409 | |
| 410 | function Constant_Reference |
| 411 | (Container : aliased Vector; |
| 412 | Index : Index_Type) return Constant_Reference_Type |
| 413 | is |
| 414 | begin |
| 415 | if Index > Container.Last then |
| 416 | raise Constraint_Error with "Index is out of range"; |
| 417 | end if; |
| 418 | |
| 419 | declare |
| 420 | A : Elements_Array renames Container.Elements; |
| 421 | I : constant Count_Type := To_Array_Index (Index); |
| 422 | begin |
| 423 | return (Element => A (I)'Access); |
| 424 | end; |
| 425 | end Constant_Reference; |
| 426 | |
| 427 | -------------- |
| 428 | -- Contains -- |
| 429 | -------------- |
| 430 | |
| 431 | function Contains |
| 432 | (Container : Vector; |
| 433 | Item : Element_Type) return Boolean |
| 434 | is |
| 435 | begin |
| 436 | return Find_Index (Container, Item) /= No_Index; |
| 437 | end Contains; |
| 438 | |
| 439 | ---------- |
| 440 | -- Copy -- |
| 441 | ---------- |
| 442 | |
| 443 | function Copy |
| 444 | (Source : Vector; |
| 445 | Capacity : Count_Type := 0) return Vector |
| 446 | is |
| 447 | C : Count_Type; |
| 448 | |
| 449 | begin |
| 450 | if Capacity = 0 then |
| 451 | C := Source.Length; |
| 452 | |
| 453 | elsif Capacity >= Source.Length then |
| 454 | C := Capacity; |
| 455 | |
| 456 | else |
| 457 | raise Capacity_Error |
| 458 | with "Requested capacity is less than Source length"; |
| 459 | end if; |
| 460 | |
| 461 | return Target : Vector (C) do |
| 462 | Target.Elements (1 .. Source.Length) := |
| 463 | Source.Elements (1 .. Source.Length); |
| 464 | |
| 465 | Target.Last := Source.Last; |
| 466 | end return; |
| 467 | end Copy; |
| 468 | |
| 469 | ------------ |
| 470 | -- Delete -- |
| 471 | ------------ |
| 472 | |
| 473 | procedure Delete |
| 474 | (Container : in out Vector; |
| 475 | Index : Extended_Index; |
| 476 | Count : Count_Type := 1) |
| 477 | is |
| 478 | Old_Last : constant Index_Type'Base := Container.Last; |
| 479 | Old_Len : constant Count_Type := Container.Length; |
| 480 | New_Last : Index_Type'Base; |
| 481 | Count2 : Count_Type'Base; -- count of items from Index to Old_Last |
| 482 | Off : Count_Type'Base; -- Index expressed as offset from IT'First |
| 483 | |
| 484 | begin |
| 485 | -- Delete removes items from the vector, the number of which is the |
| 486 | -- minimum of the specified Count and the items (if any) that exist from |
| 487 | -- Index to Container.Last. There are no constraints on the specified |
| 488 | -- value of Count (it can be larger than what's available at this |
| 489 | -- position in the vector, for example), but there are constraints on |
| 490 | -- the allowed values of the Index. |
| 491 | |
| 492 | -- As a precondition on the generic actual Index_Type, the base type |
| 493 | -- must include Index_Type'Pred (Index_Type'First); this is the value |
| 494 | -- that Container.Last assumes when the vector is empty. However, we do |
| 495 | -- not allow that as the value for Index when specifying which items |
| 496 | -- should be deleted, so we must manually check. (That the user is |
| 497 | -- allowed to specify the value at all here is a consequence of the |
| 498 | -- declaration of the Extended_Index subtype, which includes the values |
| 499 | -- in the base range that immediately precede and immediately follow the |
| 500 | -- values in the Index_Type.) |
| 501 | |
| 502 | if Index < Index_Type'First then |
| 503 | raise Constraint_Error with "Index is out of range (too small)"; |
| 504 | end if; |
| 505 | |
| 506 | -- We do allow a value greater than Container.Last to be specified as |
| 507 | -- the Index, but only if it's immediately greater. This allows the |
| 508 | -- corner case of deleting no items from the back end of the vector to |
| 509 | -- be treated as a no-op. (It is assumed that specifying an index value |
| 510 | -- greater than Last + 1 indicates some deeper flaw in the caller's |
| 511 | -- algorithm, so that case is treated as a proper error.) |
| 512 | |
| 513 | if Index > Old_Last then |
| 514 | if Index > Old_Last + 1 then |
| 515 | raise Constraint_Error with "Index is out of range (too large)"; |
| 516 | end if; |
| 517 | |
| 518 | return; |
| 519 | end if; |
| 520 | |
| 521 | -- Here and elsewhere we treat deleting 0 items from the container as a |
| 522 | -- no-op, even when the container is busy, so we simply return. |
| 523 | |
| 524 | if Count = 0 then |
| 525 | return; |
| 526 | end if; |
| 527 | |
| 528 | -- The tampering bits exist to prevent an item from being deleted (or |
| 529 | -- otherwise harmfully manipulated) while it is being visited. Query, |
| 530 | -- Update, and Iterate increment the busy count on entry, and decrement |
| 531 | -- the count on exit. Delete checks the count to determine whether it is |
| 532 | -- being called while the associated callback procedure is executing. |
| 533 | |
| 534 | if Container.Busy > 0 then |
| 535 | raise Program_Error with |
| 536 | "attempt to tamper with cursors (vector is busy)"; |
| 537 | end if; |
| 538 | |
| 539 | -- We first calculate what's available for deletion starting at |
| 540 | -- Index. Here and elsewhere we use the wider of Index_Type'Base and |
| 541 | -- Count_Type'Base as the type for intermediate values. (See function |
| 542 | -- Length for more information.) |
| 543 | |
| 544 | if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then |
| 545 | Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; |
| 546 | |
| 547 | else |
| 548 | Count2 := Count_Type'Base (Old_Last - Index + 1); |
| 549 | end if; |
| 550 | |
| 551 | -- If more elements are requested (Count) for deletion than are |
| 552 | -- available (Count2) for deletion beginning at Index, then everything |
| 553 | -- from Index is deleted. There are no elements to slide down, and so |
| 554 | -- all we need to do is set the value of Container.Last. |
| 555 | |
| 556 | if Count >= Count2 then |
| 557 | Container.Last := Index - 1; |
| 558 | return; |
| 559 | end if; |
| 560 | |
| 561 | -- There are some elements aren't being deleted (the requested count was |
| 562 | -- less than the available count), so we must slide them down to |
| 563 | -- Index. We first calculate the index values of the respective array |
| 564 | -- slices, using the wider of Index_Type'Base and Count_Type'Base as the |
| 565 | -- type for intermediate calculations. |
| 566 | |
| 567 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 568 | Off := Count_Type'Base (Index - Index_Type'First); |
| 569 | New_Last := Old_Last - Index_Type'Base (Count); |
| 570 | |
| 571 | else |
| 572 | Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); |
| 573 | New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); |
| 574 | end if; |
| 575 | |
| 576 | -- The array index values for each slice have already been determined, |
| 577 | -- so we just slide down to Index the elements that weren't deleted. |
| 578 | |
| 579 | declare |
| 580 | EA : Elements_Array renames Container.Elements; |
| 581 | Idx : constant Count_Type := EA'First + Off; |
| 582 | |
| 583 | begin |
| 584 | EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); |
| 585 | Container.Last := New_Last; |
| 586 | end; |
| 587 | end Delete; |
| 588 | |
| 589 | procedure Delete |
| 590 | (Container : in out Vector; |
| 591 | Position : in out Cursor; |
| 592 | Count : Count_Type := 1) |
| 593 | is |
| 594 | pragma Warnings (Off, Position); |
| 595 | |
| 596 | begin |
| 597 | if Position.Container = null then |
| 598 | raise Constraint_Error with "Position cursor has no element"; |
| 599 | end if; |
| 600 | |
| 601 | if Position.Container /= Container'Unrestricted_Access then |
| 602 | raise Program_Error with "Position cursor denotes wrong container"; |
| 603 | end if; |
| 604 | |
| 605 | if Position.Index > Container.Last then |
| 606 | raise Program_Error with "Position index is out of range"; |
| 607 | end if; |
| 608 | |
| 609 | Delete (Container, Position.Index, Count); |
| 610 | Position := No_Element; |
| 611 | end Delete; |
| 612 | |
| 613 | ------------------ |
| 614 | -- Delete_First -- |
| 615 | ------------------ |
| 616 | |
| 617 | procedure Delete_First |
| 618 | (Container : in out Vector; |
| 619 | Count : Count_Type := 1) |
| 620 | is |
| 621 | begin |
| 622 | if Count = 0 then |
| 623 | return; |
| 624 | end if; |
| 625 | |
| 626 | if Count >= Length (Container) then |
| 627 | Clear (Container); |
| 628 | return; |
| 629 | end if; |
| 630 | |
| 631 | Delete (Container, Index_Type'First, Count); |
| 632 | end Delete_First; |
| 633 | |
| 634 | ----------------- |
| 635 | -- Delete_Last -- |
| 636 | ----------------- |
| 637 | |
| 638 | procedure Delete_Last |
| 639 | (Container : in out Vector; |
| 640 | Count : Count_Type := 1) |
| 641 | is |
| 642 | begin |
| 643 | -- It is not permitted to delete items while the container is busy (for |
| 644 | -- example, we're in the middle of a passive iteration). However, we |
| 645 | -- always treat deleting 0 items as a no-op, even when we're busy, so we |
| 646 | -- simply return without checking. |
| 647 | |
| 648 | if Count = 0 then |
| 649 | return; |
| 650 | end if; |
| 651 | |
| 652 | -- The tampering bits exist to prevent an item from being deleted (or |
| 653 | -- otherwise harmfully manipulated) while it is being visited. Query, |
| 654 | -- Update, and Iterate increment the busy count on entry, and decrement |
| 655 | -- the count on exit. Delete_Last checks the count to determine whether |
| 656 | -- it is being called while the associated callback procedure is |
| 657 | -- executing. |
| 658 | |
| 659 | if Container.Busy > 0 then |
| 660 | raise Program_Error with |
| 661 | "attempt to tamper with cursors (vector is busy)"; |
| 662 | end if; |
| 663 | |
| 664 | -- There is no restriction on how large Count can be when deleting |
| 665 | -- items. If it is equal or greater than the current length, then this |
| 666 | -- is equivalent to clearing the vector. (In particular, there's no need |
| 667 | -- for us to actually calculate the new value for Last.) |
| 668 | |
| 669 | -- If the requested count is less than the current length, then we must |
| 670 | -- calculate the new value for Last. For the type we use the widest of |
| 671 | -- Index_Type'Base and Count_Type'Base for the intermediate values of |
| 672 | -- our calculation. (See the comments in Length for more information.) |
| 673 | |
| 674 | if Count >= Container.Length then |
| 675 | Container.Last := No_Index; |
| 676 | |
| 677 | elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 678 | Container.Last := Container.Last - Index_Type'Base (Count); |
| 679 | |
| 680 | else |
| 681 | Container.Last := |
| 682 | Index_Type'Base (Count_Type'Base (Container.Last) - Count); |
| 683 | end if; |
| 684 | end Delete_Last; |
| 685 | |
| 686 | ------------- |
| 687 | -- Element -- |
| 688 | ------------- |
| 689 | |
| 690 | function Element |
| 691 | (Container : Vector; |
| 692 | Index : Index_Type) return Element_Type |
| 693 | is |
| 694 | begin |
| 695 | if Index > Container.Last then |
| 696 | raise Constraint_Error with "Index is out of range"; |
| 697 | else |
| 698 | return Container.Elements (To_Array_Index (Index)); |
| 699 | end if; |
| 700 | end Element; |
| 701 | |
| 702 | function Element (Position : Cursor) return Element_Type is |
| 703 | begin |
| 704 | if Position.Container = null then |
| 705 | raise Constraint_Error with "Position cursor has no element"; |
| 706 | else |
| 707 | return Position.Container.Element (Position.Index); |
| 708 | end if; |
| 709 | end Element; |
| 710 | |
| 711 | -------------- |
| 712 | -- Finalize -- |
| 713 | -------------- |
| 714 | |
| 715 | procedure Finalize (Object : in out Iterator) is |
| 716 | B : Natural renames Object.Container.Busy; |
| 717 | begin |
| 718 | B := B - 1; |
| 719 | end Finalize; |
| 720 | |
| 721 | ---------- |
| 722 | -- Find -- |
| 723 | ---------- |
| 724 | |
| 725 | function Find |
| 726 | (Container : Vector; |
| 727 | Item : Element_Type; |
| 728 | Position : Cursor := No_Element) return Cursor |
| 729 | is |
| 730 | begin |
| 731 | if Position.Container /= null then |
| 732 | if Position.Container /= Container'Unrestricted_Access then |
| 733 | raise Program_Error with "Position cursor denotes wrong container"; |
| 734 | end if; |
| 735 | |
| 736 | if Position.Index > Container.Last then |
| 737 | raise Program_Error with "Position index is out of range"; |
| 738 | end if; |
| 739 | end if; |
| 740 | |
| 741 | for J in Position.Index .. Container.Last loop |
| 742 | if Container.Elements (To_Array_Index (J)) = Item then |
| 743 | return (Container'Unrestricted_Access, J); |
| 744 | end if; |
| 745 | end loop; |
| 746 | |
| 747 | return No_Element; |
| 748 | end Find; |
| 749 | |
| 750 | ---------------- |
| 751 | -- Find_Index -- |
| 752 | ---------------- |
| 753 | |
| 754 | function Find_Index |
| 755 | (Container : Vector; |
| 756 | Item : Element_Type; |
| 757 | Index : Index_Type := Index_Type'First) return Extended_Index |
| 758 | is |
| 759 | begin |
| 760 | for Indx in Index .. Container.Last loop |
| 761 | if Container.Elements (To_Array_Index (Indx)) = Item then |
| 762 | return Indx; |
| 763 | end if; |
| 764 | end loop; |
| 765 | |
| 766 | return No_Index; |
| 767 | end Find_Index; |
| 768 | |
| 769 | ----------- |
| 770 | -- First -- |
| 771 | ----------- |
| 772 | |
| 773 | function First (Container : Vector) return Cursor is |
| 774 | begin |
| 775 | if Is_Empty (Container) then |
| 776 | return No_Element; |
| 777 | else |
| 778 | return (Container'Unrestricted_Access, Index_Type'First); |
| 779 | end if; |
| 780 | end First; |
| 781 | |
| 782 | function First (Object : Iterator) return Cursor is |
| 783 | begin |
| 784 | -- The value of the iterator object's Index component influences the |
| 785 | -- behavior of the First (and Last) selector function. |
| 786 | |
| 787 | -- When the Index component is No_Index, this means the iterator |
| 788 | -- object was constructed without a start expression, in which case the |
| 789 | -- (forward) iteration starts from the (logical) beginning of the entire |
| 790 | -- sequence of items (corresponding to Container.First, for a forward |
| 791 | -- iterator). |
| 792 | |
| 793 | -- Otherwise, this is iteration over a partial sequence of items. |
| 794 | -- When the Index component isn't No_Index, the iterator object was |
| 795 | -- constructed with a start expression, that specifies the position |
| 796 | -- from which the (forward) partial iteration begins. |
| 797 | |
| 798 | if Object.Index = No_Index then |
| 799 | return First (Object.Container.all); |
| 800 | else |
| 801 | return Cursor'(Object.Container, Object.Index); |
| 802 | end if; |
| 803 | end First; |
| 804 | |
| 805 | ------------------- |
| 806 | -- First_Element -- |
| 807 | ------------------- |
| 808 | |
| 809 | function First_Element (Container : Vector) return Element_Type is |
| 810 | begin |
| 811 | if Container.Last = No_Index then |
| 812 | raise Constraint_Error with "Container is empty"; |
| 813 | else |
| 814 | return Container.Elements (To_Array_Index (Index_Type'First)); |
| 815 | end if; |
| 816 | end First_Element; |
| 817 | |
| 818 | ----------------- |
| 819 | -- First_Index -- |
| 820 | ----------------- |
| 821 | |
| 822 | function First_Index (Container : Vector) return Index_Type is |
| 823 | pragma Unreferenced (Container); |
| 824 | begin |
| 825 | return Index_Type'First; |
| 826 | end First_Index; |
| 827 | |
| 828 | --------------------- |
| 829 | -- Generic_Sorting -- |
| 830 | --------------------- |
| 831 | |
| 832 | package body Generic_Sorting is |
| 833 | |
| 834 | --------------- |
| 835 | -- Is_Sorted -- |
| 836 | --------------- |
| 837 | |
| 838 | function Is_Sorted (Container : Vector) return Boolean is |
| 839 | begin |
| 840 | if Container.Last <= Index_Type'First then |
| 841 | return True; |
| 842 | end if; |
| 843 | |
| 844 | declare |
| 845 | EA : Elements_Array renames Container.Elements; |
| 846 | begin |
| 847 | for J in 1 .. Container.Length - 1 loop |
| 848 | if EA (J + 1) < EA (J) then |
| 849 | return False; |
| 850 | end if; |
| 851 | end loop; |
| 852 | end; |
| 853 | |
| 854 | return True; |
| 855 | end Is_Sorted; |
| 856 | |
| 857 | ----------- |
| 858 | -- Merge -- |
| 859 | ----------- |
| 860 | |
| 861 | procedure Merge (Target, Source : in out Vector) is |
| 862 | I, J : Count_Type; |
| 863 | |
| 864 | begin |
| 865 | |
| 866 | -- The semantics of Merge changed slightly per AI05-0021. It was |
| 867 | -- originally the case that if Target and Source denoted the same |
| 868 | -- container object, then the GNAT implementation of Merge did |
| 869 | -- nothing. However, it was argued that RM05 did not precisely |
| 870 | -- specify the semantics for this corner case. The decision of the |
| 871 | -- ARG was that if Target and Source denote the same non-empty |
| 872 | -- container object, then Program_Error is raised. |
| 873 | |
| 874 | if Source.Is_Empty then |
| 875 | return; |
| 876 | end if; |
| 877 | |
| 878 | if Target'Address = Source'Address then |
| 879 | raise Program_Error with |
| 880 | "Target and Source denote same non-empty container"; |
| 881 | end if; |
| 882 | |
| 883 | if Target.Is_Empty then |
| 884 | Move (Target => Target, Source => Source); |
| 885 | return; |
| 886 | end if; |
| 887 | |
| 888 | if Source.Busy > 0 then |
| 889 | raise Program_Error with |
| 890 | "attempt to tamper with cursors (vector is busy)"; |
| 891 | end if; |
| 892 | |
| 893 | I := Target.Length; |
| 894 | Target.Set_Length (I + Source.Length); |
| 895 | |
| 896 | declare |
| 897 | TA : Elements_Array renames Target.Elements; |
| 898 | SA : Elements_Array renames Source.Elements; |
| 899 | |
| 900 | begin |
| 901 | J := Target.Length; |
| 902 | while not Source.Is_Empty loop |
| 903 | pragma Assert (Source.Length <= 1 |
| 904 | or else not (SA (Source.Length) < |
| 905 | SA (Source.Length - 1))); |
| 906 | |
| 907 | if I = 0 then |
| 908 | TA (1 .. J) := SA (1 .. Source.Length); |
| 909 | Source.Last := No_Index; |
| 910 | return; |
| 911 | end if; |
| 912 | |
| 913 | pragma Assert (I <= 1 |
| 914 | or else not (TA (I) < TA (I - 1))); |
| 915 | |
| 916 | if SA (Source.Length) < TA (I) then |
| 917 | TA (J) := TA (I); |
| 918 | I := I - 1; |
| 919 | |
| 920 | else |
| 921 | TA (J) := SA (Source.Length); |
| 922 | Source.Last := Source.Last - 1; |
| 923 | end if; |
| 924 | |
| 925 | J := J - 1; |
| 926 | end loop; |
| 927 | end; |
| 928 | end Merge; |
| 929 | |
| 930 | ---------- |
| 931 | -- Sort -- |
| 932 | ---------- |
| 933 | |
| 934 | procedure Sort (Container : in out Vector) is |
| 935 | procedure Sort is |
| 936 | new Generic_Array_Sort |
| 937 | (Index_Type => Count_Type, |
| 938 | Element_Type => Element_Type, |
| 939 | Array_Type => Elements_Array, |
| 940 | "<" => "<"); |
| 941 | |
| 942 | begin |
| 943 | if Container.Last <= Index_Type'First then |
| 944 | return; |
| 945 | end if; |
| 946 | |
| 947 | -- The exception behavior for the vector container must match that |
| 948 | -- for the list container, so we check for cursor tampering here |
| 949 | -- (which will catch more things) instead of for element tampering |
| 950 | -- (which will catch fewer things). It's true that the elements of |
| 951 | -- this vector container could be safely moved around while (say) an |
| 952 | -- iteration is taking place (iteration only increments the busy |
| 953 | -- counter), and so technically all we would need here is a test for |
| 954 | -- element tampering (indicated by the lock counter), that's simply |
| 955 | -- an artifact of our array-based implementation. Logically Sort |
| 956 | -- requires a check for cursor tampering. |
| 957 | |
| 958 | if Container.Busy > 0 then |
| 959 | raise Program_Error with |
| 960 | "attempt to tamper with cursors (vector is busy)"; |
| 961 | end if; |
| 962 | |
| 963 | Sort (Container.Elements (1 .. Container.Length)); |
| 964 | end Sort; |
| 965 | |
| 966 | end Generic_Sorting; |
| 967 | |
| 968 | ----------------- |
| 969 | -- Has_Element -- |
| 970 | ----------------- |
| 971 | |
| 972 | function Has_Element (Position : Cursor) return Boolean is |
| 973 | begin |
| 974 | if Position.Container = null then |
| 975 | return False; |
| 976 | end if; |
| 977 | |
| 978 | return Position.Index <= Position.Container.Last; |
| 979 | end Has_Element; |
| 980 | |
| 981 | ------------ |
| 982 | -- Insert -- |
| 983 | ------------ |
| 984 | |
| 985 | procedure Insert |
| 986 | (Container : in out Vector; |
| 987 | Before : Extended_Index; |
| 988 | New_Item : Element_Type; |
| 989 | Count : Count_Type := 1) |
| 990 | is |
| 991 | EA : Elements_Array renames Container.Elements; |
| 992 | Old_Length : constant Count_Type := Container.Length; |
| 993 | |
| 994 | Max_Length : Count_Type'Base; -- determined from range of Index_Type |
| 995 | New_Length : Count_Type'Base; -- sum of current length and Count |
| 996 | |
| 997 | Index : Index_Type'Base; -- scratch for intermediate values |
| 998 | J : Count_Type'Base; -- scratch |
| 999 | |
| 1000 | begin |
| 1001 | -- As a precondition on the generic actual Index_Type, the base type |
| 1002 | -- must include Index_Type'Pred (Index_Type'First); this is the value |
| 1003 | -- that Container.Last assumes when the vector is empty. However, we do |
| 1004 | -- not allow that as the value for Index when specifying where the new |
| 1005 | -- items should be inserted, so we must manually check. (That the user |
| 1006 | -- is allowed to specify the value at all here is a consequence of the |
| 1007 | -- declaration of the Extended_Index subtype, which includes the values |
| 1008 | -- in the base range that immediately precede and immediately follow the |
| 1009 | -- values in the Index_Type.) |
| 1010 | |
| 1011 | if Before < Index_Type'First then |
| 1012 | raise Constraint_Error with |
| 1013 | "Before index is out of range (too small)"; |
| 1014 | end if; |
| 1015 | |
| 1016 | -- We do allow a value greater than Container.Last to be specified as |
| 1017 | -- the Index, but only if it's immediately greater. This allows for the |
| 1018 | -- case of appending items to the back end of the vector. (It is assumed |
| 1019 | -- that specifying an index value greater than Last + 1 indicates some |
| 1020 | -- deeper flaw in the caller's algorithm, so that case is treated as a |
| 1021 | -- proper error.) |
| 1022 | |
| 1023 | if Before > Container.Last |
| 1024 | and then Before > Container.Last + 1 |
| 1025 | then |
| 1026 | raise Constraint_Error with |
| 1027 | "Before index is out of range (too large)"; |
| 1028 | end if; |
| 1029 | |
| 1030 | -- We treat inserting 0 items into the container as a no-op, even when |
| 1031 | -- the container is busy, so we simply return. |
| 1032 | |
| 1033 | if Count = 0 then |
| 1034 | return; |
| 1035 | end if; |
| 1036 | |
| 1037 | -- There are two constraints we need to satisfy. The first constraint is |
| 1038 | -- that a container cannot have more than Count_Type'Last elements, so |
| 1039 | -- we must check the sum of the current length and the insertion |
| 1040 | -- count. Note that we cannot simply add these values, because of the |
| 1041 | -- possibility of overflow. |
| 1042 | |
| 1043 | if Old_Length > Count_Type'Last - Count then |
| 1044 | raise Constraint_Error with "Count is out of range"; |
| 1045 | end if; |
| 1046 | |
| 1047 | -- It is now safe compute the length of the new vector, without fear of |
| 1048 | -- overflow. |
| 1049 | |
| 1050 | New_Length := Old_Length + Count; |
| 1051 | |
| 1052 | -- The second constraint is that the new Last index value cannot exceed |
| 1053 | -- Index_Type'Last. In each branch below, we calculate the maximum |
| 1054 | -- length (computed from the range of values in Index_Type), and then |
| 1055 | -- compare the new length to the maximum length. If the new length is |
| 1056 | -- acceptable, then we compute the new last index from that. |
| 1057 | |
| 1058 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1059 | -- We have to handle the case when there might be more values in the |
| 1060 | -- range of Index_Type than in the range of Count_Type. |
| 1061 | |
| 1062 | if Index_Type'First <= 0 then |
| 1063 | -- We know that No_Index (the same as Index_Type'First - 1) is |
| 1064 | -- less than 0, so it is safe to compute the following sum without |
| 1065 | -- fear of overflow. |
| 1066 | |
| 1067 | Index := No_Index + Index_Type'Base (Count_Type'Last); |
| 1068 | |
| 1069 | if Index <= Index_Type'Last then |
| 1070 | -- We have determined that range of Index_Type has at least as |
| 1071 | -- many values as in Count_Type, so Count_Type'Last is the |
| 1072 | -- maximum number of items that are allowed. |
| 1073 | |
| 1074 | Max_Length := Count_Type'Last; |
| 1075 | |
| 1076 | else |
| 1077 | -- The range of Index_Type has fewer values than in Count_Type, |
| 1078 | -- so the maximum number of items is computed from the range of |
| 1079 | -- the Index_Type. |
| 1080 | |
| 1081 | Max_Length := Count_Type'Base (Index_Type'Last - No_Index); |
| 1082 | end if; |
| 1083 | |
| 1084 | else |
| 1085 | -- No_Index is equal or greater than 0, so we can safely compute |
| 1086 | -- the difference without fear of overflow (which we would have to |
| 1087 | -- worry about if No_Index were less than 0, but that case is |
| 1088 | -- handled above). |
| 1089 | |
| 1090 | Max_Length := Count_Type'Base (Index_Type'Last - No_Index); |
| 1091 | end if; |
| 1092 | |
| 1093 | elsif Index_Type'First <= 0 then |
| 1094 | -- We know that No_Index (the same as Index_Type'First - 1) is less |
| 1095 | -- than 0, so it is safe to compute the following sum without fear of |
| 1096 | -- overflow. |
| 1097 | |
| 1098 | J := Count_Type'Base (No_Index) + Count_Type'Last; |
| 1099 | |
| 1100 | if J <= Count_Type'Base (Index_Type'Last) then |
| 1101 | -- We have determined that range of Index_Type has at least as |
| 1102 | -- many values as in Count_Type, so Count_Type'Last is the maximum |
| 1103 | -- number of items that are allowed. |
| 1104 | |
| 1105 | Max_Length := Count_Type'Last; |
| 1106 | |
| 1107 | else |
| 1108 | -- The range of Index_Type has fewer values than Count_Type does, |
| 1109 | -- so the maximum number of items is computed from the range of |
| 1110 | -- the Index_Type. |
| 1111 | |
| 1112 | Max_Length := |
| 1113 | Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); |
| 1114 | end if; |
| 1115 | |
| 1116 | else |
| 1117 | -- No_Index is equal or greater than 0, so we can safely compute the |
| 1118 | -- difference without fear of overflow (which we would have to worry |
| 1119 | -- about if No_Index were less than 0, but that case is handled |
| 1120 | -- above). |
| 1121 | |
| 1122 | Max_Length := |
| 1123 | Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); |
| 1124 | end if; |
| 1125 | |
| 1126 | -- We have just computed the maximum length (number of items). We must |
| 1127 | -- now compare the requested length to the maximum length, as we do not |
| 1128 | -- allow a vector expand beyond the maximum (because that would create |
| 1129 | -- an internal array with a last index value greater than |
| 1130 | -- Index_Type'Last, with no way to index those elements). |
| 1131 | |
| 1132 | if New_Length > Max_Length then |
| 1133 | raise Constraint_Error with "Count is out of range"; |
| 1134 | end if; |
| 1135 | |
| 1136 | -- The tampering bits exist to prevent an item from being harmfully |
| 1137 | -- manipulated while it is being visited. Query, Update, and Iterate |
| 1138 | -- increment the busy count on entry, and decrement the count on |
| 1139 | -- exit. Insert checks the count to determine whether it is being called |
| 1140 | -- while the associated callback procedure is executing. |
| 1141 | |
| 1142 | if Container.Busy > 0 then |
| 1143 | raise Program_Error with |
| 1144 | "attempt to tamper with cursors (vector is busy)"; |
| 1145 | end if; |
| 1146 | |
| 1147 | if New_Length > Container.Capacity then |
| 1148 | raise Capacity_Error with "New length is larger than capacity"; |
| 1149 | end if; |
| 1150 | |
| 1151 | J := To_Array_Index (Before); |
| 1152 | |
| 1153 | if Before > Container.Last then |
| 1154 | -- The new items are being appended to the vector, so no |
| 1155 | -- sliding of existing elements is required. |
| 1156 | |
| 1157 | EA (J .. New_Length) := (others => New_Item); |
| 1158 | |
| 1159 | else |
| 1160 | -- The new items are being inserted before some existing |
| 1161 | -- elements, so we must slide the existing elements up to their |
| 1162 | -- new home. |
| 1163 | |
| 1164 | EA (J + Count .. New_Length) := EA (J .. Old_Length); |
| 1165 | EA (J .. J + Count - 1) := (others => New_Item); |
| 1166 | end if; |
| 1167 | |
| 1168 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1169 | Container.Last := No_Index + Index_Type'Base (New_Length); |
| 1170 | |
| 1171 | else |
| 1172 | Container.Last := |
| 1173 | Index_Type'Base (Count_Type'Base (No_Index) + New_Length); |
| 1174 | end if; |
| 1175 | end Insert; |
| 1176 | |
| 1177 | procedure Insert |
| 1178 | (Container : in out Vector; |
| 1179 | Before : Extended_Index; |
| 1180 | New_Item : Vector) |
| 1181 | is |
| 1182 | N : constant Count_Type := Length (New_Item); |
| 1183 | B : Count_Type; -- index Before converted to Count_Type |
| 1184 | |
| 1185 | begin |
| 1186 | -- Use Insert_Space to create the "hole" (the destination slice) into |
| 1187 | -- which we copy the source items. |
| 1188 | |
| 1189 | Insert_Space (Container, Before, Count => N); |
| 1190 | |
| 1191 | if N = 0 then |
| 1192 | -- There's nothing else to do here (vetting of parameters was |
| 1193 | -- performed already in Insert_Space), so we simply return. |
| 1194 | |
| 1195 | return; |
| 1196 | end if; |
| 1197 | |
| 1198 | B := To_Array_Index (Before); |
| 1199 | |
| 1200 | if Container'Address /= New_Item'Address then |
| 1201 | -- This is the simple case. New_Item denotes an object different |
| 1202 | -- from Container, so there's nothing special we need to do to copy |
| 1203 | -- the source items to their destination, because all of the source |
| 1204 | -- items are contiguous. |
| 1205 | |
| 1206 | Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N); |
| 1207 | return; |
| 1208 | end if; |
| 1209 | |
| 1210 | -- We refer to array index value Before + N - 1 as J. This is the last |
| 1211 | -- index value of the destination slice. |
| 1212 | |
| 1213 | -- New_Item denotes the same object as Container, so an insertion has |
| 1214 | -- potentially split the source items. The destination is always the |
| 1215 | -- range [Before, J], but the source is [Index_Type'First, Before) and |
| 1216 | -- (J, Container.Last]. We perform the copy in two steps, using each of |
| 1217 | -- the two slices of the source items. |
| 1218 | |
| 1219 | declare |
| 1220 | subtype Src_Index_Subtype is Count_Type'Base range 1 .. B - 1; |
| 1221 | |
| 1222 | Src : Elements_Array renames Container.Elements (Src_Index_Subtype); |
| 1223 | |
| 1224 | begin |
| 1225 | -- We first copy the source items that precede the space we |
| 1226 | -- inserted. (If Before equals Index_Type'First, then this first |
| 1227 | -- source slice will be empty, which is harmless.) |
| 1228 | |
| 1229 | Container.Elements (B .. B + Src'Length - 1) := Src; |
| 1230 | end; |
| 1231 | |
| 1232 | declare |
| 1233 | subtype Src_Index_Subtype is Count_Type'Base range |
| 1234 | B + N .. Container.Length; |
| 1235 | |
| 1236 | Src : Elements_Array renames Container.Elements (Src_Index_Subtype); |
| 1237 | |
| 1238 | begin |
| 1239 | -- We next copy the source items that follow the space we inserted. |
| 1240 | |
| 1241 | Container.Elements (B + N - Src'Length .. B + N - 1) := Src; |
| 1242 | end; |
| 1243 | end Insert; |
| 1244 | |
| 1245 | procedure Insert |
| 1246 | (Container : in out Vector; |
| 1247 | Before : Cursor; |
| 1248 | New_Item : Vector) |
| 1249 | is |
| 1250 | Index : Index_Type'Base; |
| 1251 | |
| 1252 | begin |
| 1253 | if Before.Container /= null |
| 1254 | and then Before.Container /= Container'Unchecked_Access |
| 1255 | then |
| 1256 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1257 | end if; |
| 1258 | |
| 1259 | if Is_Empty (New_Item) then |
| 1260 | return; |
| 1261 | end if; |
| 1262 | |
| 1263 | if Before.Container = null |
| 1264 | or else Before.Index > Container.Last |
| 1265 | then |
| 1266 | if Container.Last = Index_Type'Last then |
| 1267 | raise Constraint_Error with |
| 1268 | "vector is already at its maximum length"; |
| 1269 | end if; |
| 1270 | |
| 1271 | Index := Container.Last + 1; |
| 1272 | |
| 1273 | else |
| 1274 | Index := Before.Index; |
| 1275 | end if; |
| 1276 | |
| 1277 | Insert (Container, Index, New_Item); |
| 1278 | end Insert; |
| 1279 | |
| 1280 | procedure Insert |
| 1281 | (Container : in out Vector; |
| 1282 | Before : Cursor; |
| 1283 | New_Item : Vector; |
| 1284 | Position : out Cursor) |
| 1285 | is |
| 1286 | Index : Index_Type'Base; |
| 1287 | |
| 1288 | begin |
| 1289 | if Before.Container /= null |
| 1290 | and then Before.Container /= Container'Unchecked_Access |
| 1291 | then |
| 1292 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1293 | end if; |
| 1294 | |
| 1295 | if Is_Empty (New_Item) then |
| 1296 | if Before.Container = null |
| 1297 | or else Before.Index > Container.Last |
| 1298 | then |
| 1299 | Position := No_Element; |
| 1300 | else |
| 1301 | Position := (Container'Unchecked_Access, Before.Index); |
| 1302 | end if; |
| 1303 | |
| 1304 | return; |
| 1305 | end if; |
| 1306 | |
| 1307 | if Before.Container = null |
| 1308 | or else Before.Index > Container.Last |
| 1309 | then |
| 1310 | if Container.Last = Index_Type'Last then |
| 1311 | raise Constraint_Error with |
| 1312 | "vector is already at its maximum length"; |
| 1313 | end if; |
| 1314 | |
| 1315 | Index := Container.Last + 1; |
| 1316 | |
| 1317 | else |
| 1318 | Index := Before.Index; |
| 1319 | end if; |
| 1320 | |
| 1321 | Insert (Container, Index, New_Item); |
| 1322 | |
| 1323 | Position := Cursor'(Container'Unchecked_Access, Index); |
| 1324 | end Insert; |
| 1325 | |
| 1326 | procedure Insert |
| 1327 | (Container : in out Vector; |
| 1328 | Before : Cursor; |
| 1329 | New_Item : Element_Type; |
| 1330 | Count : Count_Type := 1) |
| 1331 | is |
| 1332 | Index : Index_Type'Base; |
| 1333 | |
| 1334 | begin |
| 1335 | if Before.Container /= null |
| 1336 | and then Before.Container /= Container'Unchecked_Access |
| 1337 | then |
| 1338 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1339 | end if; |
| 1340 | |
| 1341 | if Count = 0 then |
| 1342 | return; |
| 1343 | end if; |
| 1344 | |
| 1345 | if Before.Container = null |
| 1346 | or else Before.Index > Container.Last |
| 1347 | then |
| 1348 | if Container.Last = Index_Type'Last then |
| 1349 | raise Constraint_Error with |
| 1350 | "vector is already at its maximum length"; |
| 1351 | end if; |
| 1352 | |
| 1353 | Index := Container.Last + 1; |
| 1354 | |
| 1355 | else |
| 1356 | Index := Before.Index; |
| 1357 | end if; |
| 1358 | |
| 1359 | Insert (Container, Index, New_Item, Count); |
| 1360 | end Insert; |
| 1361 | |
| 1362 | procedure Insert |
| 1363 | (Container : in out Vector; |
| 1364 | Before : Cursor; |
| 1365 | New_Item : Element_Type; |
| 1366 | Position : out Cursor; |
| 1367 | Count : Count_Type := 1) |
| 1368 | is |
| 1369 | Index : Index_Type'Base; |
| 1370 | |
| 1371 | begin |
| 1372 | if Before.Container /= null |
| 1373 | and then Before.Container /= Container'Unchecked_Access |
| 1374 | then |
| 1375 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1376 | end if; |
| 1377 | |
| 1378 | if Count = 0 then |
| 1379 | if Before.Container = null |
| 1380 | or else Before.Index > Container.Last |
| 1381 | then |
| 1382 | Position := No_Element; |
| 1383 | else |
| 1384 | Position := (Container'Unchecked_Access, Before.Index); |
| 1385 | end if; |
| 1386 | |
| 1387 | return; |
| 1388 | end if; |
| 1389 | |
| 1390 | if Before.Container = null |
| 1391 | or else Before.Index > Container.Last |
| 1392 | then |
| 1393 | if Container.Last = Index_Type'Last then |
| 1394 | raise Constraint_Error with |
| 1395 | "vector is already at its maximum length"; |
| 1396 | end if; |
| 1397 | |
| 1398 | Index := Container.Last + 1; |
| 1399 | |
| 1400 | else |
| 1401 | Index := Before.Index; |
| 1402 | end if; |
| 1403 | |
| 1404 | Insert (Container, Index, New_Item, Count); |
| 1405 | |
| 1406 | Position := Cursor'(Container'Unchecked_Access, Index); |
| 1407 | end Insert; |
| 1408 | |
| 1409 | procedure Insert |
| 1410 | (Container : in out Vector; |
| 1411 | Before : Extended_Index; |
| 1412 | Count : Count_Type := 1) |
| 1413 | is |
| 1414 | New_Item : Element_Type; -- Default-initialized value |
| 1415 | pragma Warnings (Off, New_Item); |
| 1416 | |
| 1417 | begin |
| 1418 | Insert (Container, Before, New_Item, Count); |
| 1419 | end Insert; |
| 1420 | |
| 1421 | procedure Insert |
| 1422 | (Container : in out Vector; |
| 1423 | Before : Cursor; |
| 1424 | Position : out Cursor; |
| 1425 | Count : Count_Type := 1) |
| 1426 | is |
| 1427 | New_Item : Element_Type; -- Default-initialized value |
| 1428 | pragma Warnings (Off, New_Item); |
| 1429 | |
| 1430 | begin |
| 1431 | Insert (Container, Before, New_Item, Position, Count); |
| 1432 | end Insert; |
| 1433 | |
| 1434 | ------------------ |
| 1435 | -- Insert_Space -- |
| 1436 | ------------------ |
| 1437 | |
| 1438 | procedure Insert_Space |
| 1439 | (Container : in out Vector; |
| 1440 | Before : Extended_Index; |
| 1441 | Count : Count_Type := 1) |
| 1442 | is |
| 1443 | EA : Elements_Array renames Container.Elements; |
| 1444 | Old_Length : constant Count_Type := Container.Length; |
| 1445 | |
| 1446 | Max_Length : Count_Type'Base; -- determined from range of Index_Type |
| 1447 | New_Length : Count_Type'Base; -- sum of current length and Count |
| 1448 | |
| 1449 | Index : Index_Type'Base; -- scratch for intermediate values |
| 1450 | J : Count_Type'Base; -- scratch |
| 1451 | |
| 1452 | begin |
| 1453 | -- As a precondition on the generic actual Index_Type, the base type |
| 1454 | -- must include Index_Type'Pred (Index_Type'First); this is the value |
| 1455 | -- that Container.Last assumes when the vector is empty. However, we do |
| 1456 | -- not allow that as the value for Index when specifying where the new |
| 1457 | -- items should be inserted, so we must manually check. (That the user |
| 1458 | -- is allowed to specify the value at all here is a consequence of the |
| 1459 | -- declaration of the Extended_Index subtype, which includes the values |
| 1460 | -- in the base range that immediately precede and immediately follow the |
| 1461 | -- values in the Index_Type.) |
| 1462 | |
| 1463 | if Before < Index_Type'First then |
| 1464 | raise Constraint_Error with |
| 1465 | "Before index is out of range (too small)"; |
| 1466 | end if; |
| 1467 | |
| 1468 | -- We do allow a value greater than Container.Last to be specified as |
| 1469 | -- the Index, but only if it's immediately greater. This allows for the |
| 1470 | -- case of appending items to the back end of the vector. (It is assumed |
| 1471 | -- that specifying an index value greater than Last + 1 indicates some |
| 1472 | -- deeper flaw in the caller's algorithm, so that case is treated as a |
| 1473 | -- proper error.) |
| 1474 | |
| 1475 | if Before > Container.Last |
| 1476 | and then Before > Container.Last + 1 |
| 1477 | then |
| 1478 | raise Constraint_Error with |
| 1479 | "Before index is out of range (too large)"; |
| 1480 | end if; |
| 1481 | |
| 1482 | -- We treat inserting 0 items into the container as a no-op, even when |
| 1483 | -- the container is busy, so we simply return. |
| 1484 | |
| 1485 | if Count = 0 then |
| 1486 | return; |
| 1487 | end if; |
| 1488 | |
| 1489 | -- There are two constraints we need to satisfy. The first constraint is |
| 1490 | -- that a container cannot have more than Count_Type'Last elements, so |
| 1491 | -- we must check the sum of the current length and the insertion count. |
| 1492 | -- Note that we cannot simply add these values, because of the |
| 1493 | -- possibility of overflow. |
| 1494 | |
| 1495 | if Old_Length > Count_Type'Last - Count then |
| 1496 | raise Constraint_Error with "Count is out of range"; |
| 1497 | end if; |
| 1498 | |
| 1499 | -- It is now safe compute the length of the new vector, without fear of |
| 1500 | -- overflow. |
| 1501 | |
| 1502 | New_Length := Old_Length + Count; |
| 1503 | |
| 1504 | -- The second constraint is that the new Last index value cannot exceed |
| 1505 | -- Index_Type'Last. In each branch below, we calculate the maximum |
| 1506 | -- length (computed from the range of values in Index_Type), and then |
| 1507 | -- compare the new length to the maximum length. If the new length is |
| 1508 | -- acceptable, then we compute the new last index from that. |
| 1509 | |
| 1510 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1511 | -- We have to handle the case when there might be more values in the |
| 1512 | -- range of Index_Type than in the range of Count_Type. |
| 1513 | |
| 1514 | if Index_Type'First <= 0 then |
| 1515 | -- We know that No_Index (the same as Index_Type'First - 1) is |
| 1516 | -- less than 0, so it is safe to compute the following sum without |
| 1517 | -- fear of overflow. |
| 1518 | |
| 1519 | Index := No_Index + Index_Type'Base (Count_Type'Last); |
| 1520 | |
| 1521 | if Index <= Index_Type'Last then |
| 1522 | -- We have determined that range of Index_Type has at least as |
| 1523 | -- many values as in Count_Type, so Count_Type'Last is the |
| 1524 | -- maximum number of items that are allowed. |
| 1525 | |
| 1526 | Max_Length := Count_Type'Last; |
| 1527 | |
| 1528 | else |
| 1529 | -- The range of Index_Type has fewer values than in Count_Type, |
| 1530 | -- so the maximum number of items is computed from the range of |
| 1531 | -- the Index_Type. |
| 1532 | |
| 1533 | Max_Length := Count_Type'Base (Index_Type'Last - No_Index); |
| 1534 | end if; |
| 1535 | |
| 1536 | else |
| 1537 | -- No_Index is equal or greater than 0, so we can safely compute |
| 1538 | -- the difference without fear of overflow (which we would have to |
| 1539 | -- worry about if No_Index were less than 0, but that case is |
| 1540 | -- handled above). |
| 1541 | |
| 1542 | Max_Length := Count_Type'Base (Index_Type'Last - No_Index); |
| 1543 | end if; |
| 1544 | |
| 1545 | elsif Index_Type'First <= 0 then |
| 1546 | -- We know that No_Index (the same as Index_Type'First - 1) is less |
| 1547 | -- than 0, so it is safe to compute the following sum without fear of |
| 1548 | -- overflow. |
| 1549 | |
| 1550 | J := Count_Type'Base (No_Index) + Count_Type'Last; |
| 1551 | |
| 1552 | if J <= Count_Type'Base (Index_Type'Last) then |
| 1553 | -- We have determined that range of Index_Type has at least as |
| 1554 | -- many values as in Count_Type, so Count_Type'Last is the maximum |
| 1555 | -- number of items that are allowed. |
| 1556 | |
| 1557 | Max_Length := Count_Type'Last; |
| 1558 | |
| 1559 | else |
| 1560 | -- The range of Index_Type has fewer values than Count_Type does, |
| 1561 | -- so the maximum number of items is computed from the range of |
| 1562 | -- the Index_Type. |
| 1563 | |
| 1564 | Max_Length := |
| 1565 | Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); |
| 1566 | end if; |
| 1567 | |
| 1568 | else |
| 1569 | -- No_Index is equal or greater than 0, so we can safely compute the |
| 1570 | -- difference without fear of overflow (which we would have to worry |
| 1571 | -- about if No_Index were less than 0, but that case is handled |
| 1572 | -- above). |
| 1573 | |
| 1574 | Max_Length := |
| 1575 | Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); |
| 1576 | end if; |
| 1577 | |
| 1578 | -- We have just computed the maximum length (number of items). We must |
| 1579 | -- now compare the requested length to the maximum length, as we do not |
| 1580 | -- allow a vector expand beyond the maximum (because that would create |
| 1581 | -- an internal array with a last index value greater than |
| 1582 | -- Index_Type'Last, with no way to index those elements). |
| 1583 | |
| 1584 | if New_Length > Max_Length then |
| 1585 | raise Constraint_Error with "Count is out of range"; |
| 1586 | end if; |
| 1587 | |
| 1588 | -- The tampering bits exist to prevent an item from being harmfully |
| 1589 | -- manipulated while it is being visited. Query, Update, and Iterate |
| 1590 | -- increment the busy count on entry, and decrement the count on |
| 1591 | -- exit. Insert checks the count to determine whether it is being called |
| 1592 | -- while the associated callback procedure is executing. |
| 1593 | |
| 1594 | if Container.Busy > 0 then |
| 1595 | raise Program_Error with |
| 1596 | "attempt to tamper with cursors (vector is busy)"; |
| 1597 | end if; |
| 1598 | |
| 1599 | -- An internal array has already been allocated, so we need to check |
| 1600 | -- whether there is enough unused storage for the new items. |
| 1601 | |
| 1602 | if New_Length > Container.Capacity then |
| 1603 | raise Capacity_Error with "New length is larger than capacity"; |
| 1604 | end if; |
| 1605 | |
| 1606 | -- In this case, we're inserting space into a vector that has already |
| 1607 | -- allocated an internal array, and the existing array has enough |
| 1608 | -- unused storage for the new items. |
| 1609 | |
| 1610 | if Before <= Container.Last then |
| 1611 | -- The space is being inserted before some existing elements, |
| 1612 | -- so we must slide the existing elements up to their new home. |
| 1613 | |
| 1614 | J := To_Array_Index (Before); |
| 1615 | EA (J + Count .. New_Length) := EA (J .. Old_Length); |
| 1616 | end if; |
| 1617 | |
| 1618 | -- New_Last is the last index value of the items in the container after |
| 1619 | -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to |
| 1620 | -- compute its value from the New_Length. |
| 1621 | |
| 1622 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1623 | Container.Last := No_Index + Index_Type'Base (New_Length); |
| 1624 | |
| 1625 | else |
| 1626 | Container.Last := |
| 1627 | Index_Type'Base (Count_Type'Base (No_Index) + New_Length); |
| 1628 | end if; |
| 1629 | end Insert_Space; |
| 1630 | |
| 1631 | procedure Insert_Space |
| 1632 | (Container : in out Vector; |
| 1633 | Before : Cursor; |
| 1634 | Position : out Cursor; |
| 1635 | Count : Count_Type := 1) |
| 1636 | is |
| 1637 | Index : Index_Type'Base; |
| 1638 | |
| 1639 | begin |
| 1640 | if Before.Container /= null |
| 1641 | and then Before.Container /= Container'Unchecked_Access |
| 1642 | then |
| 1643 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1644 | end if; |
| 1645 | |
| 1646 | if Count = 0 then |
| 1647 | if Before.Container = null |
| 1648 | or else Before.Index > Container.Last |
| 1649 | then |
| 1650 | Position := No_Element; |
| 1651 | else |
| 1652 | Position := (Container'Unchecked_Access, Before.Index); |
| 1653 | end if; |
| 1654 | |
| 1655 | return; |
| 1656 | end if; |
| 1657 | |
| 1658 | if Before.Container = null |
| 1659 | or else Before.Index > Container.Last |
| 1660 | then |
| 1661 | if Container.Last = Index_Type'Last then |
| 1662 | raise Constraint_Error with |
| 1663 | "vector is already at its maximum length"; |
| 1664 | end if; |
| 1665 | |
| 1666 | Index := Container.Last + 1; |
| 1667 | |
| 1668 | else |
| 1669 | Index := Before.Index; |
| 1670 | end if; |
| 1671 | |
| 1672 | Insert_Space (Container, Index, Count => Count); |
| 1673 | |
| 1674 | Position := Cursor'(Container'Unchecked_Access, Index); |
| 1675 | end Insert_Space; |
| 1676 | |
| 1677 | -------------- |
| 1678 | -- Is_Empty -- |
| 1679 | -------------- |
| 1680 | |
| 1681 | function Is_Empty (Container : Vector) return Boolean is |
| 1682 | begin |
| 1683 | return Container.Last < Index_Type'First; |
| 1684 | end Is_Empty; |
| 1685 | |
| 1686 | ------------- |
| 1687 | -- Iterate -- |
| 1688 | ------------- |
| 1689 | |
| 1690 | procedure Iterate |
| 1691 | (Container : Vector; |
| 1692 | Process : not null access procedure (Position : Cursor)) |
| 1693 | is |
| 1694 | B : Natural renames Container'Unrestricted_Access.all.Busy; |
| 1695 | |
| 1696 | begin |
| 1697 | B := B + 1; |
| 1698 | |
| 1699 | begin |
| 1700 | for Indx in Index_Type'First .. Container.Last loop |
| 1701 | Process (Cursor'(Container'Unrestricted_Access, Indx)); |
| 1702 | end loop; |
| 1703 | exception |
| 1704 | when others => |
| 1705 | B := B - 1; |
| 1706 | raise; |
| 1707 | end; |
| 1708 | |
| 1709 | B := B - 1; |
| 1710 | end Iterate; |
| 1711 | |
| 1712 | function Iterate |
| 1713 | (Container : Vector) |
| 1714 | return Vector_Iterator_Interfaces.Reversible_Iterator'Class |
| 1715 | is |
| 1716 | V : constant Vector_Access := Container'Unrestricted_Access; |
| 1717 | B : Natural renames V.Busy; |
| 1718 | |
| 1719 | begin |
| 1720 | -- The value of its Index component influences the behavior of the First |
| 1721 | -- and Last selector functions of the iterator object. When the Index |
| 1722 | -- component is No_Index (as is the case here), this means the iterator |
| 1723 | -- object was constructed without a start expression. This is a complete |
| 1724 | -- iterator, meaning that the iteration starts from the (logical) |
| 1725 | -- beginning of the sequence of items. |
| 1726 | |
| 1727 | -- Note: For a forward iterator, Container.First is the beginning, and |
| 1728 | -- for a reverse iterator, Container.Last is the beginning. |
| 1729 | |
| 1730 | return It : constant Iterator := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 1731 | (Limited_Controlled with |
| 1732 | Container => V, |
| 1733 | Index => No_Index) |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 1734 | do |
| 1735 | B := B + 1; |
| 1736 | end return; |
| 1737 | end Iterate; |
| 1738 | |
| 1739 | function Iterate |
| 1740 | (Container : Vector; |
| 1741 | Start : Cursor) |
| 1742 | return Vector_Iterator_Interfaces.Reversible_Iterator'Class |
| 1743 | is |
| 1744 | V : constant Vector_Access := Container'Unrestricted_Access; |
| 1745 | B : Natural renames V.Busy; |
| 1746 | |
| 1747 | begin |
| 1748 | -- It was formerly the case that when Start = No_Element, the partial |
| 1749 | -- iterator was defined to behave the same as for a complete iterator, |
| 1750 | -- and iterate over the entire sequence of items. However, those |
| 1751 | -- semantics were unintuitive and arguably error-prone (it is too easy |
| 1752 | -- to accidentally create an endless loop), and so they were changed, |
| 1753 | -- per the ARG meeting in Denver on 2011/11. However, there was no |
| 1754 | -- consensus about what positive meaning this corner case should have, |
| 1755 | -- and so it was decided to simply raise an exception. This does imply, |
| 1756 | -- however, that it is not possible to use a partial iterator to specify |
| 1757 | -- an empty sequence of items. |
| 1758 | |
| 1759 | if Start.Container = null then |
| 1760 | raise Constraint_Error with |
| 1761 | "Start position for iterator equals No_Element"; |
| 1762 | end if; |
| 1763 | |
| 1764 | if Start.Container /= V then |
| 1765 | raise Program_Error with |
| 1766 | "Start cursor of Iterate designates wrong vector"; |
| 1767 | end if; |
| 1768 | |
| 1769 | if Start.Index > V.Last then |
| 1770 | raise Constraint_Error with |
| 1771 | "Start position for iterator equals No_Element"; |
| 1772 | end if; |
| 1773 | |
| 1774 | -- The value of its Index component influences the behavior of the First |
| 1775 | -- and Last selector functions of the iterator object. When the Index |
| 1776 | -- component is not No_Index (as is the case here), it means that this |
| 1777 | -- is a partial iteration, over a subset of the complete sequence of |
| 1778 | -- items. The iterator object was constructed with a start expression, |
| 1779 | -- indicating the position from which the iteration begins. Note that |
| 1780 | -- the start position has the same value irrespective of whether this is |
| 1781 | -- a forward or reverse iteration. |
| 1782 | |
| 1783 | return It : constant Iterator := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 1784 | (Limited_Controlled with |
| 1785 | Container => V, |
| 1786 | Index => Start.Index) |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 1787 | do |
| 1788 | B := B + 1; |
| 1789 | end return; |
| 1790 | end Iterate; |
| 1791 | |
| 1792 | ---------- |
| 1793 | -- Last -- |
| 1794 | ---------- |
| 1795 | |
| 1796 | function Last (Container : Vector) return Cursor is |
| 1797 | begin |
| 1798 | if Is_Empty (Container) then |
| 1799 | return No_Element; |
| 1800 | else |
| 1801 | return (Container'Unrestricted_Access, Container.Last); |
| 1802 | end if; |
| 1803 | end Last; |
| 1804 | |
| 1805 | function Last (Object : Iterator) return Cursor is |
| 1806 | begin |
| 1807 | -- The value of the iterator object's Index component influences the |
| 1808 | -- behavior of the Last (and First) selector function. |
| 1809 | |
| 1810 | -- When the Index component is No_Index, this means the iterator object |
| 1811 | -- was constructed without a start expression, in which case the |
| 1812 | -- (reverse) iteration starts from the (logical) beginning of the entire |
| 1813 | -- sequence (corresponding to Container.Last, for a reverse iterator). |
| 1814 | |
| 1815 | -- Otherwise, this is iteration over a partial sequence of items. When |
| 1816 | -- the Index component is not No_Index, the iterator object was |
| 1817 | -- constructed with a start expression, that specifies the position from |
| 1818 | -- which the (reverse) partial iteration begins. |
| 1819 | |
| 1820 | if Object.Index = No_Index then |
| 1821 | return Last (Object.Container.all); |
| 1822 | else |
| 1823 | return Cursor'(Object.Container, Object.Index); |
| 1824 | end if; |
| 1825 | end Last; |
| 1826 | |
| 1827 | ------------------ |
| 1828 | -- Last_Element -- |
| 1829 | ------------------ |
| 1830 | |
| 1831 | function Last_Element (Container : Vector) return Element_Type is |
| 1832 | begin |
| 1833 | if Container.Last = No_Index then |
| 1834 | raise Constraint_Error with "Container is empty"; |
| 1835 | else |
| 1836 | return Container.Elements (Container.Length); |
| 1837 | end if; |
| 1838 | end Last_Element; |
| 1839 | |
| 1840 | ---------------- |
| 1841 | -- Last_Index -- |
| 1842 | ---------------- |
| 1843 | |
| 1844 | function Last_Index (Container : Vector) return Extended_Index is |
| 1845 | begin |
| 1846 | return Container.Last; |
| 1847 | end Last_Index; |
| 1848 | |
| 1849 | ------------ |
| 1850 | -- Length -- |
| 1851 | ------------ |
| 1852 | |
| 1853 | function Length (Container : Vector) return Count_Type is |
| 1854 | L : constant Index_Type'Base := Container.Last; |
| 1855 | F : constant Index_Type := Index_Type'First; |
| 1856 | |
| 1857 | begin |
| 1858 | -- The base range of the index type (Index_Type'Base) might not include |
| 1859 | -- all values for length (Count_Type). Contrariwise, the index type |
| 1860 | -- might include values outside the range of length. Hence we use |
| 1861 | -- whatever type is wider for intermediate values when calculating |
| 1862 | -- length. Note that no matter what the index type is, the maximum |
| 1863 | -- length to which a vector is allowed to grow is always the minimum |
| 1864 | -- of Count_Type'Last and (IT'Last - IT'First + 1). |
| 1865 | |
| 1866 | -- For example, an Index_Type with range -127 .. 127 is only guaranteed |
| 1867 | -- to have a base range of -128 .. 127, but the corresponding vector |
| 1868 | -- would have lengths in the range 0 .. 255. In this case we would need |
| 1869 | -- to use Count_Type'Base for intermediate values. |
| 1870 | |
| 1871 | -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The |
| 1872 | -- vector would have a maximum length of 10, but the index values lie |
| 1873 | -- outside the range of Count_Type (which is only 32 bits). In this |
| 1874 | -- case we would need to use Index_Type'Base for intermediate values. |
| 1875 | |
| 1876 | if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then |
| 1877 | return Count_Type'Base (L) - Count_Type'Base (F) + 1; |
| 1878 | else |
| 1879 | return Count_Type (L - F + 1); |
| 1880 | end if; |
| 1881 | end Length; |
| 1882 | |
| 1883 | ---------- |
| 1884 | -- Move -- |
| 1885 | ---------- |
| 1886 | |
| 1887 | procedure Move |
| 1888 | (Target : in out Vector; |
| 1889 | Source : in out Vector) |
| 1890 | is |
| 1891 | begin |
| 1892 | if Target'Address = Source'Address then |
| 1893 | return; |
| 1894 | end if; |
| 1895 | |
| 1896 | if Target.Capacity < Source.Length then |
| 1897 | raise Capacity_Error -- ??? |
| 1898 | with "Target capacity is less than Source length"; |
| 1899 | end if; |
| 1900 | |
| 1901 | if Target.Busy > 0 then |
| 1902 | raise Program_Error with |
| 1903 | "attempt to tamper with cursors (Target is busy)"; |
| 1904 | end if; |
| 1905 | |
| 1906 | if Source.Busy > 0 then |
| 1907 | raise Program_Error with |
| 1908 | "attempt to tamper with cursors (Source is busy)"; |
| 1909 | end if; |
| 1910 | |
| 1911 | -- Clear Target now, in case element assignment fails |
| 1912 | |
| 1913 | Target.Last := No_Index; |
| 1914 | |
| 1915 | Target.Elements (1 .. Source.Length) := |
| 1916 | Source.Elements (1 .. Source.Length); |
| 1917 | |
| 1918 | Target.Last := Source.Last; |
| 1919 | Source.Last := No_Index; |
| 1920 | end Move; |
| 1921 | |
| 1922 | ---------- |
| 1923 | -- Next -- |
| 1924 | ---------- |
| 1925 | |
| 1926 | function Next (Position : Cursor) return Cursor is |
| 1927 | begin |
| 1928 | if Position.Container = null then |
| 1929 | return No_Element; |
| 1930 | end if; |
| 1931 | |
| 1932 | if Position.Index < Position.Container.Last then |
| 1933 | return (Position.Container, Position.Index + 1); |
| 1934 | end if; |
| 1935 | |
| 1936 | return No_Element; |
| 1937 | end Next; |
| 1938 | |
| 1939 | function Next (Object : Iterator; Position : Cursor) return Cursor is |
| 1940 | begin |
| 1941 | if Position.Container = null then |
| 1942 | return No_Element; |
| 1943 | end if; |
| 1944 | |
| 1945 | if Position.Container /= Object.Container then |
| 1946 | raise Program_Error with |
| 1947 | "Position cursor of Next designates wrong vector"; |
| 1948 | end if; |
| 1949 | |
| 1950 | return Next (Position); |
| 1951 | end Next; |
| 1952 | |
| 1953 | procedure Next (Position : in out Cursor) is |
| 1954 | begin |
| 1955 | if Position.Container = null then |
| 1956 | return; |
| 1957 | end if; |
| 1958 | |
| 1959 | if Position.Index < Position.Container.Last then |
| 1960 | Position.Index := Position.Index + 1; |
| 1961 | else |
| 1962 | Position := No_Element; |
| 1963 | end if; |
| 1964 | end Next; |
| 1965 | |
| 1966 | ------------- |
| 1967 | -- Prepend -- |
| 1968 | ------------- |
| 1969 | |
| 1970 | procedure Prepend (Container : in out Vector; New_Item : Vector) is |
| 1971 | begin |
| 1972 | Insert (Container, Index_Type'First, New_Item); |
| 1973 | end Prepend; |
| 1974 | |
| 1975 | procedure Prepend |
| 1976 | (Container : in out Vector; |
| 1977 | New_Item : Element_Type; |
| 1978 | Count : Count_Type := 1) |
| 1979 | is |
| 1980 | begin |
| 1981 | Insert (Container, |
| 1982 | Index_Type'First, |
| 1983 | New_Item, |
| 1984 | Count); |
| 1985 | end Prepend; |
| 1986 | |
| 1987 | -------------- |
| 1988 | -- Previous -- |
| 1989 | -------------- |
| 1990 | |
| 1991 | procedure Previous (Position : in out Cursor) is |
| 1992 | begin |
| 1993 | if Position.Container = null then |
| 1994 | return; |
| 1995 | end if; |
| 1996 | |
| 1997 | if Position.Index > Index_Type'First then |
| 1998 | Position.Index := Position.Index - 1; |
| 1999 | else |
| 2000 | Position := No_Element; |
| 2001 | end if; |
| 2002 | end Previous; |
| 2003 | |
| 2004 | function Previous (Position : Cursor) return Cursor is |
| 2005 | begin |
| 2006 | if Position.Container = null then |
| 2007 | return No_Element; |
| 2008 | end if; |
| 2009 | |
| 2010 | if Position.Index > Index_Type'First then |
| 2011 | return (Position.Container, Position.Index - 1); |
| 2012 | end if; |
| 2013 | |
| 2014 | return No_Element; |
| 2015 | end Previous; |
| 2016 | |
| 2017 | function Previous (Object : Iterator; Position : Cursor) return Cursor is |
| 2018 | begin |
| 2019 | if Position.Container = null then |
| 2020 | return No_Element; |
| 2021 | end if; |
| 2022 | |
| 2023 | if Position.Container /= Object.Container then |
| 2024 | raise Program_Error with |
| 2025 | "Position cursor of Previous designates wrong vector"; |
| 2026 | end if; |
| 2027 | |
| 2028 | return Previous (Position); |
| 2029 | end Previous; |
| 2030 | |
| 2031 | ------------------- |
| 2032 | -- Query_Element -- |
| 2033 | ------------------- |
| 2034 | |
| 2035 | procedure Query_Element |
| 2036 | (Container : Vector; |
| 2037 | Index : Index_Type; |
| 2038 | Process : not null access procedure (Element : Element_Type)) |
| 2039 | is |
| 2040 | V : Vector renames Container'Unrestricted_Access.all; |
| 2041 | B : Natural renames V.Busy; |
| 2042 | L : Natural renames V.Lock; |
| 2043 | |
| 2044 | begin |
| 2045 | if Index > Container.Last then |
| 2046 | raise Constraint_Error with "Index is out of range"; |
| 2047 | end if; |
| 2048 | |
| 2049 | B := B + 1; |
| 2050 | L := L + 1; |
| 2051 | |
| 2052 | begin |
| 2053 | Process (V.Elements (To_Array_Index (Index))); |
| 2054 | exception |
| 2055 | when others => |
| 2056 | L := L - 1; |
| 2057 | B := B - 1; |
| 2058 | raise; |
| 2059 | end; |
| 2060 | |
| 2061 | L := L - 1; |
| 2062 | B := B - 1; |
| 2063 | end Query_Element; |
| 2064 | |
| 2065 | procedure Query_Element |
| 2066 | (Position : Cursor; |
| 2067 | Process : not null access procedure (Element : Element_Type)) |
| 2068 | is |
| 2069 | begin |
| 2070 | if Position.Container = null then |
| 2071 | raise Constraint_Error with "Position cursor has no element"; |
| 2072 | end if; |
| 2073 | |
| 2074 | Query_Element (Position.Container.all, Position.Index, Process); |
| 2075 | end Query_Element; |
| 2076 | |
| 2077 | ---------- |
| 2078 | -- Read -- |
| 2079 | ---------- |
| 2080 | |
| 2081 | procedure Read |
| 2082 | (Stream : not null access Root_Stream_Type'Class; |
| 2083 | Container : out Vector) |
| 2084 | is |
| 2085 | Length : Count_Type'Base; |
| 2086 | Last : Index_Type'Base := No_Index; |
| 2087 | |
| 2088 | begin |
| 2089 | Clear (Container); |
| 2090 | |
| 2091 | Count_Type'Base'Read (Stream, Length); |
| 2092 | |
| 2093 | Reserve_Capacity (Container, Capacity => Length); |
| 2094 | |
| 2095 | for Idx in Count_Type range 1 .. Length loop |
| 2096 | Last := Last + 1; |
| 2097 | Element_Type'Read (Stream, Container.Elements (Idx)); |
| 2098 | Container.Last := Last; |
| 2099 | end loop; |
| 2100 | end Read; |
| 2101 | |
| 2102 | procedure Read |
| 2103 | (Stream : not null access Root_Stream_Type'Class; |
| 2104 | Position : out Cursor) |
| 2105 | is |
| 2106 | begin |
| 2107 | raise Program_Error with "attempt to stream vector cursor"; |
| 2108 | end Read; |
| 2109 | |
| 2110 | procedure Read |
| 2111 | (Stream : not null access Root_Stream_Type'Class; |
| 2112 | Item : out Reference_Type) |
| 2113 | is |
| 2114 | begin |
| 2115 | raise Program_Error with "attempt to stream reference"; |
| 2116 | end Read; |
| 2117 | |
| 2118 | procedure Read |
| 2119 | (Stream : not null access Root_Stream_Type'Class; |
| 2120 | Item : out Constant_Reference_Type) |
| 2121 | is |
| 2122 | begin |
| 2123 | raise Program_Error with "attempt to stream reference"; |
| 2124 | end Read; |
| 2125 | |
| 2126 | --------------- |
| 2127 | -- Reference -- |
| 2128 | --------------- |
| 2129 | |
| 2130 | function Reference |
| 2131 | (Container : aliased in out Vector; |
| 2132 | Position : Cursor) return Reference_Type |
| 2133 | is |
| 2134 | begin |
| 2135 | if Position.Container = null then |
| 2136 | raise Constraint_Error with "Position cursor has no element"; |
| 2137 | end if; |
| 2138 | |
| 2139 | if Position.Container /= Container'Unrestricted_Access then |
| 2140 | raise Program_Error with "Position cursor denotes wrong container"; |
| 2141 | end if; |
| 2142 | |
| 2143 | if Position.Index > Position.Container.Last then |
| 2144 | raise Constraint_Error with "Position cursor is out of range"; |
| 2145 | end if; |
| 2146 | |
| 2147 | declare |
| 2148 | A : Elements_Array renames Container.Elements; |
| 2149 | I : constant Count_Type := To_Array_Index (Position.Index); |
| 2150 | begin |
| 2151 | return (Element => A (I)'Access); |
| 2152 | end; |
| 2153 | end Reference; |
| 2154 | |
| 2155 | function Reference |
| 2156 | (Container : aliased in out Vector; |
| 2157 | Index : Index_Type) return Reference_Type |
| 2158 | is |
| 2159 | begin |
| 2160 | if Index > Container.Last then |
| 2161 | raise Constraint_Error with "Index is out of range"; |
| 2162 | end if; |
| 2163 | |
| 2164 | declare |
| 2165 | A : Elements_Array renames Container.Elements; |
| 2166 | I : constant Count_Type := To_Array_Index (Index); |
| 2167 | begin |
| 2168 | return (Element => A (I)'Access); |
| 2169 | end; |
| 2170 | end Reference; |
| 2171 | |
| 2172 | --------------------- |
| 2173 | -- Replace_Element -- |
| 2174 | --------------------- |
| 2175 | |
| 2176 | procedure Replace_Element |
| 2177 | (Container : in out Vector; |
| 2178 | Index : Index_Type; |
| 2179 | New_Item : Element_Type) |
| 2180 | is |
| 2181 | begin |
| 2182 | if Index > Container.Last then |
| 2183 | raise Constraint_Error with "Index is out of range"; |
| 2184 | end if; |
| 2185 | |
| 2186 | if Container.Lock > 0 then |
| 2187 | raise Program_Error with |
| 2188 | "attempt to tamper with elements (vector is locked)"; |
| 2189 | end if; |
| 2190 | |
| 2191 | Container.Elements (To_Array_Index (Index)) := New_Item; |
| 2192 | end Replace_Element; |
| 2193 | |
| 2194 | procedure Replace_Element |
| 2195 | (Container : in out Vector; |
| 2196 | Position : Cursor; |
| 2197 | New_Item : Element_Type) |
| 2198 | is |
| 2199 | begin |
| 2200 | if Position.Container = null then |
| 2201 | raise Constraint_Error with "Position cursor has no element"; |
| 2202 | end if; |
| 2203 | |
| 2204 | if Position.Container /= Container'Unrestricted_Access then |
| 2205 | raise Program_Error with "Position cursor denotes wrong container"; |
| 2206 | end if; |
| 2207 | |
| 2208 | if Position.Index > Container.Last then |
| 2209 | raise Constraint_Error with "Position cursor is out of range"; |
| 2210 | end if; |
| 2211 | |
| 2212 | if Container.Lock > 0 then |
| 2213 | raise Program_Error with |
| 2214 | "attempt to tamper with elements (vector is locked)"; |
| 2215 | end if; |
| 2216 | |
| 2217 | Container.Elements (To_Array_Index (Position.Index)) := New_Item; |
| 2218 | end Replace_Element; |
| 2219 | |
| 2220 | ---------------------- |
| 2221 | -- Reserve_Capacity -- |
| 2222 | ---------------------- |
| 2223 | |
| 2224 | procedure Reserve_Capacity |
| 2225 | (Container : in out Vector; |
| 2226 | Capacity : Count_Type) |
| 2227 | is |
| 2228 | begin |
| 2229 | if Capacity > Container.Capacity then |
| 2230 | raise Constraint_Error with "Capacity is out of range"; |
| 2231 | end if; |
| 2232 | end Reserve_Capacity; |
| 2233 | |
| 2234 | ---------------------- |
| 2235 | -- Reverse_Elements -- |
| 2236 | ---------------------- |
| 2237 | |
| 2238 | procedure Reverse_Elements (Container : in out Vector) is |
| 2239 | E : Elements_Array renames Container.Elements; |
| 2240 | Idx : Count_Type; |
| 2241 | Jdx : Count_Type; |
| 2242 | |
| 2243 | begin |
| 2244 | if Container.Length <= 1 then |
| 2245 | return; |
| 2246 | end if; |
| 2247 | |
| 2248 | -- The exception behavior for the vector container must match that for |
| 2249 | -- the list container, so we check for cursor tampering here (which will |
| 2250 | -- catch more things) instead of for element tampering (which will catch |
| 2251 | -- fewer things). It's true that the elements of this vector container |
| 2252 | -- could be safely moved around while (say) an iteration is taking place |
| 2253 | -- (iteration only increments the busy counter), and so technically |
| 2254 | -- all we would need here is a test for element tampering (indicated |
| 2255 | -- by the lock counter), that's simply an artifact of our array-based |
| 2256 | -- implementation. Logically Reverse_Elements requires a check for |
| 2257 | -- cursor tampering. |
| 2258 | |
| 2259 | if Container.Busy > 0 then |
| 2260 | raise Program_Error with |
| 2261 | "attempt to tamper with cursors (vector is busy)"; |
| 2262 | end if; |
| 2263 | |
| 2264 | Idx := 1; |
| 2265 | Jdx := Container.Length; |
| 2266 | while Idx < Jdx loop |
| 2267 | declare |
| 2268 | EI : constant Element_Type := E (Idx); |
| 2269 | |
| 2270 | begin |
| 2271 | E (Idx) := E (Jdx); |
| 2272 | E (Jdx) := EI; |
| 2273 | end; |
| 2274 | |
| 2275 | Idx := Idx + 1; |
| 2276 | Jdx := Jdx - 1; |
| 2277 | end loop; |
| 2278 | end Reverse_Elements; |
| 2279 | |
| 2280 | ------------------ |
| 2281 | -- Reverse_Find -- |
| 2282 | ------------------ |
| 2283 | |
| 2284 | function Reverse_Find |
| 2285 | (Container : Vector; |
| 2286 | Item : Element_Type; |
| 2287 | Position : Cursor := No_Element) return Cursor |
| 2288 | is |
| 2289 | Last : Index_Type'Base; |
| 2290 | |
| 2291 | begin |
| 2292 | if Position.Container /= null |
| 2293 | and then Position.Container /= Container'Unrestricted_Access |
| 2294 | then |
| 2295 | raise Program_Error with "Position cursor denotes wrong container"; |
| 2296 | end if; |
| 2297 | |
| 2298 | Last := |
| 2299 | (if Position.Container = null or else Position.Index > Container.Last |
| 2300 | then Container.Last |
| 2301 | else Position.Index); |
| 2302 | |
| 2303 | for Indx in reverse Index_Type'First .. Last loop |
| 2304 | if Container.Elements (To_Array_Index (Indx)) = Item then |
| 2305 | return (Container'Unrestricted_Access, Indx); |
| 2306 | end if; |
| 2307 | end loop; |
| 2308 | |
| 2309 | return No_Element; |
| 2310 | end Reverse_Find; |
| 2311 | |
| 2312 | ------------------------ |
| 2313 | -- Reverse_Find_Index -- |
| 2314 | ------------------------ |
| 2315 | |
| 2316 | function Reverse_Find_Index |
| 2317 | (Container : Vector; |
| 2318 | Item : Element_Type; |
| 2319 | Index : Index_Type := Index_Type'Last) return Extended_Index |
| 2320 | is |
| 2321 | Last : constant Index_Type'Base := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 2322 | Index_Type'Min (Container.Last, Index); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 2323 | |
| 2324 | begin |
| 2325 | for Indx in reverse Index_Type'First .. Last loop |
| 2326 | if Container.Elements (To_Array_Index (Indx)) = Item then |
| 2327 | return Indx; |
| 2328 | end if; |
| 2329 | end loop; |
| 2330 | |
| 2331 | return No_Index; |
| 2332 | end Reverse_Find_Index; |
| 2333 | |
| 2334 | --------------------- |
| 2335 | -- Reverse_Iterate -- |
| 2336 | --------------------- |
| 2337 | |
| 2338 | procedure Reverse_Iterate |
| 2339 | (Container : Vector; |
| 2340 | Process : not null access procedure (Position : Cursor)) |
| 2341 | is |
| 2342 | V : Vector renames Container'Unrestricted_Access.all; |
| 2343 | B : Natural renames V.Busy; |
| 2344 | |
| 2345 | begin |
| 2346 | B := B + 1; |
| 2347 | |
| 2348 | begin |
| 2349 | for Indx in reverse Index_Type'First .. Container.Last loop |
| 2350 | Process (Cursor'(Container'Unrestricted_Access, Indx)); |
| 2351 | end loop; |
| 2352 | exception |
| 2353 | when others => |
| 2354 | B := B - 1; |
| 2355 | raise; |
| 2356 | end; |
| 2357 | |
| 2358 | B := B - 1; |
| 2359 | end Reverse_Iterate; |
| 2360 | |
| 2361 | ---------------- |
| 2362 | -- Set_Length -- |
| 2363 | ---------------- |
| 2364 | |
| 2365 | procedure Set_Length (Container : in out Vector; Length : Count_Type) is |
| 2366 | Count : constant Count_Type'Base := Container.Length - Length; |
| 2367 | |
| 2368 | begin |
| 2369 | -- Set_Length allows the user to set the length explicitly, instead of |
| 2370 | -- implicitly as a side-effect of deletion or insertion. If the |
| 2371 | -- requested length is less than the current length, this is equivalent |
| 2372 | -- to deleting items from the back end of the vector. If the requested |
| 2373 | -- length is greater than the current length, then this is equivalent to |
| 2374 | -- inserting "space" (nonce items) at the end. |
| 2375 | |
| 2376 | if Count >= 0 then |
| 2377 | Container.Delete_Last (Count); |
| 2378 | |
| 2379 | elsif Container.Last >= Index_Type'Last then |
| 2380 | raise Constraint_Error with "vector is already at its maximum length"; |
| 2381 | |
| 2382 | else |
| 2383 | Container.Insert_Space (Container.Last + 1, -Count); |
| 2384 | end if; |
| 2385 | end Set_Length; |
| 2386 | |
| 2387 | ---------- |
| 2388 | -- Swap -- |
| 2389 | ---------- |
| 2390 | |
| 2391 | procedure Swap (Container : in out Vector; I, J : Index_Type) is |
| 2392 | E : Elements_Array renames Container.Elements; |
| 2393 | |
| 2394 | begin |
| 2395 | if I > Container.Last then |
| 2396 | raise Constraint_Error with "I index is out of range"; |
| 2397 | end if; |
| 2398 | |
| 2399 | if J > Container.Last then |
| 2400 | raise Constraint_Error with "J index is out of range"; |
| 2401 | end if; |
| 2402 | |
| 2403 | if I = J then |
| 2404 | return; |
| 2405 | end if; |
| 2406 | |
| 2407 | if Container.Lock > 0 then |
| 2408 | raise Program_Error with |
| 2409 | "attempt to tamper with elements (vector is locked)"; |
| 2410 | end if; |
| 2411 | |
| 2412 | declare |
| 2413 | EI_Copy : constant Element_Type := E (To_Array_Index (I)); |
| 2414 | begin |
| 2415 | E (To_Array_Index (I)) := E (To_Array_Index (J)); |
| 2416 | E (To_Array_Index (J)) := EI_Copy; |
| 2417 | end; |
| 2418 | end Swap; |
| 2419 | |
| 2420 | procedure Swap (Container : in out Vector; I, J : Cursor) is |
| 2421 | begin |
| 2422 | if I.Container = null then |
| 2423 | raise Constraint_Error with "I cursor has no element"; |
| 2424 | end if; |
| 2425 | |
| 2426 | if J.Container = null then |
| 2427 | raise Constraint_Error with "J cursor has no element"; |
| 2428 | end if; |
| 2429 | |
| 2430 | if I.Container /= Container'Unrestricted_Access then |
| 2431 | raise Program_Error with "I cursor denotes wrong container"; |
| 2432 | end if; |
| 2433 | |
| 2434 | if J.Container /= Container'Unrestricted_Access then |
| 2435 | raise Program_Error with "J cursor denotes wrong container"; |
| 2436 | end if; |
| 2437 | |
| 2438 | Swap (Container, I.Index, J.Index); |
| 2439 | end Swap; |
| 2440 | |
| 2441 | -------------------- |
| 2442 | -- To_Array_Index -- |
| 2443 | -------------------- |
| 2444 | |
| 2445 | function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is |
| 2446 | Offset : Count_Type'Base; |
| 2447 | |
| 2448 | begin |
| 2449 | -- We know that |
| 2450 | -- Index >= Index_Type'First |
| 2451 | -- hence we also know that |
| 2452 | -- Index - Index_Type'First >= 0 |
| 2453 | |
| 2454 | -- The issue is that even though 0 is guaranteed to be a value |
| 2455 | -- in the type Index_Type'Base, there's no guarantee that the |
| 2456 | -- difference is a value in that type. To prevent overflow we |
| 2457 | -- use the wider of Count_Type'Base and Index_Type'Base to |
| 2458 | -- perform intermediate calculations. |
| 2459 | |
| 2460 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 2461 | Offset := Count_Type'Base (Index - Index_Type'First); |
| 2462 | |
| 2463 | else |
| 2464 | Offset := Count_Type'Base (Index) - |
| 2465 | Count_Type'Base (Index_Type'First); |
| 2466 | end if; |
| 2467 | |
| 2468 | -- The array index subtype for all container element arrays |
| 2469 | -- always starts with 1. |
| 2470 | |
| 2471 | return 1 + Offset; |
| 2472 | end To_Array_Index; |
| 2473 | |
| 2474 | --------------- |
| 2475 | -- To_Cursor -- |
| 2476 | --------------- |
| 2477 | |
| 2478 | function To_Cursor |
| 2479 | (Container : Vector; |
| 2480 | Index : Extended_Index) return Cursor |
| 2481 | is |
| 2482 | begin |
| 2483 | if Index not in Index_Type'First .. Container.Last then |
| 2484 | return No_Element; |
| 2485 | end if; |
| 2486 | |
| 2487 | return Cursor'(Container'Unrestricted_Access, Index); |
| 2488 | end To_Cursor; |
| 2489 | |
| 2490 | -------------- |
| 2491 | -- To_Index -- |
| 2492 | -------------- |
| 2493 | |
| 2494 | function To_Index (Position : Cursor) return Extended_Index is |
| 2495 | begin |
| 2496 | if Position.Container = null then |
| 2497 | return No_Index; |
| 2498 | end if; |
| 2499 | |
| 2500 | if Position.Index <= Position.Container.Last then |
| 2501 | return Position.Index; |
| 2502 | end if; |
| 2503 | |
| 2504 | return No_Index; |
| 2505 | end To_Index; |
| 2506 | |
| 2507 | --------------- |
| 2508 | -- To_Vector -- |
| 2509 | --------------- |
| 2510 | |
| 2511 | function To_Vector (Length : Count_Type) return Vector is |
| 2512 | Index : Count_Type'Base; |
| 2513 | Last : Index_Type'Base; |
| 2514 | |
| 2515 | begin |
| 2516 | if Length = 0 then |
| 2517 | return Empty_Vector; |
| 2518 | end if; |
| 2519 | |
| 2520 | -- We create a vector object with a capacity that matches the specified |
| 2521 | -- Length, but we do not allow the vector capacity (the length of the |
| 2522 | -- internal array) to exceed the number of values in Index_Type'Range |
| 2523 | -- (otherwise, there would be no way to refer to those components via an |
| 2524 | -- index). We must therefore check whether the specified Length would |
| 2525 | -- create a Last index value greater than Index_Type'Last. |
| 2526 | |
| 2527 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 2528 | -- We perform a two-part test. First we determine whether the |
| 2529 | -- computed Last value lies in the base range of the type, and then |
| 2530 | -- determine whether it lies in the range of the index (sub)type. |
| 2531 | |
| 2532 | -- Last must satisfy this relation: |
| 2533 | -- First + Length - 1 <= Last |
| 2534 | -- We regroup terms: |
| 2535 | -- First - 1 <= Last - Length |
| 2536 | -- Which can rewrite as: |
| 2537 | -- No_Index <= Last - Length |
| 2538 | |
| 2539 | if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then |
| 2540 | raise Constraint_Error with "Length is out of range"; |
| 2541 | end if; |
| 2542 | |
| 2543 | -- We now know that the computed value of Last is within the base |
| 2544 | -- range of the type, so it is safe to compute its value: |
| 2545 | |
| 2546 | Last := No_Index + Index_Type'Base (Length); |
| 2547 | |
| 2548 | -- Finally we test whether the value is within the range of the |
| 2549 | -- generic actual index subtype: |
| 2550 | |
| 2551 | if Last > Index_Type'Last then |
| 2552 | raise Constraint_Error with "Length is out of range"; |
| 2553 | end if; |
| 2554 | |
| 2555 | elsif Index_Type'First <= 0 then |
| 2556 | |
| 2557 | -- Here we can compute Last directly, in the normal way. We know that |
| 2558 | -- No_Index is less than 0, so there is no danger of overflow when |
| 2559 | -- adding the (positive) value of Length. |
| 2560 | |
| 2561 | Index := Count_Type'Base (No_Index) + Length; -- Last |
| 2562 | |
| 2563 | if Index > Count_Type'Base (Index_Type'Last) then |
| 2564 | raise Constraint_Error with "Length is out of range"; |
| 2565 | end if; |
| 2566 | |
| 2567 | -- We know that the computed value (having type Count_Type) of Last |
| 2568 | -- is within the range of the generic actual index subtype, so it is |
| 2569 | -- safe to convert to Index_Type: |
| 2570 | |
| 2571 | Last := Index_Type'Base (Index); |
| 2572 | |
| 2573 | else |
| 2574 | -- Here Index_Type'First (and Index_Type'Last) is positive, so we |
| 2575 | -- must test the length indirectly (by working backwards from the |
| 2576 | -- largest possible value of Last), in order to prevent overflow. |
| 2577 | |
| 2578 | Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index |
| 2579 | |
| 2580 | if Index < Count_Type'Base (No_Index) then |
| 2581 | raise Constraint_Error with "Length is out of range"; |
| 2582 | end if; |
| 2583 | |
| 2584 | -- We have determined that the value of Length would not create a |
| 2585 | -- Last index value outside of the range of Index_Type, so we can now |
| 2586 | -- safely compute its value. |
| 2587 | |
| 2588 | Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); |
| 2589 | end if; |
| 2590 | |
| 2591 | return V : Vector (Capacity => Length) do |
| 2592 | V.Last := Last; |
| 2593 | end return; |
| 2594 | end To_Vector; |
| 2595 | |
| 2596 | function To_Vector |
| 2597 | (New_Item : Element_Type; |
| 2598 | Length : Count_Type) return Vector |
| 2599 | is |
| 2600 | Index : Count_Type'Base; |
| 2601 | Last : Index_Type'Base; |
| 2602 | |
| 2603 | begin |
| 2604 | if Length = 0 then |
| 2605 | return Empty_Vector; |
| 2606 | end if; |
| 2607 | |
| 2608 | -- We create a vector object with a capacity that matches the specified |
| 2609 | -- Length, but we do not allow the vector capacity (the length of the |
| 2610 | -- internal array) to exceed the number of values in Index_Type'Range |
| 2611 | -- (otherwise, there would be no way to refer to those components via an |
| 2612 | -- index). We must therefore check whether the specified Length would |
| 2613 | -- create a Last index value greater than Index_Type'Last. |
| 2614 | |
| 2615 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 2616 | |
| 2617 | -- We perform a two-part test. First we determine whether the |
| 2618 | -- computed Last value lies in the base range of the type, and then |
| 2619 | -- determine whether it lies in the range of the index (sub)type. |
| 2620 | |
| 2621 | -- Last must satisfy this relation: |
| 2622 | -- First + Length - 1 <= Last |
| 2623 | -- We regroup terms: |
| 2624 | -- First - 1 <= Last - Length |
| 2625 | -- Which can rewrite as: |
| 2626 | -- No_Index <= Last - Length |
| 2627 | |
| 2628 | if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then |
| 2629 | raise Constraint_Error with "Length is out of range"; |
| 2630 | end if; |
| 2631 | |
| 2632 | -- We now know that the computed value of Last is within the base |
| 2633 | -- range of the type, so it is safe to compute its value: |
| 2634 | |
| 2635 | Last := No_Index + Index_Type'Base (Length); |
| 2636 | |
| 2637 | -- Finally we test whether the value is within the range of the |
| 2638 | -- generic actual index subtype: |
| 2639 | |
| 2640 | if Last > Index_Type'Last then |
| 2641 | raise Constraint_Error with "Length is out of range"; |
| 2642 | end if; |
| 2643 | |
| 2644 | elsif Index_Type'First <= 0 then |
| 2645 | |
| 2646 | -- Here we can compute Last directly, in the normal way. We know that |
| 2647 | -- No_Index is less than 0, so there is no danger of overflow when |
| 2648 | -- adding the (positive) value of Length. |
| 2649 | |
| 2650 | Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last |
| 2651 | |
| 2652 | if Index > Count_Type'Base (Index_Type'Last) then |
| 2653 | raise Constraint_Error with "Length is out of range"; |
| 2654 | end if; |
| 2655 | |
| 2656 | -- We know that the computed value (having type Count_Type) of Last |
| 2657 | -- is within the range of the generic actual index subtype, so it is |
| 2658 | -- safe to convert to Index_Type: |
| 2659 | |
| 2660 | Last := Index_Type'Base (Index); |
| 2661 | |
| 2662 | else |
| 2663 | -- Here Index_Type'First (and Index_Type'Last) is positive, so we |
| 2664 | -- must test the length indirectly (by working backwards from the |
| 2665 | -- largest possible value of Last), in order to prevent overflow. |
| 2666 | |
| 2667 | Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index |
| 2668 | |
| 2669 | if Index < Count_Type'Base (No_Index) then |
| 2670 | raise Constraint_Error with "Length is out of range"; |
| 2671 | end if; |
| 2672 | |
| 2673 | -- We have determined that the value of Length would not create a |
| 2674 | -- Last index value outside of the range of Index_Type, so we can now |
| 2675 | -- safely compute its value. |
| 2676 | |
| 2677 | Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); |
| 2678 | end if; |
| 2679 | |
| 2680 | return V : Vector (Capacity => Length) do |
| 2681 | V.Elements := (others => New_Item); |
| 2682 | V.Last := Last; |
| 2683 | end return; |
| 2684 | end To_Vector; |
| 2685 | |
| 2686 | -------------------- |
| 2687 | -- Update_Element -- |
| 2688 | -------------------- |
| 2689 | |
| 2690 | procedure Update_Element |
| 2691 | (Container : in out Vector; |
| 2692 | Index : Index_Type; |
| 2693 | Process : not null access procedure (Element : in out Element_Type)) |
| 2694 | is |
| 2695 | B : Natural renames Container.Busy; |
| 2696 | L : Natural renames Container.Lock; |
| 2697 | |
| 2698 | begin |
| 2699 | if Index > Container.Last then |
| 2700 | raise Constraint_Error with "Index is out of range"; |
| 2701 | end if; |
| 2702 | |
| 2703 | B := B + 1; |
| 2704 | L := L + 1; |
| 2705 | |
| 2706 | begin |
| 2707 | Process (Container.Elements (To_Array_Index (Index))); |
| 2708 | exception |
| 2709 | when others => |
| 2710 | L := L - 1; |
| 2711 | B := B - 1; |
| 2712 | raise; |
| 2713 | end; |
| 2714 | |
| 2715 | L := L - 1; |
| 2716 | B := B - 1; |
| 2717 | end Update_Element; |
| 2718 | |
| 2719 | procedure Update_Element |
| 2720 | (Container : in out Vector; |
| 2721 | Position : Cursor; |
| 2722 | Process : not null access procedure (Element : in out Element_Type)) |
| 2723 | is |
| 2724 | begin |
| 2725 | if Position.Container = null then |
| 2726 | raise Constraint_Error with "Position cursor has no element"; |
| 2727 | end if; |
| 2728 | |
| 2729 | if Position.Container /= Container'Unrestricted_Access then |
| 2730 | raise Program_Error with "Position cursor denotes wrong container"; |
| 2731 | end if; |
| 2732 | |
| 2733 | Update_Element (Container, Position.Index, Process); |
| 2734 | end Update_Element; |
| 2735 | |
| 2736 | ----------- |
| 2737 | -- Write -- |
| 2738 | ----------- |
| 2739 | |
| 2740 | procedure Write |
| 2741 | (Stream : not null access Root_Stream_Type'Class; |
| 2742 | Container : Vector) |
| 2743 | is |
| 2744 | N : Count_Type; |
| 2745 | |
| 2746 | begin |
| 2747 | N := Container.Length; |
| 2748 | Count_Type'Base'Write (Stream, N); |
| 2749 | |
| 2750 | for J in 1 .. N loop |
| 2751 | Element_Type'Write (Stream, Container.Elements (J)); |
| 2752 | end loop; |
| 2753 | end Write; |
| 2754 | |
| 2755 | procedure Write |
| 2756 | (Stream : not null access Root_Stream_Type'Class; |
| 2757 | Position : Cursor) |
| 2758 | is |
| 2759 | begin |
| 2760 | raise Program_Error with "attempt to stream vector cursor"; |
| 2761 | end Write; |
| 2762 | |
| 2763 | procedure Write |
| 2764 | (Stream : not null access Root_Stream_Type'Class; |
| 2765 | Item : Reference_Type) |
| 2766 | is |
| 2767 | begin |
| 2768 | raise Program_Error with "attempt to stream reference"; |
| 2769 | end Write; |
| 2770 | |
| 2771 | procedure Write |
| 2772 | (Stream : not null access Root_Stream_Type'Class; |
| 2773 | Item : Constant_Reference_Type) |
| 2774 | is |
| 2775 | begin |
| 2776 | raise Program_Error with "attempt to stream reference"; |
| 2777 | end Write; |
| 2778 | |
| 2779 | end Ada.Containers.Bounded_Vectors; |