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 . 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.Unchecked_Deallocation; |
| 32 | |
| 33 | with System; use type System.Address; |
| 34 | |
| 35 | package body Ada.Containers.Vectors is |
| 36 | |
| 37 | procedure Free is |
| 38 | new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); |
| 39 | |
| 40 | type Iterator is new Limited_Controlled and |
| 41 | Vector_Iterator_Interfaces.Reversible_Iterator with |
| 42 | record |
| 43 | Container : Vector_Access; |
| 44 | Index : Index_Type'Base; |
| 45 | end record; |
| 46 | |
| 47 | overriding procedure Finalize (Object : in out Iterator); |
| 48 | |
| 49 | overriding function First (Object : Iterator) return Cursor; |
| 50 | overriding function Last (Object : Iterator) return Cursor; |
| 51 | |
| 52 | overriding function Next |
| 53 | (Object : Iterator; |
| 54 | Position : Cursor) return Cursor; |
| 55 | |
| 56 | overriding function Previous |
| 57 | (Object : Iterator; |
| 58 | Position : Cursor) return Cursor; |
| 59 | |
| 60 | --------- |
| 61 | -- "&" -- |
| 62 | --------- |
| 63 | |
| 64 | function "&" (Left, Right : Vector) return Vector is |
| 65 | LN : constant Count_Type := Length (Left); |
| 66 | RN : constant Count_Type := Length (Right); |
| 67 | N : Count_Type'Base; -- length of result |
| 68 | J : Count_Type'Base; -- for computing intermediate index values |
| 69 | Last : Index_Type'Base; -- Last index of result |
| 70 | |
| 71 | begin |
| 72 | -- We decide that the capacity of the result is the sum of the lengths |
| 73 | -- of the vector parameters. We could decide to make it larger, but we |
| 74 | -- have no basis for knowing how much larger, so we just allocate the |
| 75 | -- minimum amount of storage. |
| 76 | |
| 77 | -- Here we handle the easy cases first, when one of the vector |
| 78 | -- parameters is empty. (We say "easy" because there's nothing to |
| 79 | -- compute, that can potentially overflow.) |
| 80 | |
| 81 | if LN = 0 then |
| 82 | if RN = 0 then |
| 83 | return Empty_Vector; |
| 84 | end if; |
| 85 | |
| 86 | declare |
| 87 | RE : Elements_Array renames |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 88 | Right.Elements.EA (Index_Type'First .. Right.Last); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 89 | |
| 90 | Elements : constant Elements_Access := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 91 | new Elements_Type'(Right.Last, RE); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 92 | |
| 93 | begin |
| 94 | return (Controlled with Elements, Right.Last, 0, 0); |
| 95 | end; |
| 96 | end if; |
| 97 | |
| 98 | if RN = 0 then |
| 99 | declare |
| 100 | LE : Elements_Array renames |
| 101 | Left.Elements.EA (Index_Type'First .. Left.Last); |
| 102 | |
| 103 | Elements : constant Elements_Access := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 104 | new Elements_Type'(Left.Last, LE); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 105 | |
| 106 | begin |
| 107 | return (Controlled with Elements, Left.Last, 0, 0); |
| 108 | end; |
| 109 | |
| 110 | end if; |
| 111 | |
| 112 | -- Neither of the vector parameters is empty, so must compute the length |
| 113 | -- of the result vector and its last index. (This is the harder case, |
| 114 | -- because our computations must avoid overflow.) |
| 115 | |
| 116 | -- There are two constraints we need to satisfy. The first constraint is |
| 117 | -- that a container cannot have more than Count_Type'Last elements, so |
| 118 | -- we must check the sum of the combined lengths. Note that we cannot |
| 119 | -- simply add the lengths, because of the possibility of overflow. |
| 120 | |
| 121 | if LN > Count_Type'Last - RN then |
| 122 | raise Constraint_Error with "new length is out of range"; |
| 123 | end if; |
| 124 | |
| 125 | -- It is now safe compute the length of the new vector, without fear of |
| 126 | -- overflow. |
| 127 | |
| 128 | N := LN + RN; |
| 129 | |
| 130 | -- The second constraint is that the new Last index value cannot |
| 131 | -- exceed Index_Type'Last. We use the wider of Index_Type'Base and |
| 132 | -- Count_Type'Base as the type for intermediate values. |
| 133 | |
| 134 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 135 | |
| 136 | -- We perform a two-part test. First we determine whether the |
| 137 | -- computed Last value lies in the base range of the type, and then |
| 138 | -- determine whether it lies in the range of the index (sub)type. |
| 139 | |
| 140 | -- Last must satisfy this relation: |
| 141 | -- First + Length - 1 <= Last |
| 142 | -- We regroup terms: |
| 143 | -- First - 1 <= Last - Length |
| 144 | -- Which can rewrite as: |
| 145 | -- No_Index <= Last - Length |
| 146 | |
| 147 | if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then |
| 148 | raise Constraint_Error with "new length is out of range"; |
| 149 | end if; |
| 150 | |
| 151 | -- We now know that the computed value of Last is within the base |
| 152 | -- range of the type, so it is safe to compute its value: |
| 153 | |
| 154 | Last := No_Index + Index_Type'Base (N); |
| 155 | |
| 156 | -- Finally we test whether the value is within the range of the |
| 157 | -- generic actual index subtype: |
| 158 | |
| 159 | if Last > Index_Type'Last then |
| 160 | raise Constraint_Error with "new length is out of range"; |
| 161 | end if; |
| 162 | |
| 163 | elsif Index_Type'First <= 0 then |
| 164 | |
| 165 | -- Here we can compute Last directly, in the normal way. We know that |
| 166 | -- No_Index is less than 0, so there is no danger of overflow when |
| 167 | -- adding the (positive) value of length. |
| 168 | |
| 169 | J := Count_Type'Base (No_Index) + N; -- Last |
| 170 | |
| 171 | if J > Count_Type'Base (Index_Type'Last) then |
| 172 | raise Constraint_Error with "new length is out of range"; |
| 173 | end if; |
| 174 | |
| 175 | -- We know that the computed value (having type Count_Type) of Last |
| 176 | -- is within the range of the generic actual index subtype, so it is |
| 177 | -- safe to convert to Index_Type: |
| 178 | |
| 179 | Last := Index_Type'Base (J); |
| 180 | |
| 181 | else |
| 182 | -- Here Index_Type'First (and Index_Type'Last) is positive, so we |
| 183 | -- must test the length indirectly (by working backwards from the |
| 184 | -- largest possible value of Last), in order to prevent overflow. |
| 185 | |
| 186 | J := Count_Type'Base (Index_Type'Last) - N; -- No_Index |
| 187 | |
| 188 | if J < Count_Type'Base (No_Index) then |
| 189 | raise Constraint_Error with "new length is out of range"; |
| 190 | end if; |
| 191 | |
| 192 | -- We have determined that the result length would not create a Last |
| 193 | -- index value outside of the range of Index_Type, so we can now |
| 194 | -- safely compute its value. |
| 195 | |
| 196 | Last := Index_Type'Base (Count_Type'Base (No_Index) + N); |
| 197 | end if; |
| 198 | |
| 199 | declare |
| 200 | LE : Elements_Array renames |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 201 | Left.Elements.EA (Index_Type'First .. Left.Last); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 202 | |
| 203 | RE : Elements_Array renames |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 204 | Right.Elements.EA (Index_Type'First .. Right.Last); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 205 | |
| 206 | Elements : constant Elements_Access := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 207 | new Elements_Type'(Last, LE & RE); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 208 | |
| 209 | begin |
| 210 | return (Controlled with Elements, Last, 0, 0); |
| 211 | end; |
| 212 | end "&"; |
| 213 | |
| 214 | function "&" (Left : Vector; Right : Element_Type) return Vector is |
| 215 | begin |
| 216 | -- We decide that the capacity of the result is the sum of the lengths |
| 217 | -- of the parameters. We could decide to make it larger, but we have no |
| 218 | -- basis for knowing how much larger, so we just allocate the minimum |
| 219 | -- amount of storage. |
| 220 | |
| 221 | -- Handle easy case first, when the vector parameter (Left) is empty |
| 222 | |
| 223 | if Left.Is_Empty then |
| 224 | declare |
| 225 | Elements : constant Elements_Access := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 226 | new Elements_Type' |
| 227 | (Last => Index_Type'First, |
| 228 | EA => (others => Right)); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 229 | |
| 230 | begin |
| 231 | return (Controlled with Elements, Index_Type'First, 0, 0); |
| 232 | end; |
| 233 | end if; |
| 234 | |
| 235 | -- The vector parameter is not empty, so we must compute the length of |
| 236 | -- the result vector and its last index, but in such a way that overflow |
| 237 | -- is avoided. We must satisfy two constraints: the new length cannot |
| 238 | -- exceed Count_Type'Last, and the new Last index cannot exceed |
| 239 | -- Index_Type'Last. |
| 240 | |
| 241 | if Left.Length = Count_Type'Last then |
| 242 | raise Constraint_Error with "new length is out of range"; |
| 243 | end if; |
| 244 | |
| 245 | if Left.Last >= Index_Type'Last then |
| 246 | raise Constraint_Error with "new length is out of range"; |
| 247 | end if; |
| 248 | |
| 249 | declare |
| 250 | Last : constant Index_Type := Left.Last + 1; |
| 251 | |
| 252 | LE : Elements_Array renames |
| 253 | Left.Elements.EA (Index_Type'First .. Left.Last); |
| 254 | |
| 255 | Elements : constant Elements_Access := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 256 | new Elements_Type'(Last => Last, EA => LE & Right); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 257 | |
| 258 | begin |
| 259 | return (Controlled with Elements, Last, 0, 0); |
| 260 | end; |
| 261 | end "&"; |
| 262 | |
| 263 | function "&" (Left : Element_Type; Right : Vector) return Vector is |
| 264 | begin |
| 265 | -- We decide that the capacity of the result is the sum of the lengths |
| 266 | -- of the parameters. We could decide to make it larger, but we have no |
| 267 | -- basis for knowing how much larger, so we just allocate the minimum |
| 268 | -- amount of storage. |
| 269 | |
| 270 | -- Handle easy case first, when the vector parameter (Right) is empty |
| 271 | |
| 272 | if Right.Is_Empty then |
| 273 | declare |
| 274 | Elements : constant Elements_Access := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 275 | new Elements_Type' |
| 276 | (Last => Index_Type'First, |
| 277 | EA => (others => Left)); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 278 | |
| 279 | begin |
| 280 | return (Controlled with Elements, Index_Type'First, 0, 0); |
| 281 | end; |
| 282 | end if; |
| 283 | |
| 284 | -- The vector parameter is not empty, so we must compute the length of |
| 285 | -- the result vector and its last index, but in such a way that overflow |
| 286 | -- is avoided. We must satisfy two constraints: the new length cannot |
| 287 | -- exceed Count_Type'Last, and the new Last index cannot exceed |
| 288 | -- Index_Type'Last. |
| 289 | |
| 290 | if Right.Length = Count_Type'Last then |
| 291 | raise Constraint_Error with "new length is out of range"; |
| 292 | end if; |
| 293 | |
| 294 | if Right.Last >= Index_Type'Last then |
| 295 | raise Constraint_Error with "new length is out of range"; |
| 296 | end if; |
| 297 | |
| 298 | declare |
| 299 | Last : constant Index_Type := Right.Last + 1; |
| 300 | |
| 301 | RE : Elements_Array renames |
| 302 | Right.Elements.EA (Index_Type'First .. Right.Last); |
| 303 | |
| 304 | Elements : constant Elements_Access := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 305 | new Elements_Type' |
| 306 | (Last => Last, |
| 307 | EA => Left & RE); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 308 | |
| 309 | begin |
| 310 | return (Controlled with Elements, Last, 0, 0); |
| 311 | end; |
| 312 | end "&"; |
| 313 | |
| 314 | function "&" (Left, Right : Element_Type) return Vector is |
| 315 | begin |
| 316 | -- We decide that the capacity of the result is the sum of the lengths |
| 317 | -- of the parameters. We could decide to make it larger, but we have no |
| 318 | -- basis for knowing how much larger, so we just allocate the minimum |
| 319 | -- amount of storage. |
| 320 | |
| 321 | -- We must compute the length of the result vector and its last index, |
| 322 | -- but in such a way that overflow is avoided. We must satisfy two |
| 323 | -- constraints: the new length cannot exceed Count_Type'Last (here, we |
| 324 | -- know that that condition is satisfied), and the new Last index cannot |
| 325 | -- exceed Index_Type'Last. |
| 326 | |
| 327 | if Index_Type'First >= Index_Type'Last then |
| 328 | raise Constraint_Error with "new length is out of range"; |
| 329 | end if; |
| 330 | |
| 331 | declare |
| 332 | Last : constant Index_Type := Index_Type'First + 1; |
| 333 | |
| 334 | Elements : constant Elements_Access := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 335 | new Elements_Type' |
| 336 | (Last => Last, |
| 337 | EA => (Left, Right)); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 338 | |
| 339 | begin |
| 340 | return (Controlled with Elements, Last, 0, 0); |
| 341 | end; |
| 342 | end "&"; |
| 343 | |
| 344 | --------- |
| 345 | -- "=" -- |
| 346 | --------- |
| 347 | |
| 348 | overriding function "=" (Left, Right : Vector) return Boolean is |
| 349 | begin |
| 350 | if Left'Address = Right'Address then |
| 351 | return True; |
| 352 | end if; |
| 353 | |
| 354 | if Left.Last /= Right.Last then |
| 355 | return False; |
| 356 | end if; |
| 357 | |
| 358 | for J in Index_Type range Index_Type'First .. Left.Last loop |
| 359 | if Left.Elements.EA (J) /= Right.Elements.EA (J) then |
| 360 | return False; |
| 361 | end if; |
| 362 | end loop; |
| 363 | |
| 364 | return True; |
| 365 | end "="; |
| 366 | |
| 367 | ------------ |
| 368 | -- Adjust -- |
| 369 | ------------ |
| 370 | |
| 371 | procedure Adjust (Container : in out Vector) is |
| 372 | begin |
| 373 | if Container.Last = No_Index then |
| 374 | Container.Elements := null; |
| 375 | return; |
| 376 | end if; |
| 377 | |
| 378 | declare |
| 379 | L : constant Index_Type := Container.Last; |
| 380 | EA : Elements_Array renames |
| 381 | Container.Elements.EA (Index_Type'First .. L); |
| 382 | |
| 383 | begin |
| 384 | Container.Elements := null; |
| 385 | Container.Busy := 0; |
| 386 | Container.Lock := 0; |
| 387 | |
| 388 | -- Note: it may seem that the following assignment to Container.Last |
| 389 | -- is useless, since we assign it to L below. However this code is |
| 390 | -- used in case 'new Elements_Type' below raises an exception, to |
| 391 | -- keep Container in a consistent state. |
| 392 | |
| 393 | Container.Last := No_Index; |
| 394 | Container.Elements := new Elements_Type'(L, EA); |
| 395 | Container.Last := L; |
| 396 | end; |
| 397 | end Adjust; |
| 398 | |
| 399 | procedure Adjust (Control : in out Reference_Control_Type) is |
| 400 | begin |
| 401 | if Control.Container /= null then |
| 402 | declare |
| 403 | C : Vector renames Control.Container.all; |
| 404 | B : Natural renames C.Busy; |
| 405 | L : Natural renames C.Lock; |
| 406 | begin |
| 407 | B := B + 1; |
| 408 | L := L + 1; |
| 409 | end; |
| 410 | end if; |
| 411 | end Adjust; |
| 412 | |
| 413 | ------------ |
| 414 | -- Append -- |
| 415 | ------------ |
| 416 | |
| 417 | procedure Append (Container : in out Vector; New_Item : Vector) is |
| 418 | begin |
| 419 | if Is_Empty (New_Item) then |
| 420 | return; |
| 421 | end if; |
| 422 | |
| 423 | if Container.Last = Index_Type'Last then |
| 424 | raise Constraint_Error with "vector is already at its maximum length"; |
| 425 | end if; |
| 426 | |
| 427 | Insert |
| 428 | (Container, |
| 429 | Container.Last + 1, |
| 430 | New_Item); |
| 431 | end Append; |
| 432 | |
| 433 | procedure Append |
| 434 | (Container : in out Vector; |
| 435 | New_Item : Element_Type; |
| 436 | Count : Count_Type := 1) |
| 437 | is |
| 438 | begin |
| 439 | if Count = 0 then |
| 440 | return; |
| 441 | end if; |
| 442 | |
| 443 | if Container.Last = Index_Type'Last then |
| 444 | raise Constraint_Error with "vector is already at its maximum length"; |
| 445 | end if; |
| 446 | |
| 447 | Insert |
| 448 | (Container, |
| 449 | Container.Last + 1, |
| 450 | New_Item, |
| 451 | Count); |
| 452 | end Append; |
| 453 | |
| 454 | ------------ |
| 455 | -- Assign -- |
| 456 | ------------ |
| 457 | |
| 458 | procedure Assign (Target : in out Vector; Source : Vector) is |
| 459 | begin |
| 460 | if Target'Address = Source'Address then |
| 461 | return; |
| 462 | end if; |
| 463 | |
| 464 | Target.Clear; |
| 465 | Target.Append (Source); |
| 466 | end Assign; |
| 467 | |
| 468 | -------------- |
| 469 | -- Capacity -- |
| 470 | -------------- |
| 471 | |
| 472 | function Capacity (Container : Vector) return Count_Type is |
| 473 | begin |
| 474 | if Container.Elements = null then |
| 475 | return 0; |
| 476 | else |
| 477 | return Container.Elements.EA'Length; |
| 478 | end if; |
| 479 | end Capacity; |
| 480 | |
| 481 | ----------- |
| 482 | -- Clear -- |
| 483 | ----------- |
| 484 | |
| 485 | procedure Clear (Container : in out Vector) is |
| 486 | begin |
| 487 | if Container.Busy > 0 then |
| 488 | raise Program_Error with |
| 489 | "attempt to tamper with cursors (vector is busy)"; |
| 490 | else |
| 491 | Container.Last := No_Index; |
| 492 | end if; |
| 493 | end Clear; |
| 494 | |
| 495 | ------------------------ |
| 496 | -- Constant_Reference -- |
| 497 | ------------------------ |
| 498 | |
| 499 | function Constant_Reference |
| 500 | (Container : aliased Vector; |
| 501 | Position : Cursor) return Constant_Reference_Type |
| 502 | is |
| 503 | begin |
| 504 | if Position.Container = null then |
| 505 | raise Constraint_Error with "Position cursor has no element"; |
| 506 | end if; |
| 507 | |
| 508 | if Position.Container /= Container'Unrestricted_Access then |
| 509 | raise Program_Error with "Position cursor denotes wrong container"; |
| 510 | end if; |
| 511 | |
| 512 | if Position.Index > Position.Container.Last then |
| 513 | raise Constraint_Error with "Position cursor is out of range"; |
| 514 | end if; |
| 515 | |
| 516 | declare |
| 517 | C : Vector renames Position.Container.all; |
| 518 | B : Natural renames C.Busy; |
| 519 | L : Natural renames C.Lock; |
| 520 | begin |
| 521 | return R : constant Constant_Reference_Type := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 522 | (Element => Container.Elements.EA (Position.Index)'Access, |
| 523 | Control => (Controlled with Container'Unrestricted_Access)) |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 524 | do |
| 525 | B := B + 1; |
| 526 | L := L + 1; |
| 527 | end return; |
| 528 | end; |
| 529 | end Constant_Reference; |
| 530 | |
| 531 | function Constant_Reference |
| 532 | (Container : aliased Vector; |
| 533 | Index : Index_Type) return Constant_Reference_Type |
| 534 | is |
| 535 | begin |
| 536 | if Index > Container.Last then |
| 537 | raise Constraint_Error with "Index is out of range"; |
| 538 | else |
| 539 | declare |
| 540 | C : Vector renames Container'Unrestricted_Access.all; |
| 541 | B : Natural renames C.Busy; |
| 542 | L : Natural renames C.Lock; |
| 543 | begin |
| 544 | return R : constant Constant_Reference_Type := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 545 | (Element => Container.Elements.EA (Index)'Access, |
| 546 | Control => (Controlled with Container'Unrestricted_Access)) |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 547 | do |
| 548 | B := B + 1; |
| 549 | L := L + 1; |
| 550 | end return; |
| 551 | end; |
| 552 | end if; |
| 553 | end Constant_Reference; |
| 554 | |
| 555 | -------------- |
| 556 | -- Contains -- |
| 557 | -------------- |
| 558 | |
| 559 | function Contains |
| 560 | (Container : Vector; |
| 561 | Item : Element_Type) return Boolean |
| 562 | is |
| 563 | begin |
| 564 | return Find_Index (Container, Item) /= No_Index; |
| 565 | end Contains; |
| 566 | |
| 567 | ---------- |
| 568 | -- Copy -- |
| 569 | ---------- |
| 570 | |
| 571 | function Copy |
| 572 | (Source : Vector; |
| 573 | Capacity : Count_Type := 0) return Vector |
| 574 | is |
| 575 | C : Count_Type; |
| 576 | |
| 577 | begin |
| 578 | if Capacity = 0 then |
| 579 | C := Source.Length; |
| 580 | |
| 581 | elsif Capacity >= Source.Length then |
| 582 | C := Capacity; |
| 583 | |
| 584 | else |
| 585 | raise Capacity_Error |
| 586 | with "Requested capacity is less than Source length"; |
| 587 | end if; |
| 588 | |
| 589 | return Target : Vector do |
| 590 | Target.Reserve_Capacity (C); |
| 591 | Target.Assign (Source); |
| 592 | end return; |
| 593 | end Copy; |
| 594 | |
| 595 | ------------ |
| 596 | -- Delete -- |
| 597 | ------------ |
| 598 | |
| 599 | procedure Delete |
| 600 | (Container : in out Vector; |
| 601 | Index : Extended_Index; |
| 602 | Count : Count_Type := 1) |
| 603 | is |
| 604 | Old_Last : constant Index_Type'Base := Container.Last; |
| 605 | New_Last : Index_Type'Base; |
| 606 | Count2 : Count_Type'Base; -- count of items from Index to Old_Last |
| 607 | J : Index_Type'Base; -- first index of items that slide down |
| 608 | |
| 609 | begin |
| 610 | -- Delete removes items from the vector, the number of which is the |
| 611 | -- minimum of the specified Count and the items (if any) that exist from |
| 612 | -- Index to Container.Last. There are no constraints on the specified |
| 613 | -- value of Count (it can be larger than what's available at this |
| 614 | -- position in the vector, for example), but there are constraints on |
| 615 | -- the allowed values of the Index. |
| 616 | |
| 617 | -- As a precondition on the generic actual Index_Type, the base type |
| 618 | -- must include Index_Type'Pred (Index_Type'First); this is the value |
| 619 | -- that Container.Last assumes when the vector is empty. However, we do |
| 620 | -- not allow that as the value for Index when specifying which items |
| 621 | -- should be deleted, so we must manually check. (That the user is |
| 622 | -- allowed to specify the value at all here is a consequence of the |
| 623 | -- declaration of the Extended_Index subtype, which includes the values |
| 624 | -- in the base range that immediately precede and immediately follow the |
| 625 | -- values in the Index_Type.) |
| 626 | |
| 627 | if Index < Index_Type'First then |
| 628 | raise Constraint_Error with "Index is out of range (too small)"; |
| 629 | end if; |
| 630 | |
| 631 | -- We do allow a value greater than Container.Last to be specified as |
| 632 | -- the Index, but only if it's immediately greater. This allows the |
| 633 | -- corner case of deleting no items from the back end of the vector to |
| 634 | -- be treated as a no-op. (It is assumed that specifying an index value |
| 635 | -- greater than Last + 1 indicates some deeper flaw in the caller's |
| 636 | -- algorithm, so that case is treated as a proper error.) |
| 637 | |
| 638 | if Index > Old_Last then |
| 639 | if Index > Old_Last + 1 then |
| 640 | raise Constraint_Error with "Index is out of range (too large)"; |
| 641 | end if; |
| 642 | |
| 643 | return; |
| 644 | end if; |
| 645 | |
| 646 | -- Here and elsewhere we treat deleting 0 items from the container as a |
| 647 | -- no-op, even when the container is busy, so we simply return. |
| 648 | |
| 649 | if Count = 0 then |
| 650 | return; |
| 651 | end if; |
| 652 | |
| 653 | -- The tampering bits exist to prevent an item from being deleted (or |
| 654 | -- otherwise harmfully manipulated) while it is being visited. Query, |
| 655 | -- Update, and Iterate increment the busy count on entry, and decrement |
| 656 | -- the count on exit. Delete checks the count to determine whether it is |
| 657 | -- being called while the associated callback procedure is 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 | -- We first calculate what's available for deletion starting at |
| 665 | -- Index. Here and elsewhere we use the wider of Index_Type'Base and |
| 666 | -- Count_Type'Base as the type for intermediate values. (See function |
| 667 | -- Length for more information.) |
| 668 | |
| 669 | if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then |
| 670 | Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; |
| 671 | |
| 672 | else |
| 673 | Count2 := Count_Type'Base (Old_Last - Index + 1); |
| 674 | end if; |
| 675 | |
| 676 | -- If more elements are requested (Count) for deletion than are |
| 677 | -- available (Count2) for deletion beginning at Index, then everything |
| 678 | -- from Index is deleted. There are no elements to slide down, and so |
| 679 | -- all we need to do is set the value of Container.Last. |
| 680 | |
| 681 | if Count >= Count2 then |
| 682 | Container.Last := Index - 1; |
| 683 | return; |
| 684 | end if; |
| 685 | |
| 686 | -- There are some elements aren't being deleted (the requested count was |
| 687 | -- less than the available count), so we must slide them down to |
| 688 | -- Index. We first calculate the index values of the respective array |
| 689 | -- slices, using the wider of Index_Type'Base and Count_Type'Base as the |
| 690 | -- type for intermediate calculations. For the elements that slide down, |
| 691 | -- index value New_Last is the last index value of their new home, and |
| 692 | -- index value J is the first index of their old home. |
| 693 | |
| 694 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 695 | New_Last := Old_Last - Index_Type'Base (Count); |
| 696 | J := Index + Index_Type'Base (Count); |
| 697 | |
| 698 | else |
| 699 | New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); |
| 700 | J := Index_Type'Base (Count_Type'Base (Index) + Count); |
| 701 | end if; |
| 702 | |
| 703 | -- The internal elements array isn't guaranteed to exist unless we have |
| 704 | -- elements, but we have that guarantee here because we know we have |
| 705 | -- elements to slide. The array index values for each slice have |
| 706 | -- already been determined, so we just slide down to Index the elements |
| 707 | -- that weren't deleted. |
| 708 | |
| 709 | declare |
| 710 | EA : Elements_Array renames Container.Elements.EA; |
| 711 | |
| 712 | begin |
| 713 | EA (Index .. New_Last) := EA (J .. Old_Last); |
| 714 | Container.Last := New_Last; |
| 715 | end; |
| 716 | end Delete; |
| 717 | |
| 718 | procedure Delete |
| 719 | (Container : in out Vector; |
| 720 | Position : in out Cursor; |
| 721 | Count : Count_Type := 1) |
| 722 | is |
| 723 | pragma Warnings (Off, Position); |
| 724 | |
| 725 | begin |
| 726 | if Position.Container = null then |
| 727 | raise Constraint_Error with "Position cursor has no element"; |
| 728 | end if; |
| 729 | |
| 730 | if Position.Container /= Container'Unrestricted_Access then |
| 731 | raise Program_Error with "Position cursor denotes wrong container"; |
| 732 | end if; |
| 733 | |
| 734 | if Position.Index > Container.Last then |
| 735 | raise Program_Error with "Position index is out of range"; |
| 736 | end if; |
| 737 | |
| 738 | Delete (Container, Position.Index, Count); |
| 739 | Position := No_Element; |
| 740 | end Delete; |
| 741 | |
| 742 | ------------------ |
| 743 | -- Delete_First -- |
| 744 | ------------------ |
| 745 | |
| 746 | procedure Delete_First |
| 747 | (Container : in out Vector; |
| 748 | Count : Count_Type := 1) |
| 749 | is |
| 750 | begin |
| 751 | if Count = 0 then |
| 752 | return; |
| 753 | end if; |
| 754 | |
| 755 | if Count >= Length (Container) then |
| 756 | Clear (Container); |
| 757 | return; |
| 758 | end if; |
| 759 | |
| 760 | Delete (Container, Index_Type'First, Count); |
| 761 | end Delete_First; |
| 762 | |
| 763 | ----------------- |
| 764 | -- Delete_Last -- |
| 765 | ----------------- |
| 766 | |
| 767 | procedure Delete_Last |
| 768 | (Container : in out Vector; |
| 769 | Count : Count_Type := 1) |
| 770 | is |
| 771 | begin |
| 772 | -- It is not permitted to delete items while the container is busy (for |
| 773 | -- example, we're in the middle of a passive iteration). However, we |
| 774 | -- always treat deleting 0 items as a no-op, even when we're busy, so we |
| 775 | -- simply return without checking. |
| 776 | |
| 777 | if Count = 0 then |
| 778 | return; |
| 779 | end if; |
| 780 | |
| 781 | -- The tampering bits exist to prevent an item from being deleted (or |
| 782 | -- otherwise harmfully manipulated) while it is being visited. Query, |
| 783 | -- Update, and Iterate increment the busy count on entry, and decrement |
| 784 | -- the count on exit. Delete_Last checks the count to determine whether |
| 785 | -- it is being called while the associated callback procedure is |
| 786 | -- executing. |
| 787 | |
| 788 | if Container.Busy > 0 then |
| 789 | raise Program_Error with |
| 790 | "attempt to tamper with cursors (vector is busy)"; |
| 791 | end if; |
| 792 | |
| 793 | -- There is no restriction on how large Count can be when deleting |
| 794 | -- items. If it is equal or greater than the current length, then this |
| 795 | -- is equivalent to clearing the vector. (In particular, there's no need |
| 796 | -- for us to actually calculate the new value for Last.) |
| 797 | |
| 798 | -- If the requested count is less than the current length, then we must |
| 799 | -- calculate the new value for Last. For the type we use the widest of |
| 800 | -- Index_Type'Base and Count_Type'Base for the intermediate values of |
| 801 | -- our calculation. (See the comments in Length for more information.) |
| 802 | |
| 803 | if Count >= Container.Length then |
| 804 | Container.Last := No_Index; |
| 805 | |
| 806 | elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 807 | Container.Last := Container.Last - Index_Type'Base (Count); |
| 808 | |
| 809 | else |
| 810 | Container.Last := |
| 811 | Index_Type'Base (Count_Type'Base (Container.Last) - Count); |
| 812 | end if; |
| 813 | end Delete_Last; |
| 814 | |
| 815 | ------------- |
| 816 | -- Element -- |
| 817 | ------------- |
| 818 | |
| 819 | function Element |
| 820 | (Container : Vector; |
| 821 | Index : Index_Type) return Element_Type |
| 822 | is |
| 823 | begin |
| 824 | if Index > Container.Last then |
| 825 | raise Constraint_Error with "Index is out of range"; |
| 826 | end if; |
| 827 | |
| 828 | return Container.Elements.EA (Index); |
| 829 | end Element; |
| 830 | |
| 831 | function Element (Position : Cursor) return Element_Type is |
| 832 | begin |
| 833 | if Position.Container = null then |
| 834 | raise Constraint_Error with "Position cursor has no element"; |
| 835 | elsif Position.Index > Position.Container.Last then |
| 836 | raise Constraint_Error with "Position cursor is out of range"; |
| 837 | else |
| 838 | return Position.Container.Elements.EA (Position.Index); |
| 839 | end if; |
| 840 | end Element; |
| 841 | |
| 842 | -------------- |
| 843 | -- Finalize -- |
| 844 | -------------- |
| 845 | |
| 846 | procedure Finalize (Container : in out Vector) is |
| 847 | X : Elements_Access := Container.Elements; |
| 848 | |
| 849 | begin |
| 850 | if Container.Busy > 0 then |
| 851 | raise Program_Error with |
| 852 | "attempt to tamper with cursors (vector is busy)"; |
| 853 | end if; |
| 854 | |
| 855 | Container.Elements := null; |
| 856 | Container.Last := No_Index; |
| 857 | Free (X); |
| 858 | end Finalize; |
| 859 | |
| 860 | procedure Finalize (Object : in out Iterator) is |
| 861 | B : Natural renames Object.Container.Busy; |
| 862 | begin |
| 863 | B := B - 1; |
| 864 | end Finalize; |
| 865 | |
| 866 | procedure Finalize (Control : in out Reference_Control_Type) is |
| 867 | begin |
| 868 | if Control.Container /= null then |
| 869 | declare |
| 870 | C : Vector renames Control.Container.all; |
| 871 | B : Natural renames C.Busy; |
| 872 | L : Natural renames C.Lock; |
| 873 | begin |
| 874 | B := B - 1; |
| 875 | L := L - 1; |
| 876 | end; |
| 877 | |
| 878 | Control.Container := null; |
| 879 | end if; |
| 880 | end Finalize; |
| 881 | |
| 882 | ---------- |
| 883 | -- Find -- |
| 884 | ---------- |
| 885 | |
| 886 | function Find |
| 887 | (Container : Vector; |
| 888 | Item : Element_Type; |
| 889 | Position : Cursor := No_Element) return Cursor |
| 890 | is |
| 891 | begin |
| 892 | if Position.Container /= null then |
| 893 | if Position.Container /= Container'Unrestricted_Access then |
| 894 | raise Program_Error with "Position cursor denotes wrong container"; |
| 895 | end if; |
| 896 | |
| 897 | if Position.Index > Container.Last then |
| 898 | raise Program_Error with "Position index is out of range"; |
| 899 | end if; |
| 900 | end if; |
| 901 | |
| 902 | for J in Position.Index .. Container.Last loop |
| 903 | if Container.Elements.EA (J) = Item then |
| 904 | return (Container'Unrestricted_Access, J); |
| 905 | end if; |
| 906 | end loop; |
| 907 | |
| 908 | return No_Element; |
| 909 | end Find; |
| 910 | |
| 911 | ---------------- |
| 912 | -- Find_Index -- |
| 913 | ---------------- |
| 914 | |
| 915 | function Find_Index |
| 916 | (Container : Vector; |
| 917 | Item : Element_Type; |
| 918 | Index : Index_Type := Index_Type'First) return Extended_Index |
| 919 | is |
| 920 | begin |
| 921 | for Indx in Index .. Container.Last loop |
| 922 | if Container.Elements.EA (Indx) = Item then |
| 923 | return Indx; |
| 924 | end if; |
| 925 | end loop; |
| 926 | |
| 927 | return No_Index; |
| 928 | end Find_Index; |
| 929 | |
| 930 | ----------- |
| 931 | -- First -- |
| 932 | ----------- |
| 933 | |
| 934 | function First (Container : Vector) return Cursor is |
| 935 | begin |
| 936 | if Is_Empty (Container) then |
| 937 | return No_Element; |
| 938 | else |
| 939 | return (Container'Unrestricted_Access, Index_Type'First); |
| 940 | end if; |
| 941 | end First; |
| 942 | |
| 943 | function First (Object : Iterator) return Cursor is |
| 944 | begin |
| 945 | -- The value of the iterator object's Index component influences the |
| 946 | -- behavior of the First (and Last) selector function. |
| 947 | |
| 948 | -- When the Index component is No_Index, this means the iterator |
| 949 | -- object was constructed without a start expression, in which case the |
| 950 | -- (forward) iteration starts from the (logical) beginning of the entire |
| 951 | -- sequence of items (corresponding to Container.First, for a forward |
| 952 | -- iterator). |
| 953 | |
| 954 | -- Otherwise, this is iteration over a partial sequence of items. |
| 955 | -- When the Index component isn't No_Index, the iterator object was |
| 956 | -- constructed with a start expression, that specifies the position |
| 957 | -- from which the (forward) partial iteration begins. |
| 958 | |
| 959 | if Object.Index = No_Index then |
| 960 | return First (Object.Container.all); |
| 961 | else |
| 962 | return Cursor'(Object.Container, Object.Index); |
| 963 | end if; |
| 964 | end First; |
| 965 | |
| 966 | ------------------- |
| 967 | -- First_Element -- |
| 968 | ------------------- |
| 969 | |
| 970 | function First_Element (Container : Vector) return Element_Type is |
| 971 | begin |
| 972 | if Container.Last = No_Index then |
| 973 | raise Constraint_Error with "Container is empty"; |
| 974 | else |
| 975 | return Container.Elements.EA (Index_Type'First); |
| 976 | end if; |
| 977 | end First_Element; |
| 978 | |
| 979 | ----------------- |
| 980 | -- First_Index -- |
| 981 | ----------------- |
| 982 | |
| 983 | function First_Index (Container : Vector) return Index_Type is |
| 984 | pragma Unreferenced (Container); |
| 985 | begin |
| 986 | return Index_Type'First; |
| 987 | end First_Index; |
| 988 | |
| 989 | --------------------- |
| 990 | -- Generic_Sorting -- |
| 991 | --------------------- |
| 992 | |
| 993 | package body Generic_Sorting is |
| 994 | |
| 995 | --------------- |
| 996 | -- Is_Sorted -- |
| 997 | --------------- |
| 998 | |
| 999 | function Is_Sorted (Container : Vector) return Boolean is |
| 1000 | begin |
| 1001 | if Container.Last <= Index_Type'First then |
| 1002 | return True; |
| 1003 | end if; |
| 1004 | |
| 1005 | declare |
| 1006 | EA : Elements_Array renames Container.Elements.EA; |
| 1007 | begin |
| 1008 | for J in Index_Type'First .. Container.Last - 1 loop |
| 1009 | if EA (J + 1) < EA (J) then |
| 1010 | return False; |
| 1011 | end if; |
| 1012 | end loop; |
| 1013 | end; |
| 1014 | |
| 1015 | return True; |
| 1016 | end Is_Sorted; |
| 1017 | |
| 1018 | ----------- |
| 1019 | -- Merge -- |
| 1020 | ----------- |
| 1021 | |
| 1022 | procedure Merge (Target, Source : in out Vector) is |
| 1023 | I : Index_Type'Base := Target.Last; |
| 1024 | J : Index_Type'Base; |
| 1025 | |
| 1026 | begin |
| 1027 | -- The semantics of Merge changed slightly per AI05-0021. It was |
| 1028 | -- originally the case that if Target and Source denoted the same |
| 1029 | -- container object, then the GNAT implementation of Merge did |
| 1030 | -- nothing. However, it was argued that RM05 did not precisely |
| 1031 | -- specify the semantics for this corner case. The decision of the |
| 1032 | -- ARG was that if Target and Source denote the same non-empty |
| 1033 | -- container object, then Program_Error is raised. |
| 1034 | |
| 1035 | if Source.Last < Index_Type'First then -- Source is empty |
| 1036 | return; |
| 1037 | end if; |
| 1038 | |
| 1039 | if Target'Address = Source'Address then |
| 1040 | raise Program_Error with |
| 1041 | "Target and Source denote same non-empty container"; |
| 1042 | end if; |
| 1043 | |
| 1044 | if Target.Last < Index_Type'First then -- Target is empty |
| 1045 | Move (Target => Target, Source => Source); |
| 1046 | return; |
| 1047 | end if; |
| 1048 | |
| 1049 | if Source.Busy > 0 then |
| 1050 | raise Program_Error with |
| 1051 | "attempt to tamper with cursors (vector is busy)"; |
| 1052 | end if; |
| 1053 | |
| 1054 | Target.Set_Length (Length (Target) + Length (Source)); |
| 1055 | |
| 1056 | declare |
| 1057 | TA : Elements_Array renames Target.Elements.EA; |
| 1058 | SA : Elements_Array renames Source.Elements.EA; |
| 1059 | |
| 1060 | begin |
| 1061 | J := Target.Last; |
| 1062 | while Source.Last >= Index_Type'First loop |
| 1063 | pragma Assert (Source.Last <= Index_Type'First |
| 1064 | or else not (SA (Source.Last) < |
| 1065 | SA (Source.Last - 1))); |
| 1066 | |
| 1067 | if I < Index_Type'First then |
| 1068 | TA (Index_Type'First .. J) := |
| 1069 | SA (Index_Type'First .. Source.Last); |
| 1070 | |
| 1071 | Source.Last := No_Index; |
| 1072 | return; |
| 1073 | end if; |
| 1074 | |
| 1075 | pragma Assert (I <= Index_Type'First |
| 1076 | or else not (TA (I) < TA (I - 1))); |
| 1077 | |
| 1078 | if SA (Source.Last) < TA (I) then |
| 1079 | TA (J) := TA (I); |
| 1080 | I := I - 1; |
| 1081 | |
| 1082 | else |
| 1083 | TA (J) := SA (Source.Last); |
| 1084 | Source.Last := Source.Last - 1; |
| 1085 | end if; |
| 1086 | |
| 1087 | J := J - 1; |
| 1088 | end loop; |
| 1089 | end; |
| 1090 | end Merge; |
| 1091 | |
| 1092 | ---------- |
| 1093 | -- Sort -- |
| 1094 | ---------- |
| 1095 | |
| 1096 | procedure Sort (Container : in out Vector) is |
| 1097 | procedure Sort is |
| 1098 | new Generic_Array_Sort |
| 1099 | (Index_Type => Index_Type, |
| 1100 | Element_Type => Element_Type, |
| 1101 | Array_Type => Elements_Array, |
| 1102 | "<" => "<"); |
| 1103 | |
| 1104 | begin |
| 1105 | if Container.Last <= Index_Type'First then |
| 1106 | return; |
| 1107 | end if; |
| 1108 | |
| 1109 | -- The exception behavior for the vector container must match that |
| 1110 | -- for the list container, so we check for cursor tampering here |
| 1111 | -- (which will catch more things) instead of for element tampering |
| 1112 | -- (which will catch fewer things). It's true that the elements of |
| 1113 | -- this vector container could be safely moved around while (say) an |
| 1114 | -- iteration is taking place (iteration only increments the busy |
| 1115 | -- counter), and so technically all we would need here is a test for |
| 1116 | -- element tampering (indicated by the lock counter), that's simply |
| 1117 | -- an artifact of our array-based implementation. Logically Sort |
| 1118 | -- requires a check for cursor tampering. |
| 1119 | |
| 1120 | if Container.Busy > 0 then |
| 1121 | raise Program_Error with |
| 1122 | "attempt to tamper with cursors (vector is busy)"; |
| 1123 | end if; |
| 1124 | |
| 1125 | Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); |
| 1126 | end Sort; |
| 1127 | |
| 1128 | end Generic_Sorting; |
| 1129 | |
| 1130 | ----------------- |
| 1131 | -- Has_Element -- |
| 1132 | ----------------- |
| 1133 | |
| 1134 | function Has_Element (Position : Cursor) return Boolean is |
| 1135 | begin |
| 1136 | return Position /= No_Element; |
| 1137 | end Has_Element; |
| 1138 | |
| 1139 | ------------ |
| 1140 | -- Insert -- |
| 1141 | ------------ |
| 1142 | |
| 1143 | procedure Insert |
| 1144 | (Container : in out Vector; |
| 1145 | Before : Extended_Index; |
| 1146 | New_Item : Element_Type; |
| 1147 | Count : Count_Type := 1) |
| 1148 | is |
| 1149 | Old_Length : constant Count_Type := Container.Length; |
| 1150 | |
| 1151 | Max_Length : Count_Type'Base; -- determined from range of Index_Type |
| 1152 | New_Length : Count_Type'Base; -- sum of current length and Count |
| 1153 | New_Last : Index_Type'Base; -- last index of vector after insertion |
| 1154 | |
| 1155 | Index : Index_Type'Base; -- scratch for intermediate values |
| 1156 | J : Count_Type'Base; -- scratch |
| 1157 | |
| 1158 | New_Capacity : Count_Type'Base; -- length of new, expanded array |
| 1159 | Dst_Last : Index_Type'Base; -- last index of new, expanded array |
| 1160 | Dst : Elements_Access; -- new, expanded internal array |
| 1161 | |
| 1162 | begin |
| 1163 | -- As a precondition on the generic actual Index_Type, the base type |
| 1164 | -- must include Index_Type'Pred (Index_Type'First); this is the value |
| 1165 | -- that Container.Last assumes when the vector is empty. However, we do |
| 1166 | -- not allow that as the value for Index when specifying where the new |
| 1167 | -- items should be inserted, so we must manually check. (That the user |
| 1168 | -- is allowed to specify the value at all here is a consequence of the |
| 1169 | -- declaration of the Extended_Index subtype, which includes the values |
| 1170 | -- in the base range that immediately precede and immediately follow the |
| 1171 | -- values in the Index_Type.) |
| 1172 | |
| 1173 | if Before < Index_Type'First then |
| 1174 | raise Constraint_Error with |
| 1175 | "Before index is out of range (too small)"; |
| 1176 | end if; |
| 1177 | |
| 1178 | -- We do allow a value greater than Container.Last to be specified as |
| 1179 | -- the Index, but only if it's immediately greater. This allows for the |
| 1180 | -- case of appending items to the back end of the vector. (It is assumed |
| 1181 | -- that specifying an index value greater than Last + 1 indicates some |
| 1182 | -- deeper flaw in the caller's algorithm, so that case is treated as a |
| 1183 | -- proper error.) |
| 1184 | |
| 1185 | if Before > Container.Last |
| 1186 | and then Before > Container.Last + 1 |
| 1187 | then |
| 1188 | raise Constraint_Error with |
| 1189 | "Before index is out of range (too large)"; |
| 1190 | end if; |
| 1191 | |
| 1192 | -- We treat inserting 0 items into the container as a no-op, even when |
| 1193 | -- the container is busy, so we simply return. |
| 1194 | |
| 1195 | if Count = 0 then |
| 1196 | return; |
| 1197 | end if; |
| 1198 | |
| 1199 | -- There are two constraints we need to satisfy. The first constraint is |
| 1200 | -- that a container cannot have more than Count_Type'Last elements, so |
| 1201 | -- we must check the sum of the current length and the insertion count. |
| 1202 | -- Note: we cannot simply add these values, because of the possibility |
| 1203 | -- of overflow. |
| 1204 | |
| 1205 | if Old_Length > Count_Type'Last - Count then |
| 1206 | raise Constraint_Error with "Count is out of range"; |
| 1207 | end if; |
| 1208 | |
| 1209 | -- It is now safe compute the length of the new vector, without fear of |
| 1210 | -- overflow. |
| 1211 | |
| 1212 | New_Length := Old_Length + Count; |
| 1213 | |
| 1214 | -- The second constraint is that the new Last index value cannot exceed |
| 1215 | -- Index_Type'Last. In each branch below, we calculate the maximum |
| 1216 | -- length (computed from the range of values in Index_Type), and then |
| 1217 | -- compare the new length to the maximum length. If the new length is |
| 1218 | -- acceptable, then we compute the new last index from that. |
| 1219 | |
| 1220 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1221 | |
| 1222 | -- We have to handle the case when there might be more values in the |
| 1223 | -- range of Index_Type than in the range of Count_Type. |
| 1224 | |
| 1225 | if Index_Type'First <= 0 then |
| 1226 | |
| 1227 | -- We know that No_Index (the same as Index_Type'First - 1) is |
| 1228 | -- less than 0, so it is safe to compute the following sum without |
| 1229 | -- fear of overflow. |
| 1230 | |
| 1231 | Index := No_Index + Index_Type'Base (Count_Type'Last); |
| 1232 | |
| 1233 | if Index <= Index_Type'Last then |
| 1234 | |
| 1235 | -- We have determined that range of Index_Type has at least as |
| 1236 | -- many values as in Count_Type, so Count_Type'Last is the |
| 1237 | -- maximum number of items that are allowed. |
| 1238 | |
| 1239 | Max_Length := Count_Type'Last; |
| 1240 | |
| 1241 | else |
| 1242 | -- The range of Index_Type has fewer values than in Count_Type, |
| 1243 | -- so the maximum number of items is computed from the range of |
| 1244 | -- the Index_Type. |
| 1245 | |
| 1246 | Max_Length := Count_Type'Base (Index_Type'Last - No_Index); |
| 1247 | end if; |
| 1248 | |
| 1249 | else |
| 1250 | -- No_Index is equal or greater than 0, so we can safely compute |
| 1251 | -- the difference without fear of overflow (which we would have to |
| 1252 | -- worry about if No_Index were less than 0, but that case is |
| 1253 | -- handled above). |
| 1254 | |
| 1255 | Max_Length := Count_Type'Base (Index_Type'Last - No_Index); |
| 1256 | end if; |
| 1257 | |
| 1258 | elsif Index_Type'First <= 0 then |
| 1259 | |
| 1260 | -- We know that No_Index (the same as Index_Type'First - 1) is less |
| 1261 | -- than 0, so it is safe to compute the following sum without fear of |
| 1262 | -- overflow. |
| 1263 | |
| 1264 | J := Count_Type'Base (No_Index) + Count_Type'Last; |
| 1265 | |
| 1266 | if J <= Count_Type'Base (Index_Type'Last) then |
| 1267 | |
| 1268 | -- We have determined that range of Index_Type has at least as |
| 1269 | -- many values as in Count_Type, so Count_Type'Last is the maximum |
| 1270 | -- number of items that are allowed. |
| 1271 | |
| 1272 | Max_Length := Count_Type'Last; |
| 1273 | |
| 1274 | else |
| 1275 | -- The range of Index_Type has fewer values than Count_Type does, |
| 1276 | -- so the maximum number of items is computed from the range of |
| 1277 | -- the Index_Type. |
| 1278 | |
| 1279 | Max_Length := |
| 1280 | Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); |
| 1281 | end if; |
| 1282 | |
| 1283 | else |
| 1284 | -- No_Index is equal or greater than 0, so we can safely compute the |
| 1285 | -- difference without fear of overflow (which we would have to worry |
| 1286 | -- about if No_Index were less than 0, but that case is handled |
| 1287 | -- above). |
| 1288 | |
| 1289 | Max_Length := |
| 1290 | Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); |
| 1291 | end if; |
| 1292 | |
| 1293 | -- We have just computed the maximum length (number of items). We must |
| 1294 | -- now compare the requested length to the maximum length, as we do not |
| 1295 | -- allow a vector expand beyond the maximum (because that would create |
| 1296 | -- an internal array with a last index value greater than |
| 1297 | -- Index_Type'Last, with no way to index those elements). |
| 1298 | |
| 1299 | if New_Length > Max_Length then |
| 1300 | raise Constraint_Error with "Count is out of range"; |
| 1301 | end if; |
| 1302 | |
| 1303 | -- New_Last is the last index value of the items in the container after |
| 1304 | -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to |
| 1305 | -- compute its value from the New_Length. |
| 1306 | |
| 1307 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1308 | New_Last := No_Index + Index_Type'Base (New_Length); |
| 1309 | else |
| 1310 | New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); |
| 1311 | end if; |
| 1312 | |
| 1313 | if Container.Elements = null then |
| 1314 | pragma Assert (Container.Last = No_Index); |
| 1315 | |
| 1316 | -- This is the simplest case, with which we must always begin: we're |
| 1317 | -- inserting items into an empty vector that hasn't allocated an |
| 1318 | -- internal array yet. Note that we don't need to check the busy bit |
| 1319 | -- here, because an empty container cannot be busy. |
| 1320 | |
| 1321 | -- In order to preserve container invariants, we allocate the new |
| 1322 | -- internal array first, before setting the Last index value, in case |
| 1323 | -- the allocation fails (which can happen either because there is no |
| 1324 | -- storage available, or because element initialization fails). |
| 1325 | |
| 1326 | Container.Elements := new Elements_Type' |
| 1327 | (Last => New_Last, |
| 1328 | EA => (others => New_Item)); |
| 1329 | |
| 1330 | -- The allocation of the new, internal array succeeded, so it is now |
| 1331 | -- safe to update the Last index, restoring container invariants. |
| 1332 | |
| 1333 | Container.Last := New_Last; |
| 1334 | |
| 1335 | return; |
| 1336 | end if; |
| 1337 | |
| 1338 | -- The tampering bits exist to prevent an item from being harmfully |
| 1339 | -- manipulated while it is being visited. Query, Update, and Iterate |
| 1340 | -- increment the busy count on entry, and decrement the count on |
| 1341 | -- exit. Insert checks the count to determine whether it is being called |
| 1342 | -- while the associated callback procedure is executing. |
| 1343 | |
| 1344 | if Container.Busy > 0 then |
| 1345 | raise Program_Error with |
| 1346 | "attempt to tamper with cursors (vector is busy)"; |
| 1347 | end if; |
| 1348 | |
| 1349 | -- An internal array has already been allocated, so we must determine |
| 1350 | -- whether there is enough unused storage for the new items. |
| 1351 | |
| 1352 | if New_Length <= Container.Elements.EA'Length then |
| 1353 | |
| 1354 | -- In this case, we're inserting elements into a vector that has |
| 1355 | -- already allocated an internal array, and the existing array has |
| 1356 | -- enough unused storage for the new items. |
| 1357 | |
| 1358 | declare |
| 1359 | EA : Elements_Array renames Container.Elements.EA; |
| 1360 | |
| 1361 | begin |
| 1362 | if Before > Container.Last then |
| 1363 | |
| 1364 | -- The new items are being appended to the vector, so no |
| 1365 | -- sliding of existing elements is required. |
| 1366 | |
| 1367 | EA (Before .. New_Last) := (others => New_Item); |
| 1368 | |
| 1369 | else |
| 1370 | -- The new items are being inserted before some existing |
| 1371 | -- elements, so we must slide the existing elements up to their |
| 1372 | -- new home. We use the wider of Index_Type'Base and |
| 1373 | -- Count_Type'Base as the type for intermediate index values. |
| 1374 | |
| 1375 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1376 | Index := Before + Index_Type'Base (Count); |
| 1377 | |
| 1378 | else |
| 1379 | Index := Index_Type'Base (Count_Type'Base (Before) + Count); |
| 1380 | end if; |
| 1381 | |
| 1382 | EA (Index .. New_Last) := EA (Before .. Container.Last); |
| 1383 | EA (Before .. Index - 1) := (others => New_Item); |
| 1384 | end if; |
| 1385 | end; |
| 1386 | |
| 1387 | Container.Last := New_Last; |
| 1388 | return; |
| 1389 | end if; |
| 1390 | |
| 1391 | -- In this case, we're inserting elements into a vector that has already |
| 1392 | -- allocated an internal array, but the existing array does not have |
| 1393 | -- enough storage, so we must allocate a new, longer array. In order to |
| 1394 | -- guarantee that the amortized insertion cost is O(1), we always |
| 1395 | -- allocate an array whose length is some power-of-two factor of the |
| 1396 | -- current array length. (The new array cannot have a length less than |
| 1397 | -- the New_Length of the container, but its last index value cannot be |
| 1398 | -- greater than Index_Type'Last.) |
| 1399 | |
| 1400 | New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); |
| 1401 | while New_Capacity < New_Length loop |
| 1402 | if New_Capacity > Count_Type'Last / 2 then |
| 1403 | New_Capacity := Count_Type'Last; |
| 1404 | exit; |
| 1405 | end if; |
| 1406 | |
| 1407 | New_Capacity := 2 * New_Capacity; |
| 1408 | end loop; |
| 1409 | |
| 1410 | if New_Capacity > Max_Length then |
| 1411 | |
| 1412 | -- We have reached the limit of capacity, so no further expansion |
| 1413 | -- will occur. (This is not a problem, as there is never a need to |
| 1414 | -- have more capacity than the maximum container length.) |
| 1415 | |
| 1416 | New_Capacity := Max_Length; |
| 1417 | end if; |
| 1418 | |
| 1419 | -- We have computed the length of the new internal array (and this is |
| 1420 | -- what "vector capacity" means), so use that to compute its last index. |
| 1421 | |
| 1422 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1423 | Dst_Last := No_Index + Index_Type'Base (New_Capacity); |
| 1424 | |
| 1425 | else |
| 1426 | Dst_Last := |
| 1427 | Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); |
| 1428 | end if; |
| 1429 | |
| 1430 | -- Now we allocate the new, longer internal array. If the allocation |
| 1431 | -- fails, we have not changed any container state, so no side-effect |
| 1432 | -- will occur as a result of propagating the exception. |
| 1433 | |
| 1434 | Dst := new Elements_Type (Dst_Last); |
| 1435 | |
| 1436 | -- We have our new internal array. All that needs to be done now is to |
| 1437 | -- copy the existing items (if any) from the old array (the "source" |
| 1438 | -- array, object SA below) to the new array (the "destination" array, |
| 1439 | -- object DA below), and then deallocate the old array. |
| 1440 | |
| 1441 | declare |
| 1442 | SA : Elements_Array renames Container.Elements.EA; -- source |
| 1443 | DA : Elements_Array renames Dst.EA; -- destination |
| 1444 | |
| 1445 | begin |
| 1446 | DA (Index_Type'First .. Before - 1) := |
| 1447 | SA (Index_Type'First .. Before - 1); |
| 1448 | |
| 1449 | if Before > Container.Last then |
| 1450 | DA (Before .. New_Last) := (others => New_Item); |
| 1451 | |
| 1452 | else |
| 1453 | -- The new items are being inserted before some existing elements, |
| 1454 | -- so we must slide the existing elements up to their new home. |
| 1455 | |
| 1456 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1457 | Index := Before + Index_Type'Base (Count); |
| 1458 | |
| 1459 | else |
| 1460 | Index := Index_Type'Base (Count_Type'Base (Before) + Count); |
| 1461 | end if; |
| 1462 | |
| 1463 | DA (Before .. Index - 1) := (others => New_Item); |
| 1464 | DA (Index .. New_Last) := SA (Before .. Container.Last); |
| 1465 | end if; |
| 1466 | |
| 1467 | exception |
| 1468 | when others => |
| 1469 | Free (Dst); |
| 1470 | raise; |
| 1471 | end; |
| 1472 | |
| 1473 | -- We have successfully copied the items onto the new array, so the |
| 1474 | -- final thing to do is deallocate the old array. |
| 1475 | |
| 1476 | declare |
| 1477 | X : Elements_Access := Container.Elements; |
| 1478 | begin |
| 1479 | -- We first isolate the old internal array, removing it from the |
| 1480 | -- container and replacing it with the new internal array, before we |
| 1481 | -- deallocate the old array (which can fail if finalization of |
| 1482 | -- elements propagates an exception). |
| 1483 | |
| 1484 | Container.Elements := Dst; |
| 1485 | Container.Last := New_Last; |
| 1486 | |
| 1487 | -- The container invariants have been restored, so it is now safe to |
| 1488 | -- attempt to deallocate the old array. |
| 1489 | |
| 1490 | Free (X); |
| 1491 | end; |
| 1492 | end Insert; |
| 1493 | |
| 1494 | procedure Insert |
| 1495 | (Container : in out Vector; |
| 1496 | Before : Extended_Index; |
| 1497 | New_Item : Vector) |
| 1498 | is |
| 1499 | N : constant Count_Type := Length (New_Item); |
| 1500 | J : Index_Type'Base; |
| 1501 | |
| 1502 | begin |
| 1503 | -- Use Insert_Space to create the "hole" (the destination slice) into |
| 1504 | -- which we copy the source items. |
| 1505 | |
| 1506 | Insert_Space (Container, Before, Count => N); |
| 1507 | |
| 1508 | if N = 0 then |
| 1509 | |
| 1510 | -- There's nothing else to do here (vetting of parameters was |
| 1511 | -- performed already in Insert_Space), so we simply return. |
| 1512 | |
| 1513 | return; |
| 1514 | end if; |
| 1515 | |
| 1516 | -- We calculate the last index value of the destination slice using the |
| 1517 | -- wider of Index_Type'Base and count_Type'Base. |
| 1518 | |
| 1519 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1520 | J := (Before - 1) + Index_Type'Base (N); |
| 1521 | |
| 1522 | else |
| 1523 | J := Index_Type'Base (Count_Type'Base (Before - 1) + N); |
| 1524 | end if; |
| 1525 | |
| 1526 | if Container'Address /= New_Item'Address then |
| 1527 | |
| 1528 | -- This is the simple case. New_Item denotes an object different |
| 1529 | -- from Container, so there's nothing special we need to do to copy |
| 1530 | -- the source items to their destination, because all of the source |
| 1531 | -- items are contiguous. |
| 1532 | |
| 1533 | Container.Elements.EA (Before .. J) := |
| 1534 | New_Item.Elements.EA (Index_Type'First .. New_Item.Last); |
| 1535 | |
| 1536 | return; |
| 1537 | end if; |
| 1538 | |
| 1539 | -- New_Item denotes the same object as Container, so an insertion has |
| 1540 | -- potentially split the source items. The destination is always the |
| 1541 | -- range [Before, J], but the source is [Index_Type'First, Before) and |
| 1542 | -- (J, Container.Last]. We perform the copy in two steps, using each of |
| 1543 | -- the two slices of the source items. |
| 1544 | |
| 1545 | declare |
| 1546 | L : constant Index_Type'Base := Before - 1; |
| 1547 | |
| 1548 | subtype Src_Index_Subtype is Index_Type'Base range |
| 1549 | Index_Type'First .. L; |
| 1550 | |
| 1551 | Src : Elements_Array renames |
| 1552 | Container.Elements.EA (Src_Index_Subtype); |
| 1553 | |
| 1554 | K : Index_Type'Base; |
| 1555 | |
| 1556 | begin |
| 1557 | -- We first copy the source items that precede the space we |
| 1558 | -- inserted. Index value K is the last index of that portion |
| 1559 | -- destination that receives this slice of the source. (If Before |
| 1560 | -- equals Index_Type'First, then this first source slice will be |
| 1561 | -- empty, which is harmless.) |
| 1562 | |
| 1563 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1564 | K := L + Index_Type'Base (Src'Length); |
| 1565 | |
| 1566 | else |
| 1567 | K := Index_Type'Base (Count_Type'Base (L) + Src'Length); |
| 1568 | end if; |
| 1569 | |
| 1570 | Container.Elements.EA (Before .. K) := Src; |
| 1571 | |
| 1572 | if Src'Length = N then |
| 1573 | |
| 1574 | -- The new items were effectively appended to the container, so we |
| 1575 | -- have already copied all of the items that need to be copied. |
| 1576 | -- We return early here, even though the source slice below is |
| 1577 | -- empty (so the assignment would be harmless), because we want to |
| 1578 | -- avoid computing J + 1, which will overflow if J equals |
| 1579 | -- Index_Type'Base'Last. |
| 1580 | |
| 1581 | return; |
| 1582 | end if; |
| 1583 | end; |
| 1584 | |
| 1585 | declare |
| 1586 | -- Note that we want to avoid computing J + 1 here, in case J equals |
| 1587 | -- Index_Type'Base'Last. We prevent that by returning early above, |
| 1588 | -- immediately after copying the first slice of the source, and |
| 1589 | -- determining that this second slice of the source is empty. |
| 1590 | |
| 1591 | F : constant Index_Type'Base := J + 1; |
| 1592 | |
| 1593 | subtype Src_Index_Subtype is Index_Type'Base range |
| 1594 | F .. Container.Last; |
| 1595 | |
| 1596 | Src : Elements_Array renames |
| 1597 | Container.Elements.EA (Src_Index_Subtype); |
| 1598 | |
| 1599 | K : Index_Type'Base; |
| 1600 | |
| 1601 | begin |
| 1602 | -- We next copy the source items that follow the space we inserted. |
| 1603 | -- Index value K is the first index of that portion of the |
| 1604 | -- destination that receives this slice of the source. (For the |
| 1605 | -- reasons given above, this slice is guaranteed to be non-empty.) |
| 1606 | |
| 1607 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1608 | K := F - Index_Type'Base (Src'Length); |
| 1609 | |
| 1610 | else |
| 1611 | K := Index_Type'Base (Count_Type'Base (F) - Src'Length); |
| 1612 | end if; |
| 1613 | |
| 1614 | Container.Elements.EA (K .. J) := Src; |
| 1615 | end; |
| 1616 | end Insert; |
| 1617 | |
| 1618 | procedure Insert |
| 1619 | (Container : in out Vector; |
| 1620 | Before : Cursor; |
| 1621 | New_Item : Vector) |
| 1622 | is |
| 1623 | Index : Index_Type'Base; |
| 1624 | |
| 1625 | begin |
| 1626 | if Before.Container /= null |
| 1627 | and then Before.Container /= Container'Unrestricted_Access |
| 1628 | then |
| 1629 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1630 | end if; |
| 1631 | |
| 1632 | if Is_Empty (New_Item) then |
| 1633 | return; |
| 1634 | end if; |
| 1635 | |
| 1636 | if Before.Container = null |
| 1637 | or else Before.Index > Container.Last |
| 1638 | then |
| 1639 | if Container.Last = Index_Type'Last then |
| 1640 | raise Constraint_Error with |
| 1641 | "vector is already at its maximum length"; |
| 1642 | end if; |
| 1643 | |
| 1644 | Index := Container.Last + 1; |
| 1645 | |
| 1646 | else |
| 1647 | Index := Before.Index; |
| 1648 | end if; |
| 1649 | |
| 1650 | Insert (Container, Index, New_Item); |
| 1651 | end Insert; |
| 1652 | |
| 1653 | procedure Insert |
| 1654 | (Container : in out Vector; |
| 1655 | Before : Cursor; |
| 1656 | New_Item : Vector; |
| 1657 | Position : out Cursor) |
| 1658 | is |
| 1659 | Index : Index_Type'Base; |
| 1660 | |
| 1661 | begin |
| 1662 | if Before.Container /= null |
| 1663 | and then Before.Container /= Container'Unrestricted_Access |
| 1664 | then |
| 1665 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1666 | end if; |
| 1667 | |
| 1668 | if Is_Empty (New_Item) then |
| 1669 | if Before.Container = null |
| 1670 | or else Before.Index > Container.Last |
| 1671 | then |
| 1672 | Position := No_Element; |
| 1673 | else |
| 1674 | Position := (Container'Unrestricted_Access, Before.Index); |
| 1675 | end if; |
| 1676 | |
| 1677 | return; |
| 1678 | end if; |
| 1679 | |
| 1680 | if Before.Container = null |
| 1681 | or else Before.Index > Container.Last |
| 1682 | then |
| 1683 | if Container.Last = Index_Type'Last then |
| 1684 | raise Constraint_Error with |
| 1685 | "vector is already at its maximum length"; |
| 1686 | end if; |
| 1687 | |
| 1688 | Index := Container.Last + 1; |
| 1689 | |
| 1690 | else |
| 1691 | Index := Before.Index; |
| 1692 | end if; |
| 1693 | |
| 1694 | Insert (Container, Index, New_Item); |
| 1695 | |
| 1696 | Position := (Container'Unrestricted_Access, Index); |
| 1697 | end Insert; |
| 1698 | |
| 1699 | procedure Insert |
| 1700 | (Container : in out Vector; |
| 1701 | Before : Cursor; |
| 1702 | New_Item : Element_Type; |
| 1703 | Count : Count_Type := 1) |
| 1704 | is |
| 1705 | Index : Index_Type'Base; |
| 1706 | |
| 1707 | begin |
| 1708 | if Before.Container /= null |
| 1709 | and then Before.Container /= Container'Unrestricted_Access |
| 1710 | then |
| 1711 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1712 | end if; |
| 1713 | |
| 1714 | if Count = 0 then |
| 1715 | return; |
| 1716 | end if; |
| 1717 | |
| 1718 | if Before.Container = null |
| 1719 | or else Before.Index > Container.Last |
| 1720 | then |
| 1721 | if Container.Last = Index_Type'Last then |
| 1722 | raise Constraint_Error with |
| 1723 | "vector is already at its maximum length"; |
| 1724 | else |
| 1725 | Index := Container.Last + 1; |
| 1726 | end if; |
| 1727 | |
| 1728 | else |
| 1729 | Index := Before.Index; |
| 1730 | end if; |
| 1731 | |
| 1732 | Insert (Container, Index, New_Item, Count); |
| 1733 | end Insert; |
| 1734 | |
| 1735 | procedure Insert |
| 1736 | (Container : in out Vector; |
| 1737 | Before : Cursor; |
| 1738 | New_Item : Element_Type; |
| 1739 | Position : out Cursor; |
| 1740 | Count : Count_Type := 1) |
| 1741 | is |
| 1742 | Index : Index_Type'Base; |
| 1743 | |
| 1744 | begin |
| 1745 | if Before.Container /= null |
| 1746 | and then Before.Container /= Container'Unrestricted_Access |
| 1747 | then |
| 1748 | raise Program_Error with "Before cursor denotes wrong container"; |
| 1749 | end if; |
| 1750 | |
| 1751 | if Count = 0 then |
| 1752 | if Before.Container = null |
| 1753 | or else Before.Index > Container.Last |
| 1754 | then |
| 1755 | Position := No_Element; |
| 1756 | else |
| 1757 | Position := (Container'Unrestricted_Access, Before.Index); |
| 1758 | end if; |
| 1759 | |
| 1760 | return; |
| 1761 | end if; |
| 1762 | |
| 1763 | if Before.Container = null |
| 1764 | or else Before.Index > Container.Last |
| 1765 | then |
| 1766 | if Container.Last = Index_Type'Last then |
| 1767 | raise Constraint_Error with |
| 1768 | "vector is already at its maximum length"; |
| 1769 | end if; |
| 1770 | |
| 1771 | Index := Container.Last + 1; |
| 1772 | |
| 1773 | else |
| 1774 | Index := Before.Index; |
| 1775 | end if; |
| 1776 | |
| 1777 | Insert (Container, Index, New_Item, Count); |
| 1778 | |
| 1779 | Position := (Container'Unrestricted_Access, Index); |
| 1780 | end Insert; |
| 1781 | |
| 1782 | procedure Insert |
| 1783 | (Container : in out Vector; |
| 1784 | Before : Extended_Index; |
| 1785 | Count : Count_Type := 1) |
| 1786 | is |
| 1787 | New_Item : Element_Type; -- Default-initialized value |
| 1788 | pragma Warnings (Off, New_Item); |
| 1789 | |
| 1790 | begin |
| 1791 | Insert (Container, Before, New_Item, Count); |
| 1792 | end Insert; |
| 1793 | |
| 1794 | procedure Insert |
| 1795 | (Container : in out Vector; |
| 1796 | Before : Cursor; |
| 1797 | Position : out Cursor; |
| 1798 | Count : Count_Type := 1) |
| 1799 | is |
| 1800 | New_Item : Element_Type; -- Default-initialized value |
| 1801 | pragma Warnings (Off, New_Item); |
| 1802 | |
| 1803 | begin |
| 1804 | Insert (Container, Before, New_Item, Position, Count); |
| 1805 | end Insert; |
| 1806 | |
| 1807 | ------------------ |
| 1808 | -- Insert_Space -- |
| 1809 | ------------------ |
| 1810 | |
| 1811 | procedure Insert_Space |
| 1812 | (Container : in out Vector; |
| 1813 | Before : Extended_Index; |
| 1814 | Count : Count_Type := 1) |
| 1815 | is |
| 1816 | Old_Length : constant Count_Type := Container.Length; |
| 1817 | |
| 1818 | Max_Length : Count_Type'Base; -- determined from range of Index_Type |
| 1819 | New_Length : Count_Type'Base; -- sum of current length and Count |
| 1820 | New_Last : Index_Type'Base; -- last index of vector after insertion |
| 1821 | |
| 1822 | Index : Index_Type'Base; -- scratch for intermediate values |
| 1823 | J : Count_Type'Base; -- scratch |
| 1824 | |
| 1825 | New_Capacity : Count_Type'Base; -- length of new, expanded array |
| 1826 | Dst_Last : Index_Type'Base; -- last index of new, expanded array |
| 1827 | Dst : Elements_Access; -- new, expanded internal array |
| 1828 | |
| 1829 | begin |
| 1830 | -- As a precondition on the generic actual Index_Type, the base type |
| 1831 | -- must include Index_Type'Pred (Index_Type'First); this is the value |
| 1832 | -- that Container.Last assumes when the vector is empty. However, we do |
| 1833 | -- not allow that as the value for Index when specifying where the new |
| 1834 | -- items should be inserted, so we must manually check. (That the user |
| 1835 | -- is allowed to specify the value at all here is a consequence of the |
| 1836 | -- declaration of the Extended_Index subtype, which includes the values |
| 1837 | -- in the base range that immediately precede and immediately follow the |
| 1838 | -- values in the Index_Type.) |
| 1839 | |
| 1840 | if Before < Index_Type'First then |
| 1841 | raise Constraint_Error with |
| 1842 | "Before index is out of range (too small)"; |
| 1843 | end if; |
| 1844 | |
| 1845 | -- We do allow a value greater than Container.Last to be specified as |
| 1846 | -- the Index, but only if it's immediately greater. This allows for the |
| 1847 | -- case of appending items to the back end of the vector. (It is assumed |
| 1848 | -- that specifying an index value greater than Last + 1 indicates some |
| 1849 | -- deeper flaw in the caller's algorithm, so that case is treated as a |
| 1850 | -- proper error.) |
| 1851 | |
| 1852 | if Before > Container.Last |
| 1853 | and then Before > Container.Last + 1 |
| 1854 | then |
| 1855 | raise Constraint_Error with |
| 1856 | "Before index is out of range (too large)"; |
| 1857 | end if; |
| 1858 | |
| 1859 | -- We treat inserting 0 items into the container as a no-op, even when |
| 1860 | -- the container is busy, so we simply return. |
| 1861 | |
| 1862 | if Count = 0 then |
| 1863 | return; |
| 1864 | end if; |
| 1865 | |
| 1866 | -- There are two constraints we need to satisfy. The first constraint is |
| 1867 | -- that a container cannot have more than Count_Type'Last elements, so |
| 1868 | -- we must check the sum of the current length and the insertion count. |
| 1869 | -- Note: we cannot simply add these values, because of the possibility |
| 1870 | -- of overflow. |
| 1871 | |
| 1872 | if Old_Length > Count_Type'Last - Count then |
| 1873 | raise Constraint_Error with "Count is out of range"; |
| 1874 | end if; |
| 1875 | |
| 1876 | -- It is now safe compute the length of the new vector, without fear of |
| 1877 | -- overflow. |
| 1878 | |
| 1879 | New_Length := Old_Length + Count; |
| 1880 | |
| 1881 | -- The second constraint is that the new Last index value cannot exceed |
| 1882 | -- Index_Type'Last. In each branch below, we calculate the maximum |
| 1883 | -- length (computed from the range of values in Index_Type), and then |
| 1884 | -- compare the new length to the maximum length. If the new length is |
| 1885 | -- acceptable, then we compute the new last index from that. |
| 1886 | |
| 1887 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1888 | |
| 1889 | -- We have to handle the case when there might be more values in the |
| 1890 | -- range of Index_Type than in the range of Count_Type. |
| 1891 | |
| 1892 | if Index_Type'First <= 0 then |
| 1893 | |
| 1894 | -- We know that No_Index (the same as Index_Type'First - 1) is |
| 1895 | -- less than 0, so it is safe to compute the following sum without |
| 1896 | -- fear of overflow. |
| 1897 | |
| 1898 | Index := No_Index + Index_Type'Base (Count_Type'Last); |
| 1899 | |
| 1900 | if Index <= Index_Type'Last then |
| 1901 | |
| 1902 | -- We have determined that range of Index_Type has at least as |
| 1903 | -- many values as in Count_Type, so Count_Type'Last is the |
| 1904 | -- maximum number of items that are allowed. |
| 1905 | |
| 1906 | Max_Length := Count_Type'Last; |
| 1907 | |
| 1908 | else |
| 1909 | -- The range of Index_Type has fewer values than in Count_Type, |
| 1910 | -- so the maximum number of items is computed from the range of |
| 1911 | -- the Index_Type. |
| 1912 | |
| 1913 | Max_Length := Count_Type'Base (Index_Type'Last - No_Index); |
| 1914 | end if; |
| 1915 | |
| 1916 | else |
| 1917 | -- No_Index is equal or greater than 0, so we can safely compute |
| 1918 | -- the difference without fear of overflow (which we would have to |
| 1919 | -- worry about if No_Index were less than 0, but that case is |
| 1920 | -- handled above). |
| 1921 | |
| 1922 | Max_Length := Count_Type'Base (Index_Type'Last - No_Index); |
| 1923 | end if; |
| 1924 | |
| 1925 | elsif Index_Type'First <= 0 then |
| 1926 | |
| 1927 | -- We know that No_Index (the same as Index_Type'First - 1) is less |
| 1928 | -- than 0, so it is safe to compute the following sum without fear of |
| 1929 | -- overflow. |
| 1930 | |
| 1931 | J := Count_Type'Base (No_Index) + Count_Type'Last; |
| 1932 | |
| 1933 | if J <= Count_Type'Base (Index_Type'Last) then |
| 1934 | |
| 1935 | -- We have determined that range of Index_Type has at least as |
| 1936 | -- many values as in Count_Type, so Count_Type'Last is the maximum |
| 1937 | -- number of items that are allowed. |
| 1938 | |
| 1939 | Max_Length := Count_Type'Last; |
| 1940 | |
| 1941 | else |
| 1942 | -- The range of Index_Type has fewer values than Count_Type does, |
| 1943 | -- so the maximum number of items is computed from the range of |
| 1944 | -- the Index_Type. |
| 1945 | |
| 1946 | Max_Length := |
| 1947 | Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); |
| 1948 | end if; |
| 1949 | |
| 1950 | else |
| 1951 | -- No_Index is equal or greater than 0, so we can safely compute the |
| 1952 | -- difference without fear of overflow (which we would have to worry |
| 1953 | -- about if No_Index were less than 0, but that case is handled |
| 1954 | -- above). |
| 1955 | |
| 1956 | Max_Length := |
| 1957 | Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); |
| 1958 | end if; |
| 1959 | |
| 1960 | -- We have just computed the maximum length (number of items). We must |
| 1961 | -- now compare the requested length to the maximum length, as we do not |
| 1962 | -- allow a vector expand beyond the maximum (because that would create |
| 1963 | -- an internal array with a last index value greater than |
| 1964 | -- Index_Type'Last, with no way to index those elements). |
| 1965 | |
| 1966 | if New_Length > Max_Length then |
| 1967 | raise Constraint_Error with "Count is out of range"; |
| 1968 | end if; |
| 1969 | |
| 1970 | -- New_Last is the last index value of the items in the container after |
| 1971 | -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to |
| 1972 | -- compute its value from the New_Length. |
| 1973 | |
| 1974 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 1975 | New_Last := No_Index + Index_Type'Base (New_Length); |
| 1976 | |
| 1977 | else |
| 1978 | New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); |
| 1979 | end if; |
| 1980 | |
| 1981 | if Container.Elements = null then |
| 1982 | pragma Assert (Container.Last = No_Index); |
| 1983 | |
| 1984 | -- This is the simplest case, with which we must always begin: we're |
| 1985 | -- inserting items into an empty vector that hasn't allocated an |
| 1986 | -- internal array yet. Note that we don't need to check the busy bit |
| 1987 | -- here, because an empty container cannot be busy. |
| 1988 | |
| 1989 | -- In order to preserve container invariants, we allocate the new |
| 1990 | -- internal array first, before setting the Last index value, in case |
| 1991 | -- the allocation fails (which can happen either because there is no |
| 1992 | -- storage available, or because default-valued element |
| 1993 | -- initialization fails). |
| 1994 | |
| 1995 | Container.Elements := new Elements_Type (New_Last); |
| 1996 | |
| 1997 | -- The allocation of the new, internal array succeeded, so it is now |
| 1998 | -- safe to update the Last index, restoring container invariants. |
| 1999 | |
| 2000 | Container.Last := New_Last; |
| 2001 | |
| 2002 | return; |
| 2003 | end if; |
| 2004 | |
| 2005 | -- The tampering bits exist to prevent an item from being harmfully |
| 2006 | -- manipulated while it is being visited. Query, Update, and Iterate |
| 2007 | -- increment the busy count on entry, and decrement the count on |
| 2008 | -- exit. Insert checks the count to determine whether it is being called |
| 2009 | -- while the associated callback procedure is executing. |
| 2010 | |
| 2011 | if Container.Busy > 0 then |
| 2012 | raise Program_Error with |
| 2013 | "attempt to tamper with cursors (vector is busy)"; |
| 2014 | end if; |
| 2015 | |
| 2016 | -- An internal array has already been allocated, so we must determine |
| 2017 | -- whether there is enough unused storage for the new items. |
| 2018 | |
| 2019 | if New_Last <= Container.Elements.Last then |
| 2020 | |
| 2021 | -- In this case, we're inserting space into a vector that has already |
| 2022 | -- allocated an internal array, and the existing array has enough |
| 2023 | -- unused storage for the new items. |
| 2024 | |
| 2025 | declare |
| 2026 | EA : Elements_Array renames Container.Elements.EA; |
| 2027 | |
| 2028 | begin |
| 2029 | if Before <= Container.Last then |
| 2030 | |
| 2031 | -- The space is being inserted before some existing elements, |
| 2032 | -- so we must slide the existing elements up to their new |
| 2033 | -- home. We use the wider of Index_Type'Base and |
| 2034 | -- Count_Type'Base as the type for intermediate index values. |
| 2035 | |
| 2036 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 2037 | Index := Before + Index_Type'Base (Count); |
| 2038 | |
| 2039 | else |
| 2040 | Index := Index_Type'Base (Count_Type'Base (Before) + Count); |
| 2041 | end if; |
| 2042 | |
| 2043 | EA (Index .. New_Last) := EA (Before .. Container.Last); |
| 2044 | end if; |
| 2045 | end; |
| 2046 | |
| 2047 | Container.Last := New_Last; |
| 2048 | return; |
| 2049 | end if; |
| 2050 | |
| 2051 | -- In this case, we're inserting space into a vector that has already |
| 2052 | -- allocated an internal array, but the existing array does not have |
| 2053 | -- enough storage, so we must allocate a new, longer array. In order to |
| 2054 | -- guarantee that the amortized insertion cost is O(1), we always |
| 2055 | -- allocate an array whose length is some power-of-two factor of the |
| 2056 | -- current array length. (The new array cannot have a length less than |
| 2057 | -- the New_Length of the container, but its last index value cannot be |
| 2058 | -- greater than Index_Type'Last.) |
| 2059 | |
| 2060 | New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); |
| 2061 | while New_Capacity < New_Length loop |
| 2062 | if New_Capacity > Count_Type'Last / 2 then |
| 2063 | New_Capacity := Count_Type'Last; |
| 2064 | exit; |
| 2065 | end if; |
| 2066 | |
| 2067 | New_Capacity := 2 * New_Capacity; |
| 2068 | end loop; |
| 2069 | |
| 2070 | if New_Capacity > Max_Length then |
| 2071 | |
| 2072 | -- We have reached the limit of capacity, so no further expansion |
| 2073 | -- will occur. (This is not a problem, as there is never a need to |
| 2074 | -- have more capacity than the maximum container length.) |
| 2075 | |
| 2076 | New_Capacity := Max_Length; |
| 2077 | end if; |
| 2078 | |
| 2079 | -- We have computed the length of the new internal array (and this is |
| 2080 | -- what "vector capacity" means), so use that to compute its last index. |
| 2081 | |
| 2082 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 2083 | Dst_Last := No_Index + Index_Type'Base (New_Capacity); |
| 2084 | |
| 2085 | else |
| 2086 | Dst_Last := |
| 2087 | Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); |
| 2088 | end if; |
| 2089 | |
| 2090 | -- Now we allocate the new, longer internal array. If the allocation |
| 2091 | -- fails, we have not changed any container state, so no side-effect |
| 2092 | -- will occur as a result of propagating the exception. |
| 2093 | |
| 2094 | Dst := new Elements_Type (Dst_Last); |
| 2095 | |
| 2096 | -- We have our new internal array. All that needs to be done now is to |
| 2097 | -- copy the existing items (if any) from the old array (the "source" |
| 2098 | -- array, object SA below) to the new array (the "destination" array, |
| 2099 | -- object DA below), and then deallocate the old array. |
| 2100 | |
| 2101 | declare |
| 2102 | SA : Elements_Array renames Container.Elements.EA; -- source |
| 2103 | DA : Elements_Array renames Dst.EA; -- destination |
| 2104 | |
| 2105 | begin |
| 2106 | DA (Index_Type'First .. Before - 1) := |
| 2107 | SA (Index_Type'First .. Before - 1); |
| 2108 | |
| 2109 | if Before <= Container.Last then |
| 2110 | |
| 2111 | -- The space is being inserted before some existing elements, so |
| 2112 | -- we must slide the existing elements up to their new home. |
| 2113 | |
| 2114 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 2115 | Index := Before + Index_Type'Base (Count); |
| 2116 | |
| 2117 | else |
| 2118 | Index := Index_Type'Base (Count_Type'Base (Before) + Count); |
| 2119 | end if; |
| 2120 | |
| 2121 | DA (Index .. New_Last) := SA (Before .. Container.Last); |
| 2122 | end if; |
| 2123 | |
| 2124 | exception |
| 2125 | when others => |
| 2126 | Free (Dst); |
| 2127 | raise; |
| 2128 | end; |
| 2129 | |
| 2130 | -- We have successfully copied the items onto the new array, so the |
| 2131 | -- final thing to do is restore invariants, and deallocate the old |
| 2132 | -- array. |
| 2133 | |
| 2134 | declare |
| 2135 | X : Elements_Access := Container.Elements; |
| 2136 | |
| 2137 | begin |
| 2138 | -- We first isolate the old internal array, removing it from the |
| 2139 | -- container and replacing it with the new internal array, before we |
| 2140 | -- deallocate the old array (which can fail if finalization of |
| 2141 | -- elements propagates an exception). |
| 2142 | |
| 2143 | Container.Elements := Dst; |
| 2144 | Container.Last := New_Last; |
| 2145 | |
| 2146 | -- The container invariants have been restored, so it is now safe to |
| 2147 | -- attempt to deallocate the old array. |
| 2148 | |
| 2149 | Free (X); |
| 2150 | end; |
| 2151 | end Insert_Space; |
| 2152 | |
| 2153 | procedure Insert_Space |
| 2154 | (Container : in out Vector; |
| 2155 | Before : Cursor; |
| 2156 | Position : out Cursor; |
| 2157 | Count : Count_Type := 1) |
| 2158 | is |
| 2159 | Index : Index_Type'Base; |
| 2160 | |
| 2161 | begin |
| 2162 | if Before.Container /= null |
| 2163 | and then Before.Container /= Container'Unrestricted_Access |
| 2164 | then |
| 2165 | raise Program_Error with "Before cursor denotes wrong container"; |
| 2166 | end if; |
| 2167 | |
| 2168 | if Count = 0 then |
| 2169 | if Before.Container = null |
| 2170 | or else Before.Index > Container.Last |
| 2171 | then |
| 2172 | Position := No_Element; |
| 2173 | else |
| 2174 | Position := (Container'Unrestricted_Access, Before.Index); |
| 2175 | end if; |
| 2176 | |
| 2177 | return; |
| 2178 | end if; |
| 2179 | |
| 2180 | if Before.Container = null |
| 2181 | or else Before.Index > Container.Last |
| 2182 | then |
| 2183 | if Container.Last = Index_Type'Last then |
| 2184 | raise Constraint_Error with |
| 2185 | "vector is already at its maximum length"; |
| 2186 | else |
| 2187 | Index := Container.Last + 1; |
| 2188 | end if; |
| 2189 | |
| 2190 | else |
| 2191 | Index := Before.Index; |
| 2192 | end if; |
| 2193 | |
| 2194 | Insert_Space (Container, Index, Count => Count); |
| 2195 | |
| 2196 | Position := (Container'Unrestricted_Access, Index); |
| 2197 | end Insert_Space; |
| 2198 | |
| 2199 | -------------- |
| 2200 | -- Is_Empty -- |
| 2201 | -------------- |
| 2202 | |
| 2203 | function Is_Empty (Container : Vector) return Boolean is |
| 2204 | begin |
| 2205 | return Container.Last < Index_Type'First; |
| 2206 | end Is_Empty; |
| 2207 | |
| 2208 | ------------- |
| 2209 | -- Iterate -- |
| 2210 | ------------- |
| 2211 | |
| 2212 | procedure Iterate |
| 2213 | (Container : Vector; |
| 2214 | Process : not null access procedure (Position : Cursor)) |
| 2215 | is |
| 2216 | B : Natural renames Container'Unrestricted_Access.all.Busy; |
| 2217 | |
| 2218 | begin |
| 2219 | B := B + 1; |
| 2220 | |
| 2221 | begin |
| 2222 | for Indx in Index_Type'First .. Container.Last loop |
| 2223 | Process (Cursor'(Container'Unrestricted_Access, Indx)); |
| 2224 | end loop; |
| 2225 | exception |
| 2226 | when others => |
| 2227 | B := B - 1; |
| 2228 | raise; |
| 2229 | end; |
| 2230 | |
| 2231 | B := B - 1; |
| 2232 | end Iterate; |
| 2233 | |
| 2234 | function Iterate |
| 2235 | (Container : Vector) |
| 2236 | return Vector_Iterator_Interfaces.Reversible_Iterator'Class |
| 2237 | is |
| 2238 | V : constant Vector_Access := Container'Unrestricted_Access; |
| 2239 | B : Natural renames V.Busy; |
| 2240 | |
| 2241 | begin |
| 2242 | -- The value of its Index component influences the behavior of the First |
| 2243 | -- and Last selector functions of the iterator object. When the Index |
| 2244 | -- component is No_Index (as is the case here), this means the iterator |
| 2245 | -- object was constructed without a start expression. This is a complete |
| 2246 | -- iterator, meaning that the iteration starts from the (logical) |
| 2247 | -- beginning of the sequence of items. |
| 2248 | |
| 2249 | -- Note: For a forward iterator, Container.First is the beginning, and |
| 2250 | -- for a reverse iterator, Container.Last is the beginning. |
| 2251 | |
| 2252 | return It : constant Iterator := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 2253 | (Limited_Controlled with |
| 2254 | Container => V, |
| 2255 | Index => No_Index) |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 2256 | do |
| 2257 | B := B + 1; |
| 2258 | end return; |
| 2259 | end Iterate; |
| 2260 | |
| 2261 | function Iterate |
| 2262 | (Container : Vector; |
| 2263 | Start : Cursor) |
| 2264 | return Vector_Iterator_Interfaces.Reversible_Iterator'class |
| 2265 | is |
| 2266 | V : constant Vector_Access := Container'Unrestricted_Access; |
| 2267 | B : Natural renames V.Busy; |
| 2268 | |
| 2269 | begin |
| 2270 | -- It was formerly the case that when Start = No_Element, the partial |
| 2271 | -- iterator was defined to behave the same as for a complete iterator, |
| 2272 | -- and iterate over the entire sequence of items. However, those |
| 2273 | -- semantics were unintuitive and arguably error-prone (it is too easy |
| 2274 | -- to accidentally create an endless loop), and so they were changed, |
| 2275 | -- per the ARG meeting in Denver on 2011/11. However, there was no |
| 2276 | -- consensus about what positive meaning this corner case should have, |
| 2277 | -- and so it was decided to simply raise an exception. This does imply, |
| 2278 | -- however, that it is not possible to use a partial iterator to specify |
| 2279 | -- an empty sequence of items. |
| 2280 | |
| 2281 | if Start.Container = null then |
| 2282 | raise Constraint_Error with |
| 2283 | "Start position for iterator equals No_Element"; |
| 2284 | end if; |
| 2285 | |
| 2286 | if Start.Container /= V then |
| 2287 | raise Program_Error with |
| 2288 | "Start cursor of Iterate designates wrong vector"; |
| 2289 | end if; |
| 2290 | |
| 2291 | if Start.Index > V.Last then |
| 2292 | raise Constraint_Error with |
| 2293 | "Start position for iterator equals No_Element"; |
| 2294 | end if; |
| 2295 | |
| 2296 | -- The value of its Index component influences the behavior of the First |
| 2297 | -- and Last selector functions of the iterator object. When the Index |
| 2298 | -- component is not No_Index (as is the case here), it means that this |
| 2299 | -- is a partial iteration, over a subset of the complete sequence of |
| 2300 | -- items. The iterator object was constructed with a start expression, |
| 2301 | -- indicating the position from which the iteration begins. Note that |
| 2302 | -- the start position has the same value irrespective of whether this |
| 2303 | -- is a forward or reverse iteration. |
| 2304 | |
| 2305 | return It : constant Iterator := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 2306 | (Limited_Controlled with |
| 2307 | Container => V, |
| 2308 | Index => Start.Index) |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 2309 | do |
| 2310 | B := B + 1; |
| 2311 | end return; |
| 2312 | end Iterate; |
| 2313 | |
| 2314 | ---------- |
| 2315 | -- Last -- |
| 2316 | ---------- |
| 2317 | |
| 2318 | function Last (Container : Vector) return Cursor is |
| 2319 | begin |
| 2320 | if Is_Empty (Container) then |
| 2321 | return No_Element; |
| 2322 | else |
| 2323 | return (Container'Unrestricted_Access, Container.Last); |
| 2324 | end if; |
| 2325 | end Last; |
| 2326 | |
| 2327 | function Last (Object : Iterator) return Cursor is |
| 2328 | begin |
| 2329 | -- The value of the iterator object's Index component influences the |
| 2330 | -- behavior of the Last (and First) selector function. |
| 2331 | |
| 2332 | -- When the Index component is No_Index, this means the iterator |
| 2333 | -- object was constructed without a start expression, in which case the |
| 2334 | -- (reverse) iteration starts from the (logical) beginning of the entire |
| 2335 | -- sequence (corresponding to Container.Last, for a reverse iterator). |
| 2336 | |
| 2337 | -- Otherwise, this is iteration over a partial sequence of items. |
| 2338 | -- When the Index component is not No_Index, the iterator object was |
| 2339 | -- constructed with a start expression, that specifies the position |
| 2340 | -- from which the (reverse) partial iteration begins. |
| 2341 | |
| 2342 | if Object.Index = No_Index then |
| 2343 | return Last (Object.Container.all); |
| 2344 | else |
| 2345 | return Cursor'(Object.Container, Object.Index); |
| 2346 | end if; |
| 2347 | end Last; |
| 2348 | |
| 2349 | ------------------ |
| 2350 | -- Last_Element -- |
| 2351 | ------------------ |
| 2352 | |
| 2353 | function Last_Element (Container : Vector) return Element_Type is |
| 2354 | begin |
| 2355 | if Container.Last = No_Index then |
| 2356 | raise Constraint_Error with "Container is empty"; |
| 2357 | else |
| 2358 | return Container.Elements.EA (Container.Last); |
| 2359 | end if; |
| 2360 | end Last_Element; |
| 2361 | |
| 2362 | ---------------- |
| 2363 | -- Last_Index -- |
| 2364 | ---------------- |
| 2365 | |
| 2366 | function Last_Index (Container : Vector) return Extended_Index is |
| 2367 | begin |
| 2368 | return Container.Last; |
| 2369 | end Last_Index; |
| 2370 | |
| 2371 | ------------ |
| 2372 | -- Length -- |
| 2373 | ------------ |
| 2374 | |
| 2375 | function Length (Container : Vector) return Count_Type is |
| 2376 | L : constant Index_Type'Base := Container.Last; |
| 2377 | F : constant Index_Type := Index_Type'First; |
| 2378 | |
| 2379 | begin |
| 2380 | -- The base range of the index type (Index_Type'Base) might not include |
| 2381 | -- all values for length (Count_Type). Contrariwise, the index type |
| 2382 | -- might include values outside the range of length. Hence we use |
| 2383 | -- whatever type is wider for intermediate values when calculating |
| 2384 | -- length. Note that no matter what the index type is, the maximum |
| 2385 | -- length to which a vector is allowed to grow is always the minimum |
| 2386 | -- of Count_Type'Last and (IT'Last - IT'First + 1). |
| 2387 | |
| 2388 | -- For example, an Index_Type with range -127 .. 127 is only guaranteed |
| 2389 | -- to have a base range of -128 .. 127, but the corresponding vector |
| 2390 | -- would have lengths in the range 0 .. 255. In this case we would need |
| 2391 | -- to use Count_Type'Base for intermediate values. |
| 2392 | |
| 2393 | -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The |
| 2394 | -- vector would have a maximum length of 10, but the index values lie |
| 2395 | -- outside the range of Count_Type (which is only 32 bits). In this |
| 2396 | -- case we would need to use Index_Type'Base for intermediate values. |
| 2397 | |
| 2398 | if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then |
| 2399 | return Count_Type'Base (L) - Count_Type'Base (F) + 1; |
| 2400 | else |
| 2401 | return Count_Type (L - F + 1); |
| 2402 | end if; |
| 2403 | end Length; |
| 2404 | |
| 2405 | ---------- |
| 2406 | -- Move -- |
| 2407 | ---------- |
| 2408 | |
| 2409 | procedure Move |
| 2410 | (Target : in out Vector; |
| 2411 | Source : in out Vector) |
| 2412 | is |
| 2413 | begin |
| 2414 | if Target'Address = Source'Address then |
| 2415 | return; |
| 2416 | end if; |
| 2417 | |
| 2418 | if Target.Busy > 0 then |
| 2419 | raise Program_Error with |
| 2420 | "attempt to tamper with cursors (Target is busy)"; |
| 2421 | end if; |
| 2422 | |
| 2423 | if Source.Busy > 0 then |
| 2424 | raise Program_Error with |
| 2425 | "attempt to tamper with cursors (Source is busy)"; |
| 2426 | end if; |
| 2427 | |
| 2428 | declare |
| 2429 | Target_Elements : constant Elements_Access := Target.Elements; |
| 2430 | begin |
| 2431 | Target.Elements := Source.Elements; |
| 2432 | Source.Elements := Target_Elements; |
| 2433 | end; |
| 2434 | |
| 2435 | Target.Last := Source.Last; |
| 2436 | Source.Last := No_Index; |
| 2437 | end Move; |
| 2438 | |
| 2439 | ---------- |
| 2440 | -- Next -- |
| 2441 | ---------- |
| 2442 | |
| 2443 | function Next (Position : Cursor) return Cursor is |
| 2444 | begin |
| 2445 | if Position.Container = null then |
| 2446 | return No_Element; |
| 2447 | elsif Position.Index < Position.Container.Last then |
| 2448 | return (Position.Container, Position.Index + 1); |
| 2449 | else |
| 2450 | return No_Element; |
| 2451 | end if; |
| 2452 | end Next; |
| 2453 | |
| 2454 | function Next (Object : Iterator; Position : Cursor) return Cursor is |
| 2455 | begin |
| 2456 | if Position.Container = null then |
| 2457 | return No_Element; |
| 2458 | end if; |
| 2459 | |
| 2460 | if Position.Container /= Object.Container then |
| 2461 | raise Program_Error with |
| 2462 | "Position cursor of Next designates wrong vector"; |
| 2463 | end if; |
| 2464 | |
| 2465 | return Next (Position); |
| 2466 | end Next; |
| 2467 | |
| 2468 | procedure Next (Position : in out Cursor) is |
| 2469 | begin |
| 2470 | if Position.Container = null then |
| 2471 | return; |
| 2472 | elsif Position.Index < Position.Container.Last then |
| 2473 | Position.Index := Position.Index + 1; |
| 2474 | else |
| 2475 | Position := No_Element; |
| 2476 | end if; |
| 2477 | end Next; |
| 2478 | |
| 2479 | ------------- |
| 2480 | -- Prepend -- |
| 2481 | ------------- |
| 2482 | |
| 2483 | procedure Prepend (Container : in out Vector; New_Item : Vector) is |
| 2484 | begin |
| 2485 | Insert (Container, Index_Type'First, New_Item); |
| 2486 | end Prepend; |
| 2487 | |
| 2488 | procedure Prepend |
| 2489 | (Container : in out Vector; |
| 2490 | New_Item : Element_Type; |
| 2491 | Count : Count_Type := 1) |
| 2492 | is |
| 2493 | begin |
| 2494 | Insert (Container, |
| 2495 | Index_Type'First, |
| 2496 | New_Item, |
| 2497 | Count); |
| 2498 | end Prepend; |
| 2499 | |
| 2500 | -------------- |
| 2501 | -- Previous -- |
| 2502 | -------------- |
| 2503 | |
| 2504 | function Previous (Position : Cursor) return Cursor is |
| 2505 | begin |
| 2506 | if Position.Container = null then |
| 2507 | return No_Element; |
| 2508 | elsif Position.Index > Index_Type'First then |
| 2509 | return (Position.Container, Position.Index - 1); |
| 2510 | else |
| 2511 | return No_Element; |
| 2512 | end if; |
| 2513 | end Previous; |
| 2514 | |
| 2515 | function Previous (Object : Iterator; Position : Cursor) return Cursor is |
| 2516 | begin |
| 2517 | if Position.Container = null then |
| 2518 | return No_Element; |
| 2519 | end if; |
| 2520 | |
| 2521 | if Position.Container /= Object.Container then |
| 2522 | raise Program_Error with |
| 2523 | "Position cursor of Previous designates wrong vector"; |
| 2524 | end if; |
| 2525 | |
| 2526 | return Previous (Position); |
| 2527 | end Previous; |
| 2528 | |
| 2529 | procedure Previous (Position : in out Cursor) is |
| 2530 | begin |
| 2531 | if Position.Container = null then |
| 2532 | return; |
| 2533 | elsif Position.Index > Index_Type'First then |
| 2534 | Position.Index := Position.Index - 1; |
| 2535 | else |
| 2536 | Position := No_Element; |
| 2537 | end if; |
| 2538 | end Previous; |
| 2539 | |
| 2540 | ------------------- |
| 2541 | -- Query_Element -- |
| 2542 | ------------------- |
| 2543 | |
| 2544 | procedure Query_Element |
| 2545 | (Container : Vector; |
| 2546 | Index : Index_Type; |
| 2547 | Process : not null access procedure (Element : Element_Type)) |
| 2548 | is |
| 2549 | V : Vector renames Container'Unrestricted_Access.all; |
| 2550 | B : Natural renames V.Busy; |
| 2551 | L : Natural renames V.Lock; |
| 2552 | |
| 2553 | begin |
| 2554 | if Index > Container.Last then |
| 2555 | raise Constraint_Error with "Index is out of range"; |
| 2556 | end if; |
| 2557 | |
| 2558 | B := B + 1; |
| 2559 | L := L + 1; |
| 2560 | |
| 2561 | begin |
| 2562 | Process (V.Elements.EA (Index)); |
| 2563 | exception |
| 2564 | when others => |
| 2565 | L := L - 1; |
| 2566 | B := B - 1; |
| 2567 | raise; |
| 2568 | end; |
| 2569 | |
| 2570 | L := L - 1; |
| 2571 | B := B - 1; |
| 2572 | end Query_Element; |
| 2573 | |
| 2574 | procedure Query_Element |
| 2575 | (Position : Cursor; |
| 2576 | Process : not null access procedure (Element : Element_Type)) |
| 2577 | is |
| 2578 | begin |
| 2579 | if Position.Container = null then |
| 2580 | raise Constraint_Error with "Position cursor has no element"; |
| 2581 | end if; |
| 2582 | |
| 2583 | Query_Element (Position.Container.all, Position.Index, Process); |
| 2584 | end Query_Element; |
| 2585 | |
| 2586 | ---------- |
| 2587 | -- Read -- |
| 2588 | ---------- |
| 2589 | |
| 2590 | procedure Read |
| 2591 | (Stream : not null access Root_Stream_Type'Class; |
| 2592 | Container : out Vector) |
| 2593 | is |
| 2594 | Length : Count_Type'Base; |
| 2595 | Last : Index_Type'Base := No_Index; |
| 2596 | |
| 2597 | begin |
| 2598 | Clear (Container); |
| 2599 | |
| 2600 | Count_Type'Base'Read (Stream, Length); |
| 2601 | |
| 2602 | if Length > Capacity (Container) then |
| 2603 | Reserve_Capacity (Container, Capacity => Length); |
| 2604 | end if; |
| 2605 | |
| 2606 | for J in Count_Type range 1 .. Length loop |
| 2607 | Last := Last + 1; |
| 2608 | Element_Type'Read (Stream, Container.Elements.EA (Last)); |
| 2609 | Container.Last := Last; |
| 2610 | end loop; |
| 2611 | end Read; |
| 2612 | |
| 2613 | procedure Read |
| 2614 | (Stream : not null access Root_Stream_Type'Class; |
| 2615 | Position : out Cursor) |
| 2616 | is |
| 2617 | begin |
| 2618 | raise Program_Error with "attempt to stream vector cursor"; |
| 2619 | end Read; |
| 2620 | |
| 2621 | procedure Read |
| 2622 | (Stream : not null access Root_Stream_Type'Class; |
| 2623 | Item : out Reference_Type) |
| 2624 | is |
| 2625 | begin |
| 2626 | raise Program_Error with "attempt to stream reference"; |
| 2627 | end Read; |
| 2628 | |
| 2629 | procedure Read |
| 2630 | (Stream : not null access Root_Stream_Type'Class; |
| 2631 | Item : out Constant_Reference_Type) |
| 2632 | is |
| 2633 | begin |
| 2634 | raise Program_Error with "attempt to stream reference"; |
| 2635 | end Read; |
| 2636 | |
| 2637 | --------------- |
| 2638 | -- Reference -- |
| 2639 | --------------- |
| 2640 | |
| 2641 | function Reference |
| 2642 | (Container : aliased in out Vector; |
| 2643 | Position : Cursor) return Reference_Type |
| 2644 | is |
| 2645 | begin |
| 2646 | if Position.Container = null then |
| 2647 | raise Constraint_Error with "Position cursor has no element"; |
| 2648 | end if; |
| 2649 | |
| 2650 | if Position.Container /= Container'Unrestricted_Access then |
| 2651 | raise Program_Error with "Position cursor denotes wrong container"; |
| 2652 | end if; |
| 2653 | |
| 2654 | if Position.Index > Position.Container.Last then |
| 2655 | raise Constraint_Error with "Position cursor is out of range"; |
| 2656 | end if; |
| 2657 | |
| 2658 | declare |
| 2659 | C : Vector renames Position.Container.all; |
| 2660 | B : Natural renames C.Busy; |
| 2661 | L : Natural renames C.Lock; |
| 2662 | begin |
| 2663 | return R : constant Reference_Type := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 2664 | (Element => Container.Elements.EA (Position.Index)'Access, |
| 2665 | Control => (Controlled with Position.Container)) |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 2666 | do |
| 2667 | B := B + 1; |
| 2668 | L := L + 1; |
| 2669 | end return; |
| 2670 | end; |
| 2671 | end Reference; |
| 2672 | |
| 2673 | function Reference |
| 2674 | (Container : aliased in out Vector; |
| 2675 | Index : Index_Type) return Reference_Type |
| 2676 | is |
| 2677 | begin |
| 2678 | if Index > Container.Last then |
| 2679 | raise Constraint_Error with "Index is out of range"; |
| 2680 | else |
| 2681 | declare |
| 2682 | C : Vector renames Container'Unrestricted_Access.all; |
| 2683 | B : Natural renames C.Busy; |
| 2684 | L : Natural renames C.Lock; |
| 2685 | begin |
| 2686 | return R : constant Reference_Type := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 2687 | (Element => Container.Elements.EA (Index)'Access, |
| 2688 | Control => (Controlled with Container'Unrestricted_Access)) |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 2689 | do |
| 2690 | B := B + 1; |
| 2691 | L := L + 1; |
| 2692 | end return; |
| 2693 | end; |
| 2694 | end if; |
| 2695 | end Reference; |
| 2696 | |
| 2697 | --------------------- |
| 2698 | -- Replace_Element -- |
| 2699 | --------------------- |
| 2700 | |
| 2701 | procedure Replace_Element |
| 2702 | (Container : in out Vector; |
| 2703 | Index : Index_Type; |
| 2704 | New_Item : Element_Type) |
| 2705 | is |
| 2706 | begin |
| 2707 | if Index > Container.Last then |
| 2708 | raise Constraint_Error with "Index is out of range"; |
| 2709 | end if; |
| 2710 | |
| 2711 | if Container.Lock > 0 then |
| 2712 | raise Program_Error with |
| 2713 | "attempt to tamper with elements (vector is locked)"; |
| 2714 | end if; |
| 2715 | |
| 2716 | Container.Elements.EA (Index) := New_Item; |
| 2717 | end Replace_Element; |
| 2718 | |
| 2719 | procedure Replace_Element |
| 2720 | (Container : in out Vector; |
| 2721 | Position : Cursor; |
| 2722 | New_Item : 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 | if Position.Index > Container.Last then |
| 2734 | raise Constraint_Error with "Position cursor is out of range"; |
| 2735 | end if; |
| 2736 | |
| 2737 | if Container.Lock > 0 then |
| 2738 | raise Program_Error with |
| 2739 | "attempt to tamper with elements (vector is locked)"; |
| 2740 | end if; |
| 2741 | |
| 2742 | Container.Elements.EA (Position.Index) := New_Item; |
| 2743 | end Replace_Element; |
| 2744 | |
| 2745 | ---------------------- |
| 2746 | -- Reserve_Capacity -- |
| 2747 | ---------------------- |
| 2748 | |
| 2749 | procedure Reserve_Capacity |
| 2750 | (Container : in out Vector; |
| 2751 | Capacity : Count_Type) |
| 2752 | is |
| 2753 | N : constant Count_Type := Length (Container); |
| 2754 | |
| 2755 | Index : Count_Type'Base; |
| 2756 | Last : Index_Type'Base; |
| 2757 | |
| 2758 | begin |
| 2759 | -- Reserve_Capacity can be used to either expand the storage available |
| 2760 | -- for elements (this would be its typical use, in anticipation of |
| 2761 | -- future insertion), or to trim back storage. In the latter case, |
| 2762 | -- storage can only be trimmed back to the limit of the container |
| 2763 | -- length. Note that Reserve_Capacity neither deletes (active) elements |
| 2764 | -- nor inserts elements; it only affects container capacity, never |
| 2765 | -- container length. |
| 2766 | |
| 2767 | if Capacity = 0 then |
| 2768 | |
| 2769 | -- This is a request to trim back storage, to the minimum amount |
| 2770 | -- possible given the current state of the container. |
| 2771 | |
| 2772 | if N = 0 then |
| 2773 | |
| 2774 | -- The container is empty, so in this unique case we can |
| 2775 | -- deallocate the entire internal array. Note that an empty |
| 2776 | -- container can never be busy, so there's no need to check the |
| 2777 | -- tampering bits. |
| 2778 | |
| 2779 | declare |
| 2780 | X : Elements_Access := Container.Elements; |
| 2781 | |
| 2782 | begin |
| 2783 | -- First we remove the internal array from the container, to |
| 2784 | -- handle the case when the deallocation raises an exception. |
| 2785 | |
| 2786 | Container.Elements := null; |
| 2787 | |
| 2788 | -- Container invariants have been restored, so it is now safe |
| 2789 | -- to attempt to deallocate the internal array. |
| 2790 | |
| 2791 | Free (X); |
| 2792 | end; |
| 2793 | |
| 2794 | elsif N < Container.Elements.EA'Length then |
| 2795 | |
| 2796 | -- The container is not empty, and the current length is less than |
| 2797 | -- the current capacity, so there's storage available to trim. In |
| 2798 | -- this case, we allocate a new internal array having a length |
| 2799 | -- that exactly matches the number of items in the |
| 2800 | -- container. (Reserve_Capacity does not delete active elements, |
| 2801 | -- so this is the best we can do with respect to minimizing |
| 2802 | -- storage). |
| 2803 | |
| 2804 | if Container.Busy > 0 then |
| 2805 | raise Program_Error with |
| 2806 | "attempt to tamper with cursors (vector is busy)"; |
| 2807 | end if; |
| 2808 | |
| 2809 | declare |
| 2810 | subtype Src_Index_Subtype is Index_Type'Base range |
| 2811 | Index_Type'First .. Container.Last; |
| 2812 | |
| 2813 | Src : Elements_Array renames |
| 2814 | Container.Elements.EA (Src_Index_Subtype); |
| 2815 | |
| 2816 | X : Elements_Access := Container.Elements; |
| 2817 | |
| 2818 | begin |
| 2819 | -- Although we have isolated the old internal array that we're |
| 2820 | -- going to deallocate, we don't deallocate it until we have |
| 2821 | -- successfully allocated a new one. If there is an exception |
| 2822 | -- during allocation (either because there is not enough |
| 2823 | -- storage, or because initialization of the elements fails), |
| 2824 | -- we let it propagate without causing any side-effect. |
| 2825 | |
| 2826 | Container.Elements := new Elements_Type'(Container.Last, Src); |
| 2827 | |
| 2828 | -- We have successfully allocated a new internal array (with a |
| 2829 | -- smaller length than the old one, and containing a copy of |
| 2830 | -- just the active elements in the container), so it is now |
| 2831 | -- safe to attempt to deallocate the old array. The old array |
| 2832 | -- has been isolated, and container invariants have been |
| 2833 | -- restored, so if the deallocation fails (because finalization |
| 2834 | -- of the elements fails), we simply let it propagate. |
| 2835 | |
| 2836 | Free (X); |
| 2837 | end; |
| 2838 | end if; |
| 2839 | |
| 2840 | return; |
| 2841 | end if; |
| 2842 | |
| 2843 | -- Reserve_Capacity can be used to expand the storage available for |
| 2844 | -- elements, but we do not let the capacity grow beyond the number of |
| 2845 | -- values in Index_Type'Range. (Were it otherwise, there would be no way |
| 2846 | -- to refer to the elements with an index value greater than |
| 2847 | -- Index_Type'Last, so that storage would be wasted.) Here we compute |
| 2848 | -- the Last index value of the new internal array, in a way that avoids |
| 2849 | -- any possibility of overflow. |
| 2850 | |
| 2851 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 2852 | |
| 2853 | -- We perform a two-part test. First we determine whether the |
| 2854 | -- computed Last value lies in the base range of the type, and then |
| 2855 | -- determine whether it lies in the range of the index (sub)type. |
| 2856 | |
| 2857 | -- Last must satisfy this relation: |
| 2858 | -- First + Length - 1 <= Last |
| 2859 | -- We regroup terms: |
| 2860 | -- First - 1 <= Last - Length |
| 2861 | -- Which can rewrite as: |
| 2862 | -- No_Index <= Last - Length |
| 2863 | |
| 2864 | if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then |
| 2865 | raise Constraint_Error with "Capacity is out of range"; |
| 2866 | end if; |
| 2867 | |
| 2868 | -- We now know that the computed value of Last is within the base |
| 2869 | -- range of the type, so it is safe to compute its value: |
| 2870 | |
| 2871 | Last := No_Index + Index_Type'Base (Capacity); |
| 2872 | |
| 2873 | -- Finally we test whether the value is within the range of the |
| 2874 | -- generic actual index subtype: |
| 2875 | |
| 2876 | if Last > Index_Type'Last then |
| 2877 | raise Constraint_Error with "Capacity is out of range"; |
| 2878 | end if; |
| 2879 | |
| 2880 | elsif Index_Type'First <= 0 then |
| 2881 | |
| 2882 | -- Here we can compute Last directly, in the normal way. We know that |
| 2883 | -- No_Index is less than 0, so there is no danger of overflow when |
| 2884 | -- adding the (positive) value of Capacity. |
| 2885 | |
| 2886 | Index := Count_Type'Base (No_Index) + Capacity; -- Last |
| 2887 | |
| 2888 | if Index > Count_Type'Base (Index_Type'Last) then |
| 2889 | raise Constraint_Error with "Capacity is out of range"; |
| 2890 | end if; |
| 2891 | |
| 2892 | -- We know that the computed value (having type Count_Type) of Last |
| 2893 | -- is within the range of the generic actual index subtype, so it is |
| 2894 | -- safe to convert to Index_Type: |
| 2895 | |
| 2896 | Last := Index_Type'Base (Index); |
| 2897 | |
| 2898 | else |
| 2899 | -- Here Index_Type'First (and Index_Type'Last) is positive, so we |
| 2900 | -- must test the length indirectly (by working backwards from the |
| 2901 | -- largest possible value of Last), in order to prevent overflow. |
| 2902 | |
| 2903 | Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index |
| 2904 | |
| 2905 | if Index < Count_Type'Base (No_Index) then |
| 2906 | raise Constraint_Error with "Capacity is out of range"; |
| 2907 | end if; |
| 2908 | |
| 2909 | -- We have determined that the value of Capacity would not create a |
| 2910 | -- Last index value outside of the range of Index_Type, so we can now |
| 2911 | -- safely compute its value. |
| 2912 | |
| 2913 | Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); |
| 2914 | end if; |
| 2915 | |
| 2916 | -- The requested capacity is non-zero, but we don't know yet whether |
| 2917 | -- this is a request for expansion or contraction of storage. |
| 2918 | |
| 2919 | if Container.Elements = null then |
| 2920 | |
| 2921 | -- The container is empty (it doesn't even have an internal array), |
| 2922 | -- so this represents a request to allocate (expand) storage having |
| 2923 | -- the given capacity. |
| 2924 | |
| 2925 | Container.Elements := new Elements_Type (Last); |
| 2926 | return; |
| 2927 | end if; |
| 2928 | |
| 2929 | if Capacity <= N then |
| 2930 | |
| 2931 | -- This is a request to trim back storage, but only to the limit of |
| 2932 | -- what's already in the container. (Reserve_Capacity never deletes |
| 2933 | -- active elements, it only reclaims excess storage.) |
| 2934 | |
| 2935 | if N < Container.Elements.EA'Length then |
| 2936 | |
| 2937 | -- The container is not empty (because the requested capacity is |
| 2938 | -- positive, and less than or equal to the container length), and |
| 2939 | -- the current length is less than the current capacity, so |
| 2940 | -- there's storage available to trim. In this case, we allocate a |
| 2941 | -- new internal array having a length that exactly matches the |
| 2942 | -- number of items in the container. |
| 2943 | |
| 2944 | if Container.Busy > 0 then |
| 2945 | raise Program_Error with |
| 2946 | "attempt to tamper with cursors (vector is busy)"; |
| 2947 | end if; |
| 2948 | |
| 2949 | declare |
| 2950 | subtype Src_Index_Subtype is Index_Type'Base range |
| 2951 | Index_Type'First .. Container.Last; |
| 2952 | |
| 2953 | Src : Elements_Array renames |
| 2954 | Container.Elements.EA (Src_Index_Subtype); |
| 2955 | |
| 2956 | X : Elements_Access := Container.Elements; |
| 2957 | |
| 2958 | begin |
| 2959 | -- Although we have isolated the old internal array that we're |
| 2960 | -- going to deallocate, we don't deallocate it until we have |
| 2961 | -- successfully allocated a new one. If there is an exception |
| 2962 | -- during allocation (either because there is not enough |
| 2963 | -- storage, or because initialization of the elements fails), |
| 2964 | -- we let it propagate without causing any side-effect. |
| 2965 | |
| 2966 | Container.Elements := new Elements_Type'(Container.Last, Src); |
| 2967 | |
| 2968 | -- We have successfully allocated a new internal array (with a |
| 2969 | -- smaller length than the old one, and containing a copy of |
| 2970 | -- just the active elements in the container), so it is now |
| 2971 | -- safe to attempt to deallocate the old array. The old array |
| 2972 | -- has been isolated, and container invariants have been |
| 2973 | -- restored, so if the deallocation fails (because finalization |
| 2974 | -- of the elements fails), we simply let it propagate. |
| 2975 | |
| 2976 | Free (X); |
| 2977 | end; |
| 2978 | end if; |
| 2979 | |
| 2980 | return; |
| 2981 | end if; |
| 2982 | |
| 2983 | -- The requested capacity is larger than the container length (the |
| 2984 | -- number of active elements). Whether this represents a request for |
| 2985 | -- expansion or contraction of the current capacity depends on what the |
| 2986 | -- current capacity is. |
| 2987 | |
| 2988 | if Capacity = Container.Elements.EA'Length then |
| 2989 | |
| 2990 | -- The requested capacity matches the existing capacity, so there's |
| 2991 | -- nothing to do here. We treat this case as a no-op, and simply |
| 2992 | -- return without checking the busy bit. |
| 2993 | |
| 2994 | return; |
| 2995 | end if; |
| 2996 | |
| 2997 | -- There is a change in the capacity of a non-empty container, so a new |
| 2998 | -- internal array will be allocated. (The length of the new internal |
| 2999 | -- array could be less or greater than the old internal array. We know |
| 3000 | -- only that the length of the new internal array is greater than the |
| 3001 | -- number of active elements in the container.) We must check whether |
| 3002 | -- the container is busy before doing anything else. |
| 3003 | |
| 3004 | if Container.Busy > 0 then |
| 3005 | raise Program_Error with |
| 3006 | "attempt to tamper with cursors (vector is busy)"; |
| 3007 | end if; |
| 3008 | |
| 3009 | -- We now allocate a new internal array, having a length different from |
| 3010 | -- its current value. |
| 3011 | |
| 3012 | declare |
| 3013 | E : Elements_Access := new Elements_Type (Last); |
| 3014 | |
| 3015 | begin |
| 3016 | -- We have successfully allocated the new internal array. We first |
| 3017 | -- attempt to copy the existing elements from the old internal array |
| 3018 | -- ("src" elements) onto the new internal array ("tgt" elements). |
| 3019 | |
| 3020 | declare |
| 3021 | subtype Index_Subtype is Index_Type'Base range |
| 3022 | Index_Type'First .. Container.Last; |
| 3023 | |
| 3024 | Src : Elements_Array renames |
| 3025 | Container.Elements.EA (Index_Subtype); |
| 3026 | |
| 3027 | Tgt : Elements_Array renames E.EA (Index_Subtype); |
| 3028 | |
| 3029 | begin |
| 3030 | Tgt := Src; |
| 3031 | |
| 3032 | exception |
| 3033 | when others => |
| 3034 | Free (E); |
| 3035 | raise; |
| 3036 | end; |
| 3037 | |
| 3038 | -- We have successfully copied the existing elements onto the new |
| 3039 | -- internal array, so now we can attempt to deallocate the old one. |
| 3040 | |
| 3041 | declare |
| 3042 | X : Elements_Access := Container.Elements; |
| 3043 | |
| 3044 | begin |
| 3045 | -- First we isolate the old internal array, and replace it in the |
| 3046 | -- container with the new internal array. |
| 3047 | |
| 3048 | Container.Elements := E; |
| 3049 | |
| 3050 | -- Container invariants have been restored, so it is now safe to |
| 3051 | -- attempt to deallocate the old internal array. |
| 3052 | |
| 3053 | Free (X); |
| 3054 | end; |
| 3055 | end; |
| 3056 | end Reserve_Capacity; |
| 3057 | |
| 3058 | ---------------------- |
| 3059 | -- Reverse_Elements -- |
| 3060 | ---------------------- |
| 3061 | |
| 3062 | procedure Reverse_Elements (Container : in out Vector) is |
| 3063 | begin |
| 3064 | if Container.Length <= 1 then |
| 3065 | return; |
| 3066 | end if; |
| 3067 | |
| 3068 | -- The exception behavior for the vector container must match that for |
| 3069 | -- the list container, so we check for cursor tampering here (which will |
| 3070 | -- catch more things) instead of for element tampering (which will catch |
| 3071 | -- fewer things). It's true that the elements of this vector container |
| 3072 | -- could be safely moved around while (say) an iteration is taking place |
| 3073 | -- (iteration only increments the busy counter), and so technically |
| 3074 | -- all we would need here is a test for element tampering (indicated |
| 3075 | -- by the lock counter), that's simply an artifact of our array-based |
| 3076 | -- implementation. Logically Reverse_Elements requires a check for |
| 3077 | -- cursor tampering. |
| 3078 | |
| 3079 | if Container.Busy > 0 then |
| 3080 | raise Program_Error with |
| 3081 | "attempt to tamper with cursors (vector is busy)"; |
| 3082 | end if; |
| 3083 | |
| 3084 | declare |
| 3085 | K : Index_Type; |
| 3086 | J : Index_Type; |
| 3087 | E : Elements_Type renames Container.Elements.all; |
| 3088 | |
| 3089 | begin |
| 3090 | K := Index_Type'First; |
| 3091 | J := Container.Last; |
| 3092 | while K < J loop |
| 3093 | declare |
| 3094 | EK : constant Element_Type := E.EA (K); |
| 3095 | begin |
| 3096 | E.EA (K) := E.EA (J); |
| 3097 | E.EA (J) := EK; |
| 3098 | end; |
| 3099 | |
| 3100 | K := K + 1; |
| 3101 | J := J - 1; |
| 3102 | end loop; |
| 3103 | end; |
| 3104 | end Reverse_Elements; |
| 3105 | |
| 3106 | ------------------ |
| 3107 | -- Reverse_Find -- |
| 3108 | ------------------ |
| 3109 | |
| 3110 | function Reverse_Find |
| 3111 | (Container : Vector; |
| 3112 | Item : Element_Type; |
| 3113 | Position : Cursor := No_Element) return Cursor |
| 3114 | is |
| 3115 | Last : Index_Type'Base; |
| 3116 | |
| 3117 | begin |
| 3118 | if Position.Container /= null |
| 3119 | and then Position.Container /= Container'Unrestricted_Access |
| 3120 | then |
| 3121 | raise Program_Error with "Position cursor denotes wrong container"; |
| 3122 | end if; |
| 3123 | |
| 3124 | Last := |
| 3125 | (if Position.Container = null or else Position.Index > Container.Last |
| 3126 | then Container.Last |
| 3127 | else Position.Index); |
| 3128 | |
| 3129 | for Indx in reverse Index_Type'First .. Last loop |
| 3130 | if Container.Elements.EA (Indx) = Item then |
| 3131 | return (Container'Unrestricted_Access, Indx); |
| 3132 | end if; |
| 3133 | end loop; |
| 3134 | |
| 3135 | return No_Element; |
| 3136 | end Reverse_Find; |
| 3137 | |
| 3138 | ------------------------ |
| 3139 | -- Reverse_Find_Index -- |
| 3140 | ------------------------ |
| 3141 | |
| 3142 | function Reverse_Find_Index |
| 3143 | (Container : Vector; |
| 3144 | Item : Element_Type; |
| 3145 | Index : Index_Type := Index_Type'Last) return Extended_Index |
| 3146 | is |
| 3147 | Last : constant Index_Type'Base := |
Bernhard Rosenkraenzer | ee2ec6d | 2012-10-10 01:40:27 +0159 | [diff] [blame^] | 3148 | Index_Type'Min (Container.Last, Index); |
Bernhard Rosenkraenzer | c83ebe5 | 2012-09-18 21:38:03 +0159 | [diff] [blame] | 3149 | |
| 3150 | begin |
| 3151 | for Indx in reverse Index_Type'First .. Last loop |
| 3152 | if Container.Elements.EA (Indx) = Item then |
| 3153 | return Indx; |
| 3154 | end if; |
| 3155 | end loop; |
| 3156 | |
| 3157 | return No_Index; |
| 3158 | end Reverse_Find_Index; |
| 3159 | |
| 3160 | --------------------- |
| 3161 | -- Reverse_Iterate -- |
| 3162 | --------------------- |
| 3163 | |
| 3164 | procedure Reverse_Iterate |
| 3165 | (Container : Vector; |
| 3166 | Process : not null access procedure (Position : Cursor)) |
| 3167 | is |
| 3168 | V : Vector renames Container'Unrestricted_Access.all; |
| 3169 | B : Natural renames V.Busy; |
| 3170 | |
| 3171 | begin |
| 3172 | B := B + 1; |
| 3173 | |
| 3174 | begin |
| 3175 | for Indx in reverse Index_Type'First .. Container.Last loop |
| 3176 | Process (Cursor'(Container'Unrestricted_Access, Indx)); |
| 3177 | end loop; |
| 3178 | exception |
| 3179 | when others => |
| 3180 | B := B - 1; |
| 3181 | raise; |
| 3182 | end; |
| 3183 | |
| 3184 | B := B - 1; |
| 3185 | end Reverse_Iterate; |
| 3186 | |
| 3187 | ---------------- |
| 3188 | -- Set_Length -- |
| 3189 | ---------------- |
| 3190 | |
| 3191 | procedure Set_Length (Container : in out Vector; Length : Count_Type) is |
| 3192 | Count : constant Count_Type'Base := Container.Length - Length; |
| 3193 | |
| 3194 | begin |
| 3195 | -- Set_Length allows the user to set the length explicitly, instead |
| 3196 | -- of implicitly as a side-effect of deletion or insertion. If the |
| 3197 | -- requested length is less than the current length, this is equivalent |
| 3198 | -- to deleting items from the back end of the vector. If the requested |
| 3199 | -- length is greater than the current length, then this is equivalent |
| 3200 | -- to inserting "space" (nonce items) at the end. |
| 3201 | |
| 3202 | if Count >= 0 then |
| 3203 | Container.Delete_Last (Count); |
| 3204 | |
| 3205 | elsif Container.Last >= Index_Type'Last then |
| 3206 | raise Constraint_Error with "vector is already at its maximum length"; |
| 3207 | |
| 3208 | else |
| 3209 | Container.Insert_Space (Container.Last + 1, -Count); |
| 3210 | end if; |
| 3211 | end Set_Length; |
| 3212 | |
| 3213 | ---------- |
| 3214 | -- Swap -- |
| 3215 | ---------- |
| 3216 | |
| 3217 | procedure Swap (Container : in out Vector; I, J : Index_Type) is |
| 3218 | begin |
| 3219 | if I > Container.Last then |
| 3220 | raise Constraint_Error with "I index is out of range"; |
| 3221 | end if; |
| 3222 | |
| 3223 | if J > Container.Last then |
| 3224 | raise Constraint_Error with "J index is out of range"; |
| 3225 | end if; |
| 3226 | |
| 3227 | if I = J then |
| 3228 | return; |
| 3229 | end if; |
| 3230 | |
| 3231 | if Container.Lock > 0 then |
| 3232 | raise Program_Error with |
| 3233 | "attempt to tamper with elements (vector is locked)"; |
| 3234 | end if; |
| 3235 | |
| 3236 | declare |
| 3237 | EI_Copy : constant Element_Type := Container.Elements.EA (I); |
| 3238 | begin |
| 3239 | Container.Elements.EA (I) := Container.Elements.EA (J); |
| 3240 | Container.Elements.EA (J) := EI_Copy; |
| 3241 | end; |
| 3242 | end Swap; |
| 3243 | |
| 3244 | procedure Swap (Container : in out Vector; I, J : Cursor) is |
| 3245 | begin |
| 3246 | if I.Container = null then |
| 3247 | raise Constraint_Error with "I cursor has no element"; |
| 3248 | end if; |
| 3249 | |
| 3250 | if J.Container = null then |
| 3251 | raise Constraint_Error with "J cursor has no element"; |
| 3252 | end if; |
| 3253 | |
| 3254 | if I.Container /= Container'Unrestricted_Access then |
| 3255 | raise Program_Error with "I cursor denotes wrong container"; |
| 3256 | end if; |
| 3257 | |
| 3258 | if J.Container /= Container'Unrestricted_Access then |
| 3259 | raise Program_Error with "J cursor denotes wrong container"; |
| 3260 | end if; |
| 3261 | |
| 3262 | Swap (Container, I.Index, J.Index); |
| 3263 | end Swap; |
| 3264 | |
| 3265 | --------------- |
| 3266 | -- To_Cursor -- |
| 3267 | --------------- |
| 3268 | |
| 3269 | function To_Cursor |
| 3270 | (Container : Vector; |
| 3271 | Index : Extended_Index) return Cursor |
| 3272 | is |
| 3273 | begin |
| 3274 | if Index not in Index_Type'First .. Container.Last then |
| 3275 | return No_Element; |
| 3276 | else |
| 3277 | return (Container'Unrestricted_Access, Index); |
| 3278 | end if; |
| 3279 | end To_Cursor; |
| 3280 | |
| 3281 | -------------- |
| 3282 | -- To_Index -- |
| 3283 | -------------- |
| 3284 | |
| 3285 | function To_Index (Position : Cursor) return Extended_Index is |
| 3286 | begin |
| 3287 | if Position.Container = null then |
| 3288 | return No_Index; |
| 3289 | end if; |
| 3290 | |
| 3291 | if Position.Index <= Position.Container.Last then |
| 3292 | return Position.Index; |
| 3293 | end if; |
| 3294 | |
| 3295 | return No_Index; |
| 3296 | end To_Index; |
| 3297 | |
| 3298 | --------------- |
| 3299 | -- To_Vector -- |
| 3300 | --------------- |
| 3301 | |
| 3302 | function To_Vector (Length : Count_Type) return Vector is |
| 3303 | Index : Count_Type'Base; |
| 3304 | Last : Index_Type'Base; |
| 3305 | Elements : Elements_Access; |
| 3306 | |
| 3307 | begin |
| 3308 | if Length = 0 then |
| 3309 | return Empty_Vector; |
| 3310 | end if; |
| 3311 | |
| 3312 | -- We create a vector object with a capacity that matches the specified |
| 3313 | -- Length, but we do not allow the vector capacity (the length of the |
| 3314 | -- internal array) to exceed the number of values in Index_Type'Range |
| 3315 | -- (otherwise, there would be no way to refer to those components via an |
| 3316 | -- index). We must therefore check whether the specified Length would |
| 3317 | -- create a Last index value greater than Index_Type'Last. |
| 3318 | |
| 3319 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 3320 | |
| 3321 | -- We perform a two-part test. First we determine whether the |
| 3322 | -- computed Last value lies in the base range of the type, and then |
| 3323 | -- determine whether it lies in the range of the index (sub)type. |
| 3324 | |
| 3325 | -- Last must satisfy this relation: |
| 3326 | -- First + Length - 1 <= Last |
| 3327 | -- We regroup terms: |
| 3328 | -- First - 1 <= Last - Length |
| 3329 | -- Which can rewrite as: |
| 3330 | -- No_Index <= Last - Length |
| 3331 | |
| 3332 | if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then |
| 3333 | raise Constraint_Error with "Length is out of range"; |
| 3334 | end if; |
| 3335 | |
| 3336 | -- We now know that the computed value of Last is within the base |
| 3337 | -- range of the type, so it is safe to compute its value: |
| 3338 | |
| 3339 | Last := No_Index + Index_Type'Base (Length); |
| 3340 | |
| 3341 | -- Finally we test whether the value is within the range of the |
| 3342 | -- generic actual index subtype: |
| 3343 | |
| 3344 | if Last > Index_Type'Last then |
| 3345 | raise Constraint_Error with "Length is out of range"; |
| 3346 | end if; |
| 3347 | |
| 3348 | elsif Index_Type'First <= 0 then |
| 3349 | |
| 3350 | -- Here we can compute Last directly, in the normal way. We know that |
| 3351 | -- No_Index is less than 0, so there is no danger of overflow when |
| 3352 | -- adding the (positive) value of Length. |
| 3353 | |
| 3354 | Index := Count_Type'Base (No_Index) + Length; -- Last |
| 3355 | |
| 3356 | if Index > Count_Type'Base (Index_Type'Last) then |
| 3357 | raise Constraint_Error with "Length is out of range"; |
| 3358 | end if; |
| 3359 | |
| 3360 | -- We know that the computed value (having type Count_Type) of Last |
| 3361 | -- is within the range of the generic actual index subtype, so it is |
| 3362 | -- safe to convert to Index_Type: |
| 3363 | |
| 3364 | Last := Index_Type'Base (Index); |
| 3365 | |
| 3366 | else |
| 3367 | -- Here Index_Type'First (and Index_Type'Last) is positive, so we |
| 3368 | -- must test the length indirectly (by working backwards from the |
| 3369 | -- largest possible value of Last), in order to prevent overflow. |
| 3370 | |
| 3371 | Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index |
| 3372 | |
| 3373 | if Index < Count_Type'Base (No_Index) then |
| 3374 | raise Constraint_Error with "Length is out of range"; |
| 3375 | end if; |
| 3376 | |
| 3377 | -- We have determined that the value of Length would not create a |
| 3378 | -- Last index value outside of the range of Index_Type, so we can now |
| 3379 | -- safely compute its value. |
| 3380 | |
| 3381 | Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); |
| 3382 | end if; |
| 3383 | |
| 3384 | Elements := new Elements_Type (Last); |
| 3385 | |
| 3386 | return Vector'(Controlled with Elements, Last, 0, 0); |
| 3387 | end To_Vector; |
| 3388 | |
| 3389 | function To_Vector |
| 3390 | (New_Item : Element_Type; |
| 3391 | Length : Count_Type) return Vector |
| 3392 | is |
| 3393 | Index : Count_Type'Base; |
| 3394 | Last : Index_Type'Base; |
| 3395 | Elements : Elements_Access; |
| 3396 | |
| 3397 | begin |
| 3398 | if Length = 0 then |
| 3399 | return Empty_Vector; |
| 3400 | end if; |
| 3401 | |
| 3402 | -- We create a vector object with a capacity that matches the specified |
| 3403 | -- Length, but we do not allow the vector capacity (the length of the |
| 3404 | -- internal array) to exceed the number of values in Index_Type'Range |
| 3405 | -- (otherwise, there would be no way to refer to those components via an |
| 3406 | -- index). We must therefore check whether the specified Length would |
| 3407 | -- create a Last index value greater than Index_Type'Last. |
| 3408 | |
| 3409 | if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then |
| 3410 | |
| 3411 | -- We perform a two-part test. First we determine whether the |
| 3412 | -- computed Last value lies in the base range of the type, and then |
| 3413 | -- determine whether it lies in the range of the index (sub)type. |
| 3414 | |
| 3415 | -- Last must satisfy this relation: |
| 3416 | -- First + Length - 1 <= Last |
| 3417 | -- We regroup terms: |
| 3418 | -- First - 1 <= Last - Length |
| 3419 | -- Which can rewrite as: |
| 3420 | -- No_Index <= Last - Length |
| 3421 | |
| 3422 | if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then |
| 3423 | raise Constraint_Error with "Length is out of range"; |
| 3424 | end if; |
| 3425 | |
| 3426 | -- We now know that the computed value of Last is within the base |
| 3427 | -- range of the type, so it is safe to compute its value: |
| 3428 | |
| 3429 | Last := No_Index + Index_Type'Base (Length); |
| 3430 | |
| 3431 | -- Finally we test whether the value is within the range of the |
| 3432 | -- generic actual index subtype: |
| 3433 | |
| 3434 | if Last > Index_Type'Last then |
| 3435 | raise Constraint_Error with "Length is out of range"; |
| 3436 | end if; |
| 3437 | |
| 3438 | elsif Index_Type'First <= 0 then |
| 3439 | |
| 3440 | -- Here we can compute Last directly, in the normal way. We know that |
| 3441 | -- No_Index is less than 0, so there is no danger of overflow when |
| 3442 | -- adding the (positive) value of Length. |
| 3443 | |
| 3444 | Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last |
| 3445 | |
| 3446 | if Index > Count_Type'Base (Index_Type'Last) then |
| 3447 | raise Constraint_Error with "Length is out of range"; |
| 3448 | end if; |
| 3449 | |
| 3450 | -- We know that the computed value (having type Count_Type) of Last |
| 3451 | -- is within the range of the generic actual index subtype, so it is |
| 3452 | -- safe to convert to Index_Type: |
| 3453 | |
| 3454 | Last := Index_Type'Base (Index); |
| 3455 | |
| 3456 | else |
| 3457 | -- Here Index_Type'First (and Index_Type'Last) is positive, so we |
| 3458 | -- must test the length indirectly (by working backwards from the |
| 3459 | -- largest possible value of Last), in order to prevent overflow. |
| 3460 | |
| 3461 | Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index |
| 3462 | |
| 3463 | if Index < Count_Type'Base (No_Index) then |
| 3464 | raise Constraint_Error with "Length is out of range"; |
| 3465 | end if; |
| 3466 | |
| 3467 | -- We have determined that the value of Length would not create a |
| 3468 | -- Last index value outside of the range of Index_Type, so we can now |
| 3469 | -- safely compute its value. |
| 3470 | |
| 3471 | Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); |
| 3472 | end if; |
| 3473 | |
| 3474 | Elements := new Elements_Type'(Last, EA => (others => New_Item)); |
| 3475 | |
| 3476 | return Vector'(Controlled with Elements, Last, 0, 0); |
| 3477 | end To_Vector; |
| 3478 | |
| 3479 | -------------------- |
| 3480 | -- Update_Element -- |
| 3481 | -------------------- |
| 3482 | |
| 3483 | procedure Update_Element |
| 3484 | (Container : in out Vector; |
| 3485 | Index : Index_Type; |
| 3486 | Process : not null access procedure (Element : in out Element_Type)) |
| 3487 | is |
| 3488 | B : Natural renames Container.Busy; |
| 3489 | L : Natural renames Container.Lock; |
| 3490 | |
| 3491 | begin |
| 3492 | if Index > Container.Last then |
| 3493 | raise Constraint_Error with "Index is out of range"; |
| 3494 | end if; |
| 3495 | |
| 3496 | B := B + 1; |
| 3497 | L := L + 1; |
| 3498 | |
| 3499 | begin |
| 3500 | Process (Container.Elements.EA (Index)); |
| 3501 | exception |
| 3502 | when others => |
| 3503 | L := L - 1; |
| 3504 | B := B - 1; |
| 3505 | raise; |
| 3506 | end; |
| 3507 | |
| 3508 | L := L - 1; |
| 3509 | B := B - 1; |
| 3510 | end Update_Element; |
| 3511 | |
| 3512 | procedure Update_Element |
| 3513 | (Container : in out Vector; |
| 3514 | Position : Cursor; |
| 3515 | Process : not null access procedure (Element : in out Element_Type)) |
| 3516 | is |
| 3517 | begin |
| 3518 | if Position.Container = null then |
| 3519 | raise Constraint_Error with "Position cursor has no element"; |
| 3520 | elsif Position.Container /= Container'Unrestricted_Access then |
| 3521 | raise Program_Error with "Position cursor denotes wrong container"; |
| 3522 | else |
| 3523 | Update_Element (Container, Position.Index, Process); |
| 3524 | end if; |
| 3525 | end Update_Element; |
| 3526 | |
| 3527 | ----------- |
| 3528 | -- Write -- |
| 3529 | ----------- |
| 3530 | |
| 3531 | procedure Write |
| 3532 | (Stream : not null access Root_Stream_Type'Class; |
| 3533 | Container : Vector) |
| 3534 | is |
| 3535 | begin |
| 3536 | Count_Type'Base'Write (Stream, Length (Container)); |
| 3537 | |
| 3538 | for J in Index_Type'First .. Container.Last loop |
| 3539 | Element_Type'Write (Stream, Container.Elements.EA (J)); |
| 3540 | end loop; |
| 3541 | end Write; |
| 3542 | |
| 3543 | procedure Write |
| 3544 | (Stream : not null access Root_Stream_Type'Class; |
| 3545 | Position : Cursor) |
| 3546 | is |
| 3547 | begin |
| 3548 | raise Program_Error with "attempt to stream vector cursor"; |
| 3549 | end Write; |
| 3550 | |
| 3551 | procedure Write |
| 3552 | (Stream : not null access Root_Stream_Type'Class; |
| 3553 | Item : Reference_Type) |
| 3554 | is |
| 3555 | begin |
| 3556 | raise Program_Error with "attempt to stream reference"; |
| 3557 | end Write; |
| 3558 | |
| 3559 | procedure Write |
| 3560 | (Stream : not null access Root_Stream_Type'Class; |
| 3561 | Item : Constant_Reference_Type) |
| 3562 | is |
| 3563 | begin |
| 3564 | raise Program_Error with "attempt to stream reference"; |
| 3565 | end Write; |
| 3566 | |
| 3567 | end Ada.Containers.Vectors; |