diff options
Diffstat (limited to 'gcc/ada/a-convec.adb')
| -rw-r--r-- | gcc/ada/a-convec.adb | 1220 |
1 files changed, 342 insertions, 878 deletions
diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index bf7c08b23ba..23d8d9766c0 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -36,29 +36,13 @@ package body Ada.Containers.Vectors is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers + procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - procedure Append_Slow_Path (Container : in out Vector; New_Item : Element_Type; @@ -70,273 +54,45 @@ package body Ada.Containers.Vectors is -- "&" -- --------- - function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); - N : Count_Type'Base; -- length of result - J : Count_Type'Base; -- for computing intermediate index values - Last : Index_Type'Base; -- Last index of result + -- We decide that the capacity of the result of "&" is the minimum needed + -- -- the sum of the lengths of the vector parameters. We could decide to + -- make it larger, but we have no basis for knowing how much larger, so we + -- just allocate the minimum amount of storage. + function "&" (Left, Right : Vector) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the vector parameters. We could decide to make it larger, but we - -- have no basis for knowing how much larger, so we just allocate the - -- minimum amount of storage. - - -- Here we handle the easy cases first, when one of the vector - -- parameters is empty. (We say "easy" because there's nothing to - -- compute, that can potentially overflow.) - - if LN = 0 then - if RN = 0 then - return Empty_Vector; - end if; - - declare - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - Elements : constant Elements_Access := - new Elements_Type'(Right.Last, RE); - begin - return (Controlled with Elements, Right.Last, others => <>); - end; - end if; - - if RN = 0 then - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := - new Elements_Type'(Left.Last, LE); - begin - return (Controlled with Elements, Left.Last, others => <>); - end; - - end if; - - -- Neither of the vector parameters is empty, so must compute the length - -- of the result vector and its last index. (This is the harder case, - -- because our computations must avoid overflow.) - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the combined lengths. Note that we cannot - -- simply add the lengths, because of the possibility of overflow. - - if LN > Count_Type'Last - RN then - raise Constraint_Error with "new length is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - N := LN + RN; - - -- The second constraint is that the new Last index value cannot - -- exceed Index_Type'Last. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (N); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Last > Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of length. - - J := Count_Type'Base (No_Index) + N; -- Last - - if J > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (J); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - - if J < Count_Type'Base (No_Index) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We have determined that the result length would not create a Last - -- index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + N); - end if; - - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - Elements : constant Elements_Access := - new Elements_Type'(Last, LE & RE); - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Handle easy case first, when the vector parameter (Left) is empty - - if Left.Is_Empty then - declare - Elements : constant Elements_Access := - new Elements_Type' - (Last => Index_Type'First, - EA => (others => Right)); - - begin - return (Controlled with Elements, Index_Type'First, others => <>); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Left.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Left.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Left.Last + 1; - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := - new Elements_Type'(Last => Last, EA => LE & Right); - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Handle easy case first, when the vector parameter (Right) is empty - - if Right.Is_Empty then - declare - Elements : constant Elements_Access := - new Elements_Type' - (Last => Index_Type'First, - EA => (others => Left)); - begin - return (Controlled with Elements, Index_Type'First, others => <>); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Right.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Right.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Right.Last + 1; - - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : constant Elements_Access := - new Elements_Type' - (Last => Last, - EA => Left & RE); - - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left, Right : Element_Type) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- We must compute the length of the result vector and its last index, - -- but in such a way that overflow is avoided. We must satisfy two - -- constraints: the new length cannot exceed Count_Type'Last (here, we - -- know that that condition is satisfied), and the new Last index cannot - -- exceed Index_Type'Last. - - if Index_Type'First >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Index_Type'First + 1; - - Elements : constant Elements_Access := - new Elements_Type' - (Last => Last, - EA => (Left, Right)); - - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; --------- @@ -344,57 +100,20 @@ package body Ada.Containers.Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - - if Left.Last /= Right.Last then - return False; - end if; - -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - Result := True; - for J in Index_Type range Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) /= Right.Elements.EA (J) then - Result := False; - exit; - end if; - end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + Left_Valid : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + Right_Valid : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + begin + return Left_Valid = Right_Valid; + end; end "="; ------------ @@ -415,8 +134,7 @@ package body Ada.Containers.Vectors is begin Container.Elements := null; - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); -- Note: it may seem that the following assignment to Container.Last -- is useless, since we assign it to L below. However this code is @@ -429,20 +147,6 @@ package body Ada.Containers.Vectors is end; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Append -- ------------ @@ -451,7 +155,7 @@ package body Ada.Containers.Vectors is begin if Is_Empty (New_Item) then return; - elsif Container.Last = Index_Type'Last then + elsif Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Insert (Container, Container.Last + 1, New_Item); @@ -472,10 +176,7 @@ package body Ada.Containers.Vectors is and then Container.Elements /= null and then Container.Last /= Container.Elements.Last then - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Increment Container.Last after assigning the New_Item, so we -- leave the Container unmodified in case Finalize/Adjust raises @@ -505,7 +206,7 @@ package body Ada.Containers.Vectors is begin if Count = 0 then return; - elsif Container.Last = Index_Type'Last then + elsif Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Insert (Container, Container.Last + 1, New_Item, Count); @@ -545,12 +246,8 @@ package body Ada.Containers.Vectors is procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - else - Container.Last := No_Index; - end if; + TC_Check (Container.TC); + Container.Last := No_Index; end Clear; ------------------------ @@ -562,31 +259,37 @@ package body Ada.Containers.Vectors is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; - declare - C : Vector renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin + if T_Check then + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Position.Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + else return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; + Control => (Controlled with null)); + end if; end Constant_Reference; function Constant_Reference @@ -594,22 +297,26 @@ package body Ada.Containers.Vectors is Index : Index_Type) return Constant_Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - else + end if; + + if T_Check then declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; + else + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => (Controlled with null)); end if; end Constant_Reference; @@ -642,7 +349,7 @@ package body Ada.Containers.Vectors is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -685,7 +392,7 @@ package body Ada.Containers.Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Index < Index_Type'First then + if Checks and then Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; @@ -697,7 +404,7 @@ package body Ada.Containers.Vectors is -- algorithm, so that case is treated as a proper error.) if Index > Old_Last then - if Index > Old_Last + 1 then + if Checks and then Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; else return; @@ -717,10 +424,7 @@ package body Ada.Containers.Vectors is -- the count on exit. Delete checks the count to determine whether it is -- being called while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We first calculate what's available for deletion starting at -- Index. Here and elsewhere we use the wider of Index_Type'Base and @@ -778,22 +482,21 @@ package body Ada.Containers.Vectors is Position : in out Cursor; Count : Count_Type := 1) is - pragma Warnings (Off, Position); - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; - elsif Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; - else - Delete (Container, Position.Index, Count); - Position := No_Element; + elsif Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; end Delete; ------------------ @@ -842,10 +545,7 @@ package body Ada.Containers.Vectors is -- it is being called while the associated callback procedure is -- executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- There is no restriction on how large Count can be when deleting -- items. If it is equal or greater than the current length, then this @@ -878,7 +578,7 @@ package body Ada.Containers.Vectors is Index : Index_Type) return Element_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; else return Container.Elements.EA (Index); @@ -887,13 +587,15 @@ package body Ada.Containers.Vectors is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - elsif Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - else - return Position.Container.Elements.EA (Position.Index); + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; + + return Position.Container.Elements.EA (Position.Index); end Element; -------------- @@ -909,32 +611,13 @@ package body Ada.Containers.Vectors is Free (X); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); end Finalize; procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is + pragma Assert (T_Check); -- not called if check suppressed begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -947,7 +630,7 @@ package body Ada.Containers.Vectors is Position : Cursor := No_Element) return Cursor is begin - if Position.Container /= null then + if Checks and then Position.Container /= null then if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -961,38 +644,15 @@ package body Ada.Containers.Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for J in Position.Index .. Container.Last loop if Container.Elements.EA (J) = Item then - Result := J; - exit; + return Cursor'(Container'Unrestricted_Access, J); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Find; @@ -1005,37 +665,18 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; - - Result := No_Index; + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin for Indx in Index .. Container.Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Find_Index; ----------- @@ -1080,7 +721,7 @@ package body Ada.Containers.Vectors is function First_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; else return Container.Elements.EA (Index_Type'First); @@ -1117,36 +758,16 @@ package body Ada.Containers.Vectors is -- element tampering by a generic actual subprogram. declare - EA : Elements_Array renames Container.Elements.EA; - - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Boolean; - + Lock : With_Lock (Container.TC'Unrestricted_Access); + EA : Elements_Array renames Container.Elements.EA; begin - B := B + 1; - L := L + 1; - - Result := True; for J in Index_Type'First .. Container.Last - 1 loop if EA (J + 1) < EA (J) then - Result := False; - exit; + return False; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return True; end; end Is_Sorted; @@ -1171,7 +792,7 @@ package body Ada.Containers.Vectors is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; @@ -1181,10 +802,7 @@ package body Ada.Containers.Vectors is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Source.TC); Target.Set_Length (Length (Target) + Length (Source)); @@ -1195,19 +813,9 @@ package body Ada.Containers.Vectors is TA : Elements_Array renames Target.Elements.EA; SA : Elements_Array renames Source.Elements.EA; - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; - + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - J := Target.Last; while Source.Last >= Index_Type'First loop pragma Assert (Source.Last <= Index_Type'First @@ -1236,22 +844,6 @@ package body Ada.Containers.Vectors is J := J - 1; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -1283,33 +875,15 @@ package body Ada.Containers.Vectors is -- an artifact of our array-based implementation. Logically Sort -- requires a check for cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; end Sort; @@ -1358,31 +932,33 @@ package body Ada.Containers.Vectors is Dst : Elements_Access; -- new, expanded internal array begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -1398,7 +974,7 @@ package body Ada.Containers.Vectors is -- Note: we cannot simply add these values, because of the possibility -- of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -1506,7 +1082,7 @@ package body Ada.Containers.Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -1551,10 +1127,7 @@ package body Ada.Containers.Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- An internal array has already been allocated, so we must determine -- whether there is enough unused storage for the new items. @@ -1828,7 +1401,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1839,7 +1412,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1862,7 +1435,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1879,7 +1452,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1904,7 +1477,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1915,7 +1488,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -1939,7 +1512,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1956,7 +1529,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -2019,31 +1592,33 @@ package body Ada.Containers.Vectors is Dst : Elements_Access; -- new, expanded internal array begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -2059,7 +1634,7 @@ package body Ada.Containers.Vectors is -- Note: we cannot simply add these values, because of the possibility -- of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -2167,7 +1742,7 @@ package body Ada.Containers.Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -2211,10 +1786,7 @@ package body Ada.Containers.Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- An internal array has already been allocated, so we must determine -- whether there is enough unused storage for the new items. @@ -2360,7 +1932,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -2377,7 +1949,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -2410,22 +1982,11 @@ package body Ada.Containers.Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Iterate; function Iterate @@ -2433,8 +1994,6 @@ package body Ada.Containers.Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- The value of its Index component influences the behavior of the First -- and Last selector functions of the iterator object. When the Index @@ -2451,7 +2010,7 @@ package body Ada.Containers.Vectors is Container => V, Index => No_Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2461,8 +2020,6 @@ package body Ada.Containers.Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -2475,19 +2032,21 @@ package body Ada.Containers.Vectors is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start.Container = null then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; + if Checks then + if Start.Container = null then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; - if Start.Container /= V then - raise Program_Error with - "Start cursor of Iterate designates wrong vector"; - end if; + if Start.Container /= V then + raise Program_Error with + "Start cursor of Iterate designates wrong vector"; + end if; - if Start.Index > V.Last then - raise Constraint_Error with - "Start position for iterator equals No_Element"; + if Start.Index > V.Last then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; end if; -- The value of its Index component influences the behavior of the First @@ -2504,7 +2063,7 @@ package body Ada.Containers.Vectors is Container => V, Index => Start.Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2549,7 +2108,7 @@ package body Ada.Containers.Vectors is function Last_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; else return Container.Elements.EA (Container.Last); @@ -2612,15 +2171,8 @@ package body Ada.Containers.Vectors is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Target is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Source is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); declare Target_Elements : constant Elements_Access := Target.Elements; @@ -2652,7 +2204,7 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + elsif Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; else @@ -2708,7 +2260,7 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + elsif Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; else @@ -2734,15 +2286,10 @@ package body Ada.Containers.Vectors is function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type is - C : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -2755,29 +2302,15 @@ package body Ada.Containers.Vectors is Index : Index_Type; Process : not null access procedure (Element : Element_Type)) is + Lock : With_Lock (Container.TC'Unrestricted_Access); V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (V.Elements.EA (Index)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (V.Elements.EA (Index)); end Query_Element; procedure Query_Element @@ -2785,7 +2318,7 @@ package body Ada.Containers.Vectors is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; else Query_Element (Position.Container.all, Position.Index, Process); @@ -2852,31 +2385,37 @@ package body Ada.Containers.Vectors is Position : Cursor) return Reference_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; - declare - C : Vector renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin + if T_Check then + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Container.Elements.EA (Position.Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + else return R : constant Reference_Type := (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; + Control => (Controlled with null)); + end if; end Reference; function Reference @@ -2884,23 +2423,26 @@ package body Ada.Containers.Vectors is Index : Index_Type) return Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; + end if; - else + if T_Check then declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; + else + return R : constant Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => (Controlled with null)); end if; end Reference; @@ -2914,14 +2456,12 @@ package body Ada.Containers.Vectors is New_Item : Element_Type) is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - else - Container.Elements.EA (Index) := New_Item; end if; + + TE_Check (Container.TC); + Container.Elements.EA (Index) := New_Item; end Replace_Element; procedure Replace_Element @@ -2930,23 +2470,20 @@ package body Ada.Containers.Vectors is New_Item : Element_Type) is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - - elsif Position.Index > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; - else - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; + elsif Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; end if; - - Container.Elements.EA (Position.Index) := New_Item; end if; + + TE_Check (Container.TC); + Container.Elements.EA (Position.Index) := New_Item; end Replace_Element; ---------------------- @@ -3008,10 +2545,7 @@ package body Ada.Containers.Vectors is -- so this is the best we can do with respect to minimizing -- storage). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare subtype Src_Index_Subtype is Index_Type'Base range @@ -3068,7 +2602,9 @@ package body Ada.Containers.Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index + then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3080,7 +2616,7 @@ package body Ada.Containers.Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3092,7 +2628,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (No_Index) + Capacity; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3109,7 +2645,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3148,10 +2684,7 @@ package body Ada.Containers.Vectors is -- new internal array having a length that exactly matches the -- number of items in the container. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare subtype Src_Index_Subtype is Index_Type'Base range @@ -3208,10 +2741,7 @@ package body Ada.Containers.Vectors is -- number of active elements in the container.) We must check whether -- the container is busy before doing anything else. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We now allocate a new internal array, having a length different from -- its current value. @@ -3283,10 +2813,7 @@ package body Ada.Containers.Vectors is -- implementation. Logically Reverse_Elements requires a check for -- cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare K : Index_Type; @@ -3322,7 +2849,7 @@ package body Ada.Containers.Vectors is Last : Index_Type'Base; begin - if Position.Container /= null + if Checks and then Position.Container /= null and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; @@ -3337,38 +2864,15 @@ package body Ada.Containers.Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Cursor'(Container'Unrestricted_Access, Indx); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Reverse_Find; @@ -3381,67 +2885,36 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); Last : constant Index_Type'Base := Index_Type'Min (Container.Last, Index); - Result : Index_Type'Base; - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Reverse_Find_Index; --------------------- -- Reverse_Iterate -- --------------------- - procedure Reverse_Iterate (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Reverse_Iterate; ---------------- @@ -3462,7 +2935,7 @@ package body Ada.Containers.Vectors is if Count >= 0 then Container.Delete_Last (Count); - elsif Container.Last >= Index_Type'Last then + elsif Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -3476,22 +2949,21 @@ package body Ada.Containers.Vectors is procedure Swap (Container : in out Vector; I, J : Index_Type) is begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; + if Checks then + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; end if; if I = J then return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + TE_Check (Container.TC); declare EI_Copy : constant Element_Type := Container.Elements.EA (I); @@ -3503,21 +2975,22 @@ package body Ada.Containers.Vectors is procedure Swap (Container : in out Vector; I, J : Cursor) is begin - if I.Container = null then - raise Constraint_Error with "I cursor has no element"; + if Checks then + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; - elsif J.Container = null then - raise Constraint_Error with "J cursor has no element"; + elsif J.Container = null then + raise Constraint_Error with "J cursor has no element"; - elsif I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; + elsif I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; - elsif J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; - - else - Swap (Container, I.Index, J.Index); + elsif J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; + end if; end if; + + Swap (Container, I.Index, J.Index); end Swap; --------------- @@ -3585,7 +3058,9 @@ package body Ada.Containers.Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -3597,7 +3072,7 @@ package body Ada.Containers.Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -3609,7 +3084,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (No_Index) + Length; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -3626,7 +3101,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -3675,7 +3150,9 @@ package body Ada.Containers.Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -3687,7 +3164,7 @@ package body Ada.Containers.Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -3699,7 +3176,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -3716,7 +3193,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -3741,28 +3218,13 @@ package body Ada.Containers.Vectors is Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (Container.Elements.EA (Index)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Container.Elements.EA (Index)); end Update_Element; procedure Update_Element @@ -3771,13 +3233,15 @@ package body Ada.Containers.Vectors is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - else - Update_Element (Container, Position.Index, Process); + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; end if; + + Update_Element (Container, Position.Index, Process); end Update_Element; ----------- |