From e9f97e793186e04e2a69ef8dc15073b530f2851f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 Oct 2015 11:56:56 +0200 Subject: [PATCH] [multiple changes] 2015-10-20 Bob Duff * a-coinve.ads, a-coinve.adb: Do the same efficiency improvements that were already done in the definite case (Ada.Containers.Vectors, i.e. a-convec). This includes the ability to suppress checks, the fast path for Append, inlining as appropriate, and special-casing of "for ... of" loops. Reuse the tampering machinery that is now in Ada.Containers. Simplify many operations. * a-convec.ads, a-convec.adb: Change the code to be more similar to a-coinve. * a-finali.ads, a-finali.adb: Expose the "null"-ness of the operations. This may enable optimizations in the future, and seems cleaner anyway. 2015-10-20 Ed Schonberg * sem_ch13.adb (Is_Operational_Item): Attributes related to Ada 2012 iterators are operational items, and can be specified on partial views. From-SVN: r229033 --- gcc/ada/ChangeLog | 21 + gcc/ada/a-coinve.adb | 1650 +++++++++++++----------------------------- gcc/ada/a-coinve.ads | 56 +- gcc/ada/a-convec.adb | 26 +- gcc/ada/a-convec.ads | 2 +- gcc/ada/a-finali.adb | 50 +- gcc/ada/a-finali.ads | 12 +- gcc/ada/sem_ch13.adb | 19 +- 8 files changed, 598 insertions(+), 1238 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2da6c0452ff..81f65123110 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2015-10-20 Bob Duff + + * a-coinve.ads, a-coinve.adb: Do the same efficiency + improvements that were already done in the definite case + (Ada.Containers.Vectors, i.e. a-convec). This includes the + ability to suppress checks, the fast path for Append, inlining + as appropriate, and special-casing of "for ... of" loops. Reuse + the tampering machinery that is now in Ada.Containers. Simplify + many operations. + * a-convec.ads, a-convec.adb: Change the code to be more similar + to a-coinve. + * a-finali.ads, a-finali.adb: Expose the "null"-ness of the + operations. This may enable optimizations in the future, and + seems cleaner anyway. + +2015-10-20 Ed Schonberg + + * sem_ch13.adb (Is_Operational_Item): Attributes related to + Ada 2012 iterators are operational items, and can be specified + on partial views. + 2015-10-20 Hristian Kirtchev * sem_prag.adb (Check_Usage): Update the calls to Usage_Error. diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index bb7b2837c50..5cc61b467a9 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,457 +36,66 @@ package body Ada.Containers.Indefinite_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); procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + procedure Append_Slow_Path + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type); + -- This is the slow path for Append. This is split out to minimize the size + -- of Append, because we have Inline (Append). + --------- -- "&" -- --------- - 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 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 : Elements_Access := new Elements_Type (Right.Last); - - begin - -- Elements of an indefinite vector are allocated, so we cannot - -- use simple slice assignment to give a value to our result. - -- Hence we must walk the array of the Right vector, and copy - -- each source element individually. - - for I in Elements.EA'Range loop - begin - if RE (I) /= null then - Elements.EA (I) := new Element_Type'(RE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Right.Last, 0, 0); - end; - end if; - - if RN = 0 then - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - - Elements : Elements_Access := new Elements_Type (Left.Last); - - begin - -- Elements of an indefinite vector are allocated, so we cannot - -- use simple slice assignment to give a value to our result. - -- Hence we must walk the array of the Left vector, and copy - -- each source element individually. - - for I in Elements.EA'Range loop - begin - if LE (I) /= null then - Elements.EA (I) := new Element_Type'(LE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Left.Last, 0, 0); - end; - end if; - - -- Neither of the vector parameters is empty, so we 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. - - 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'Pos (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 : Elements_Access := new Elements_Type (Last); - - I : Index_Type'Base := No_Index; - - begin - -- Elements of an indefinite vector are allocated, so we cannot use - -- simple slice assignment to give a value to our result. Hence we - -- must walk the array of each vector parameter, and copy each source - -- element individually. - - for LI in LE'Range loop - I := I + 1; - - begin - if LE (LI) /= null then - Elements.EA (I) := new Element_Type'(LE (LI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - for RI in RE'Range loop - I := I + 1; - - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Last, 0, 0); - 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 + 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. - - -- Here we handle the easy case first, when the vector parameter (Left) - -- is empty. - - if Left.Is_Empty then - declare - Elements : Elements_Access := new Elements_Type (Index_Type'First); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Right); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First, 0, 0); - 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 : Elements_Access := new Elements_Type (Last); - - begin - for I in LE'Range loop - begin - if LE (I) /= null then - Elements.EA (I) := new Element_Type'(LE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - begin - Elements.EA (Last) := new Element_Type'(Right); - - exception - when others => - for J in Index_Type'First .. Last - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last, 0, 0); - 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 + 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. - - -- Here we handle the easy case first, when the vector parameter (Right) - -- is empty. - - if Right.Is_Empty then - declare - Elements : Elements_Access := new Elements_Type (Index_Type'First); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First, 0, 0); - 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 : Elements_Access := new Elements_Type (Last); - - I : Index_Type'Base := Index_Type'First; - - begin - begin - Elements.EA (I) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - for RI in RE'Range loop - I := I + 1; - - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Last, 0, 0); - 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 : Elements_Access := new Elements_Type (Last); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - begin - Elements.EA (Last) := new Element_Type'(Right); - exception - when others => - Free (Elements.EA (Index_Type'First)); - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last, 0, 0); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; --------- @@ -494,67 +103,31 @@ package body Ada.Containers.Indefinite_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; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); 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'First .. Left.Last loop + for J in Index_Type range Index_Type'First .. Left.Last loop if Left.Elements.EA (J) = null then if Right.Elements.EA (J) /= null then - Result := False; - exit; + return False; end if; elsif Right.Elements.EA (J) = null then - Result := False; - exit; + return False; elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then - Result := False; - exit; + return False; 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; + return True; end "="; ------------ @@ -576,8 +149,7 @@ package body Ada.Containers.Indefinite_Vectors is begin Container.Elements := null; Container.Last := No_Index; - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); Container.Elements := new Elements_Type (L); @@ -591,20 +163,6 @@ package body Ada.Containers.Indefinite_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 -- ------------ @@ -613,7 +171,7 @@ package body Ada.Containers.Indefinite_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); @@ -625,15 +183,57 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Element_Type; Count : Count_Type := 1) is + begin + -- In the general case, we pass the buck to Insert, but for efficiency, + -- we check for the usual case where Count = 1 and the vector has enough + -- room for at least one more element. + + if Count = 1 + and then Container.Elements /= null + and then Container.Last /= Container.Elements.Last + then + TC_Check (Container.TC); + + -- Increment Container.Last after assigning the New_Item, so we + -- leave the Container unmodified in case Finalize/Adjust raises + -- an exception. + + declare + New_Last : constant Index_Type := Container.Last + 1; + + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin + Container.Elements.EA (New_Last) := new Element_Type'(New_Item); + Container.Last := New_Last; + end; + + else + Append_Slow_Path (Container, New_Item, Count); + end if; + end Append; + + ---------------------- + -- Append_Slow_Path -- + ---------------------- + + procedure Append_Slow_Path + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + 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); end if; - end Append; + end Append_Slow_Path; ------------ -- Assign -- @@ -668,21 +268,17 @@ package body Ada.Containers.Indefinite_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)"; + TC_Check (Container.TC); - else - while Container.Last >= Index_Type'First loop - declare - X : Element_Access := Container.Elements.EA (Container.Last); - begin - Container.Elements.EA (Container.Last) := null; - Container.Last := Container.Last - 1; - Free (X); - end; - end loop; - end if; + while Container.Last >= Index_Type'First loop + declare + X : Element_Access := Container.Elements.EA (Container.Last); + begin + Container.Elements.EA (Container.Last) := null; + Container.Last := Container.Last - 1; + Free (X); + end; + end loop; end Clear; ------------------------ @@ -693,72 +289,70 @@ package body Ada.Containers.Indefinite_Vectors is (Container : aliased Vector; Position : Cursor) return Constant_Reference_Type is - E : Element_Access; - begin - 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.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - E := Container.Elements.EA (Position.Index); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if E = null then - raise Constraint_Error with "element at Position is empty"; + 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 Container'Unrestricted_Access.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 + -- The following will raise Constraint_Error if Element is null + + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Position.Index), + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + else return R : constant Constant_Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; + (Element => Container.Elements.EA (Position.Index), + Control => (Controlled with null)); + end if; end Constant_Reference; function Constant_Reference (Container : aliased Vector; Index : Index_Type) return Constant_Reference_Type is - E : Element_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; - E := Container.Elements.EA (Index); - - if E = null then - raise Constraint_Error with "element at Index is empty"; - end if; - - declare - C : Vector renames Container'Unrestricted_Access.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 + -- The following will raise Constraint_Error if Element is null + + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Index), + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + else return R : constant Constant_Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; + (Element => Container.Elements.EA (Index), + Control => (Controlled with null)); + end if; end Constant_Reference; -------------- @@ -790,9 +384,9 @@ package body Ada.Containers.Indefinite_Vectors is elsif Capacity >= Source.Length then C := Capacity; - else - raise Capacity_Error - with "Requested capacity is less than Source length"; + elsif Checks then + raise Capacity_Error with + "Requested capacity is less than Source length"; end if; return Target : Vector do @@ -833,7 +427,7 @@ package body Ada.Containers.Indefinite_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; @@ -845,7 +439,7 @@ package body Ada.Containers.Indefinite_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; @@ -874,10 +468,7 @@ package body Ada.Containers.Indefinite_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 @@ -886,7 +477,6 @@ package body Ada.Containers.Indefinite_Vectors is if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else Count2 := Count_Type'Base (Old_Last - Index + 1); end if; @@ -938,7 +528,7 @@ package body Ada.Containers.Indefinite_Vectors is -- index value New_Last is the last index value of their new home, and -- index value J is the first index of their old home. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then New_Last := Old_Last - Index_Type'Base (Count); J := Index + Index_Type'Base (Count); else @@ -988,22 +578,21 @@ package body Ada.Containers.Indefinite_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; ------------------ @@ -1062,10 +651,7 @@ package body Ada.Containers.Indefinite_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); -- Elements in an indefinite vector are allocated, so we must iterate -- over the loop and deallocate elements one-at-a-time. We work from @@ -1108,14 +694,14 @@ package body Ada.Containers.Indefinite_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"; end if; declare EA : constant Element_Access := Container.Elements.EA (Index); begin - if EA = null then + if Checks and then EA = null then raise Constraint_Error with "element is empty"; else return EA.all; @@ -1125,19 +711,21 @@ package body Ada.Containers.Indefinite_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"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + 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 EA : constant Element_Access := Position.Container.Elements.EA (Position.Index); begin - if EA = null then + if Checks and then EA = null then raise Constraint_Error with "element is empty"; else return EA.all; @@ -1162,25 +750,9 @@ package body Ada.Containers.Indefinite_Vectors is 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; ---------- @@ -1193,7 +765,7 @@ package body Ada.Containers.Indefinite_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; @@ -1207,39 +779,15 @@ package body Ada.Containers.Indefinite_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) /= null - and then Container.Elements.EA (J).all = Item - then - Result := J; - exit; + if Container.Elements.EA (J).all = Item then + 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; @@ -1252,39 +800,18 @@ package body Ada.Containers.Indefinite_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) /= null - and then Container.Elements.EA (Indx).all = Item - then - Result := Indx; - exit; + if Container.Elements.EA (Indx).all = Item then + 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; ----------- @@ -1329,7 +856,7 @@ package body Ada.Containers.Indefinite_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"; end if; @@ -1337,7 +864,7 @@ package body Ada.Containers.Indefinite_Vectors is EA : constant Element_Access := Container.Elements.EA (Index_Type'First); begin - if EA = null then + if Checks and then EA = null then raise Constraint_Error with "first element is empty"; else return EA.all; @@ -1397,36 +924,16 @@ package body Ada.Containers.Indefinite_Vectors is -- element tampering by a generic actual subprogram. declare + Lock : With_Lock (Container.TC'Unrestricted_Access); E : Elements_Array renames Container.Elements.EA; - - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Boolean; - begin - B := B + 1; - L := L + 1; - - Result := True; - for I in Index_Type'First .. Container.Last - 1 loop - if Is_Less (E (I + 1), E (I)) then - Result := False; - exit; + for J in Index_Type'First .. Container.Last - 1 loop + if Is_Less (E (J + 1), E (J)) then + 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; @@ -1450,7 +957,7 @@ package body Ada.Containers.Indefinite_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; @@ -1460,10 +967,7 @@ package body Ada.Containers.Indefinite_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); I := Target.Last; -- original value (before Set_Length) Target.Set_Length (Length (Target) + Length (Source)); @@ -1475,19 +979,9 @@ package body Ada.Containers.Indefinite_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; -- new value (after Set_Length) while Source.Last >= Index_Type'First loop pragma Assert @@ -1531,22 +1025,6 @@ package body Ada.Containers.Indefinite_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; @@ -1579,38 +1057,30 @@ package body Ada.Containers.Indefinite_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; end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements.EA (Position.Index); + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1648,33 +1118,33 @@ package body Ada.Containers.Indefinite_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.) - - if Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; + -- 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)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -1687,10 +1157,10 @@ package body Ada.Containers.Indefinite_Vectors is -- 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 current length and the insertion count. - -- Note that we cannot simply add these values, because of the - -- possibility of overflow. + -- 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; @@ -1705,7 +1175,7 @@ package body Ada.Containers.Indefinite_Vectors is -- compare the new length to the maximum length. If the new length is -- acceptable, then we compute the new last index from that. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then -- We have to handle the case when there might be more values in the -- range of Index_Type than in the range of Count_Type. @@ -1740,9 +1210,7 @@ package body Ada.Containers.Indefinite_Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - if Index_Type'Last - No_Index >= - Count_Type'Pos (Count_Type'Last) - then + if Index_Type'Last - No_Index >= Count_Type_Last then -- We have determined that range of Index_Type has at least as -- many values as in Count_Type, so Count_Type'Last is the -- maximum number of items that are allowed. @@ -1799,7 +1267,7 @@ package body Ada.Containers.Indefinite_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; @@ -1807,7 +1275,7 @@ package body Ada.Containers.Indefinite_Vectors is -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to -- compute its value from the New_Length. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then New_Last := No_Index + Index_Type'Base (New_Length); else New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); @@ -1863,10 +1331,7 @@ package body Ada.Containers.Indefinite_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); if New_Length <= Container.Elements.EA'Length then @@ -1916,7 +1381,7 @@ package body Ada.Containers.Indefinite_Vectors is -- new home. We use the wider of Index_Type'Base and -- Count_Type'Base as the type for intermediate index values. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Index := Before + Index_Type'Base (Count); else Index := Index_Type'Base (Count_Type'Base (Before) + Count); @@ -2002,7 +1467,7 @@ package body Ada.Containers.Indefinite_Vectors is -- We have computed the length of the new internal array (and this is -- what "vector capacity" means), so use that to compute its last index. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Dst_Last := No_Index + Index_Type'Base (New_Capacity); else Dst_Last := @@ -2069,7 +1534,7 @@ package body Ada.Containers.Indefinite_Vectors is -- The new items are being inserted before some existing elements, -- so we must slide the existing elements up to their new home. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Index := Before + Index_Type'Base (Count); else Index := Index_Type'Base (Count_Type'Base (Before) + Count); @@ -2219,7 +1684,7 @@ package body Ada.Containers.Indefinite_Vectors is -- after copying the first slice of the source, and determining that -- this second slice of the source is empty. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then J := Before + Index_Type'Base (N); else J := Index_Type'Base (Count_Type'Base (Before) + N); @@ -2242,7 +1707,7 @@ package body Ada.Containers.Indefinite_Vectors is -- destination that receives this slice of the source. (For the -- reasons given above, this slice is guaranteed to be non-empty.) - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Dst_Index := J - Index_Type'Base (Src'Length); else Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); @@ -2266,7 +1731,7 @@ package body Ada.Containers.Indefinite_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"; @@ -2277,7 +1742,7 @@ package body Ada.Containers.Indefinite_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; @@ -2300,9 +1765,8 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null - and then Before.Container /= - Vector_Access'(Container'Unrestricted_Access) + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2318,7 +1782,7 @@ package body Ada.Containers.Indefinite_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; @@ -2331,7 +1795,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert (Container, Index, New_Item); - Position := Cursor'(Container'Unrestricted_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -2343,7 +1807,7 @@ package body Ada.Containers.Indefinite_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"; @@ -2354,7 +1818,7 @@ package body Ada.Containers.Indefinite_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; @@ -2378,16 +1842,14 @@ package body Ada.Containers.Indefinite_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"; end if; if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unrestricted_Access, Before.Index); @@ -2397,7 +1859,7 @@ package body Ada.Containers.Indefinite_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; @@ -2436,31 +1898,33 @@ package body Ada.Containers.Indefinite_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.) - - if Before > Container.Last and then Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; + -- 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)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -2472,11 +1936,11 @@ package body Ada.Containers.Indefinite_Vectors is -- 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 current length and the insertion - -- count. Note that we cannot simply add these values, because of the - -- possibility of overflow. + -- we must check the sum of the current length and the insertion count. + -- 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; @@ -2491,7 +1955,7 @@ package body Ada.Containers.Indefinite_Vectors is -- compare the new length to the maximum length. If the new length is -- acceptable, then we compute the new last index from that. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then -- We have to handle the case when there might be more values in the -- range of Index_Type than in the range of Count_Type. @@ -2525,9 +1989,7 @@ package body Ada.Containers.Indefinite_Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - if Index_Type'Last - No_Index >= - Count_Type'Pos (Count_Type'Last) - then + if Index_Type'Last - No_Index >= Count_Type_Last then -- We have determined that range of Index_Type has at least as -- many values as in Count_Type, so Count_Type'Last is the -- maximum number of items that are allowed. @@ -2584,7 +2046,7 @@ package body Ada.Containers.Indefinite_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; @@ -2592,7 +2054,7 @@ package body Ada.Containers.Indefinite_Vectors is -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to -- compute its value from the New_Length. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then New_Last := No_Index + Index_Type'Base (New_Length); else New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); @@ -2624,10 +2086,7 @@ package body Ada.Containers.Indefinite_Vectors is -- 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); if New_Length <= Container.Elements.EA'Length then @@ -2646,7 +2105,7 @@ package body Ada.Containers.Indefinite_Vectors is -- their new home. We use the wider of Index_Type'Base and -- Count_Type'Base as the type for intermediate index values. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Index := Before + Index_Type'Base (Count); else Index := Index_Type'Base (Count_Type'Base (Before) + Count); @@ -2692,7 +2151,7 @@ package body Ada.Containers.Indefinite_Vectors is -- We have computed the length of the new internal array (and this is -- what "vector capacity" means), so use that to compute its last index. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Dst_Last := No_Index + Index_Type'Base (New_Capacity); else Dst_Last := @@ -2722,7 +2181,7 @@ package body Ada.Containers.Indefinite_Vectors is -- The new items are being inserted before some existing elements, -- so we must slide the existing elements up to their new home. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Index := Before + Index_Type'Base (Count); else Index := Index_Type'Base (Count_Type'Base (Before) + Count); @@ -2750,7 +2209,7 @@ package body Ada.Containers.Indefinite_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"; @@ -2766,10 +2225,8 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then + if Before.Container = null or else Before.Index > Container.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; @@ -2782,7 +2239,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert_Space (Container, Index, Count); - Position := Cursor'(Container'Unrestricted_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert_Space; -------------- @@ -2802,30 +2259,18 @@ package body Ada.Containers.Indefinite_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 (Container : Vector) + function Iterate + (Container : Vector) 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 @@ -2842,7 +2287,7 @@ package body Ada.Containers.Indefinite_Vectors is Container => V, Index => No_Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2852,8 +2297,6 @@ package body Ada.Containers.Indefinite_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, @@ -2866,19 +2309,21 @@ package body Ada.Containers.Indefinite_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 @@ -2895,7 +2340,7 @@ package body Ada.Containers.Indefinite_Vectors is Container => V, Index => Start.Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2934,13 +2379,13 @@ package body Ada.Containers.Indefinite_Vectors is end if; end Last; - ----------------- + ------------------ -- Last_Element -- ------------------ 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"; end if; @@ -2948,7 +2393,7 @@ package body Ada.Containers.Indefinite_Vectors is EA : constant Element_Access := Container.Elements.EA (Container.Last); begin - if EA = null then + if Checks and then EA = null then raise Constraint_Error with "last element is empty"; else return EA.all; @@ -3012,10 +2457,7 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Source is busy)"; - end if; + TC_Check (Source.TC); Clear (Target); -- Checks busy-bit @@ -3049,7 +2491,7 @@ package body Ada.Containers.Indefinite_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 @@ -3090,17 +2532,6 @@ package body Ada.Containers.Indefinite_Vectors is -- Previous -- -------------- - procedure Previous (Position : in out Cursor) is - begin - if Position.Container = null then - return; - elsif Position.Index > Index_Type'First then - Position.Index := Position.Index - 1; - else - Position := No_Element; - end if; - end Previous; - function Previous (Position : Cursor) return Cursor is begin if Position.Container = null then @@ -3116,7 +2547,7 @@ package body Ada.Containers.Indefinite_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 @@ -3124,6 +2555,31 @@ package body Ada.Containers.Indefinite_Vectors is end if; end Previous; + procedure Previous (Position : in out Cursor) is + begin + if Position.Container = null then + return; + elsif Position.Index > Index_Type'First then + Position.Index := Position.Index - 1; + else + Position := No_Element; + end if; + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -3133,33 +2589,19 @@ package body Ada.Containers.Indefinite_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; - if V.Elements.EA (Index) = null then + if Checks and then V.Elements.EA (Index) = null then raise Constraint_Error with "element is null"; end if; - B := B + 1; - L := L + 1; - - begin - Process (V.Elements.EA (Index).all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (V.Elements.EA (Index).all); end Query_Element; procedure Query_Element @@ -3167,7 +2609,7 @@ package body Ada.Containers.Indefinite_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); @@ -3241,72 +2683,70 @@ package body Ada.Containers.Indefinite_Vectors is (Container : aliased in out Vector; Position : Cursor) return Reference_Type is - E : Element_Access; - begin - 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.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - E := Container.Elements.EA (Position.Index); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if E = null then - raise Constraint_Error with "element at Position is empty"; + 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 Container'Unrestricted_Access.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 + -- The following will raise Constraint_Error if Element is null + + return R : constant Reference_Type := + (Element => Container.Elements.EA (Position.Index), + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + else return R : constant Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; + (Element => Container.Elements.EA (Position.Index), + Control => (Controlled with null)); + end if; end Reference; function Reference (Container : aliased in out Vector; Index : Index_Type) return Reference_Type is - E : Element_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; - E := Container.Elements.EA (Index); - - if E = null then - raise Constraint_Error with "element at Index is empty"; - end if; - - declare - C : Vector renames Container'Unrestricted_Access.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 + -- The following will raise Constraint_Error if Element is null + + return R : constant Reference_Type := + (Element => Container.Elements.EA (Index), + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + else return R : constant Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; + (Element => Container.Elements.EA (Index), + Control => (Controlled with null)); + end if; end Reference; --------------------- @@ -3319,14 +2759,11 @@ package body Ada.Containers.Indefinite_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"; 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 X : Element_Access := Container.Elements.EA (Index); @@ -3349,22 +2786,21 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Element_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 > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; 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 X : Element_Access := Container.Elements.EA (Position.Index); @@ -3442,10 +2878,7 @@ package body Ada.Containers.Indefinite_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 Array_Index_Subtype is Index_Type'Base range @@ -3485,7 +2918,7 @@ package body Ada.Containers.Indefinite_Vectors is -- the Last index value of the new internal array, in a way that avoids -- any possibility of overflow. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + 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 @@ -3498,7 +2931,9 @@ package body Ada.Containers.Indefinite_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; @@ -3510,7 +2945,7 @@ package body Ada.Containers.Indefinite_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; @@ -3522,7 +2957,7 @@ package body Ada.Containers.Indefinite_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; @@ -3539,7 +2974,7 @@ package body Ada.Containers.Indefinite_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; @@ -3578,10 +3013,7 @@ package body Ada.Containers.Indefinite_Vectors is -- 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 Array_Index_Subtype is Index_Type'Base range @@ -3634,10 +3066,7 @@ package body Ada.Containers.Indefinite_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. @@ -3689,10 +3118,7 @@ package body Ada.Containers.Indefinite_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 I : Index_Type; @@ -3729,55 +3155,32 @@ package body Ada.Containers.Indefinite_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"; end if; - if Position.Container = null or else Position.Index > Container.Last then - Last := Container.Last; - else - Last := Position.Index; - end if; + Last := + (if Position.Container = null or else Position.Index > Container.Last + then Container.Last + else Position.Index); -- Per AI05-0022, the container implementation is required to detect -- 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) /= null and then Container.Elements.EA (Indx).all = 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; @@ -3790,41 +3193,24 @@ package body Ada.Containers.Indefinite_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; - - Last : constant Index_Type'Base := - (if Index > Container.Last then Container.Last else 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; + Lock : With_Lock (Container.TC'Unrestricted_Access); + + Last : constant Index_Type'Base := + Index_Type'Min (Container.Last, Index); - Result := No_Index; + begin for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = 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; --------------------- @@ -3835,33 +3221,18 @@ package body Ada.Containers.Indefinite_Vectors is (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; ---------------- -- Set_Length -- ---------------- - procedure Set_Length - (Container : in out Vector; - Length : Count_Type) - is + procedure Set_Length (Container : in out Vector; Length : Count_Type) is Count : constant Count_Type'Base := Container.Length - Length; begin @@ -3875,7 +3246,7 @@ package body Ada.Containers.Indefinite_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 @@ -3887,27 +3258,23 @@ package body Ada.Containers.Indefinite_Vectors is -- Swap -- ---------- - procedure Swap - (Container : in out Vector; - I, J : Index_Type) - 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 : Element_Access renames Container.Elements.EA (I); @@ -3926,20 +3293,22 @@ package body Ada.Containers.Indefinite_Vectors is I, J : Cursor) is begin - if I.Container = null then - raise Constraint_Error with "I cursor has no element"; - end if; + if Checks then + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; + end if; - if J.Container = null then - raise Constraint_Error with "J cursor has no element"; - end if; + if J.Container = null then + raise Constraint_Error with "J cursor has no element"; + end if; - if I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; - end if; + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; + end if; - if J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; + if 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); @@ -3997,7 +3366,7 @@ package body Ada.Containers.Indefinite_Vectors is -- index). We must therefore check whether the specified Length would -- create a Last index value greater than Index_Type'Last. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + 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 @@ -4010,7 +3379,9 @@ package body Ada.Containers.Indefinite_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; @@ -4022,7 +3393,7 @@ package body Ada.Containers.Indefinite_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; @@ -4034,7 +3405,7 @@ package body Ada.Containers.Indefinite_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; @@ -4051,7 +3422,7 @@ package body Ada.Containers.Indefinite_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; @@ -4064,7 +3435,7 @@ package body Ada.Containers.Indefinite_Vectors is Elements := new Elements_Type (Last); - return Vector'(Controlled with Elements, Last, 0, 0); + return Vector'(Controlled with Elements, Last, TC => <>); end To_Vector; function To_Vector @@ -4087,7 +3458,7 @@ package body Ada.Containers.Indefinite_Vectors is -- index). We must therefore check whether the specified Length would -- create a Last index value greater than Index_Type'Last. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + 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 @@ -4100,7 +3471,9 @@ package body Ada.Containers.Indefinite_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; @@ -4112,7 +3485,7 @@ package body Ada.Containers.Indefinite_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; @@ -4124,7 +3497,7 @@ package body Ada.Containers.Indefinite_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; @@ -4141,7 +3514,7 @@ package body Ada.Containers.Indefinite_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; @@ -4191,7 +3564,7 @@ package body Ada.Containers.Indefinite_Vectors is raise; end; - return (Controlled with Elements, Last, 0, 0); + return (Controlled with Elements, Last, TC => <>); end To_Vector; -------------------- @@ -4203,32 +3576,17 @@ package body Ada.Containers.Indefinite_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; - if Container.Elements.EA (Index) = null then + if Checks and then Container.Elements.EA (Index) = null then raise Constraint_Error with "element is null"; end if; - B := B + 1; - L := L + 1; - - begin - Process (Container.Elements.EA (Index).all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Container.Elements.EA (Index).all); end Update_Element; procedure Update_Element @@ -4237,15 +3595,15 @@ package body Ada.Containers.Indefinite_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; ----------- diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index d2f7252e560..978b49a455a 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -343,6 +343,7 @@ package Ada.Containers.Indefinite_Vectors is private + pragma Inline (Append); pragma Inline (First_Index); pragma Inline (Last_Index); pragma Inline (Element); @@ -351,35 +352,37 @@ private pragma Inline (Query_Element); pragma Inline (Update_Element); pragma Inline (Replace_Element); + pragma Inline (Is_Empty); pragma Inline (Contains); pragma Inline (Next); pragma Inline (Previous); + package Implementation is new Generic_Implementation; + use Implementation; + type Element_Access is access Element_Type; type Elements_Array is array (Index_Type range <>) of Element_Access; function "=" (L, R : Elements_Array) return Boolean is abstract; - type Elements_Type (Last : Index_Type) is limited record + type Elements_Type (Last : Extended_Index) is limited record EA : Elements_Array (Index_Type'First .. Last); end record; - type Elements_Access is access Elements_Type; + type Elements_Access is access all Elements_Type; + + use Finalization; + use Streams; - type Vector is new Ada.Finalization.Controlled with record - Elements : Elements_Access; + type Vector is new Controlled with record + Elements : Elements_Access := null; Last : Extended_Index := No_Index; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; overriding procedure Adjust (Container : in out Vector); - overriding procedure Finalize (Container : in out Vector); - use Ada.Finalization; - use Ada.Streams; - procedure Write (Stream : not null access Root_Stream_Type'Class; Container : Vector); @@ -412,16 +415,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : Vector_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -467,16 +462,33 @@ private for Reference_Type'Read use Read; - Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. No_Element : constant Cursor := Cursor'(null, Index_Type'First); + Empty_Vector : constant Vector := (Controlled with others => <>); + type Iterator is new Limited_Controlled and Vector_Iterator_Interfaces.Reversible_Iterator with record Container : Vector_Access; Index : Index_Type'Base; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index a3d7464e941..404d1f59598 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -450,9 +450,9 @@ package body Ada.Containers.Vectors is return; end if; - -- There are some elements aren't being deleted (the requested count was - -- less than the available count), so we must slide them down to - -- Index. We first calculate the index values of the respective array + -- There are some elements that aren't being deleted (the requested + -- count was less than the available count), so we must slide them down + -- to Index. We first calculate the index values of the respective array -- slices, using the wider of Index_Type'Base and Count_Type'Base as the -- type for intermediate calculations. For the elements that slide down, -- index value New_Last is the last index value of their new home, and @@ -583,9 +583,9 @@ package body Ada.Containers.Vectors is begin if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - else - return Container.Elements.EA (Index); end if; + + return Container.Elements.EA (Index); end Element; function Element (Position : Cursor) return Element_Type is @@ -692,9 +692,9 @@ package body Ada.Containers.Vectors is begin if Is_Empty (Container) then return No_Element; - else - return (Container'Unrestricted_Access, Index_Type'First); end if; + + return (Container'Unrestricted_Access, Index_Type'First); end First; function First (Object : Iterator) return Cursor is @@ -1030,7 +1030,6 @@ package body Ada.Containers.Vectors is -- handled above). if Index_Type'Last - No_Index >= Count_Type_Last then - -- We have determined that range of Index_Type has at least as -- many values as in Count_Type, so Count_Type'Last is the -- maximum number of items that are allowed. @@ -1655,7 +1654,6 @@ package body Ada.Containers.Vectors is -- acceptable, then we compute the new last index from that. if Index_Type'Base'Last >= Count_Type_Last then - -- We have to handle the case when there might be more values in the -- range of Index_Type than in the range of Count_Type. @@ -1690,7 +1688,6 @@ package body Ada.Containers.Vectors is -- handled above). if Index_Type'Last - No_Index >= Count_Type_Last then - -- We have determined that range of Index_Type has at least as -- many values as in Count_Type, so Count_Type'Last is the -- maximum number of items that are allowed. @@ -1965,7 +1962,7 @@ package body Ada.Containers.Vectors is Index := Before.Index; end if; - Insert_Space (Container, Index, Count => Count); + Insert_Space (Container, Index, Count); Position := (Container'Unrestricted_Access, Index); end Insert_Space; @@ -2022,7 +2019,7 @@ package body Ada.Containers.Vectors is function Iterate (Container : Vector; Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'class + return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; begin @@ -2911,6 +2908,7 @@ package body Ada.Containers.Vectors is --------------------- -- Reverse_Iterate -- --------------------- + procedure Reverse_Iterate (Container : Vector; Process : not null access procedure (Position : Cursor)) @@ -3119,7 +3117,7 @@ package body Ada.Containers.Vectors is Elements := new Elements_Type (Last); - return Vector'(Controlled with Elements, Last, others => <>); + return Vector'(Controlled with Elements, Last, TC => <>); end To_Vector; function To_Vector @@ -3211,7 +3209,7 @@ package body Ada.Containers.Vectors is Elements := new Elements_Type'(Last, EA => (others => New_Item)); - return Vector'(Controlled with Elements, Last, others => <>); + return (Controlled with Elements, Last, TC => <>); end To_Vector; -------------------- diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 0356431772a..f19af2e0311 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -487,7 +487,7 @@ private (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - No_Element : constant Cursor := Cursor'(null, Index_Type'First); + No_Element : constant Cursor := Cursor'(null, Index_Type'First); Empty_Vector : constant Vector := (Controlled with others => <>); diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb index dc2cdf78891..3d6e45bcf6d 100644 --- a/gcc/ada/a-finali.adb +++ b/gcc/ada/a-finali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,48 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body Ada.Finalization is +-- This package does not require a body. We provide a dummy file containing a +-- No_Body pragma so that previous versions of the body (which did exist) will +-- not interfere. - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Adjust; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Finalize; - - procedure Finalize (Object : in out Limited_Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Initialize; - - procedure Initialize (Object : in out Limited_Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Initialize; - -end Ada.Finalization; +pragma No_Body; diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads index b65f6eabac7..a1f420efc91 100644 --- a/gcc/ada/a-finali.ads +++ b/gcc/ada/a-finali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -43,15 +43,15 @@ package Ada.Finalization is type Controlled is abstract tagged private; pragma Preelaborable_Initialization (Controlled); - procedure Initialize (Object : in out Controlled); - procedure Adjust (Object : in out Controlled); - procedure Finalize (Object : in out Controlled); + procedure Initialize (Object : in out Controlled) is null; + procedure Adjust (Object : in out Controlled) is null; + procedure Finalize (Object : in out Controlled) is null; type Limited_Controlled is abstract tagged limited private; pragma Preelaborable_Initialization (Limited_Controlled); - procedure Initialize (Object : in out Limited_Controlled); - procedure Finalize (Object : in out Limited_Controlled); + procedure Initialize (Object : in out Limited_Controlled) is null; + procedure Finalize (Object : in out Limited_Controlled) is null; private package SFR renames System.Finalization_Root; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 59c6e949d30..7ef0c10aae6 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2036,8 +2036,8 @@ package body Sem_Ch13 is Analyze_And_Resolve (Expr, Standard_Integer); -- Interrupt_Priority aspect not allowed for main - -- subprograms. ARM D.1 does not forbid this explicitly, - -- but ARM J.15.11 (6/3) does not permit pragma + -- subprograms. RM D.1 does not forbid this explicitly, + -- but RM J.15.11(6/3) does not permit pragma -- Interrupt_Priority for subprograms. if A_Id = Aspect_Interrupt_Priority then @@ -2060,7 +2060,7 @@ package body Sem_Ch13 is (Specification (N))) or else not Is_Compilation_Unit (Defining_Entity (N)) then - -- See ARM D.1 (14/3) and D.16 (12/3) + -- See RM D.1(14/3) and D.16(12/3) Error_Msg_N ("aspect applied to subprogram other than the " @@ -11419,9 +11419,20 @@ package body Sem_Ch13 is declare Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); begin - return Id = Attribute_Input + + -- List of operational items is given in RM 13.1(8.mm/1). + -- It is clearly incomplete, as it does not include iterator + -- aspects, among others. + + return Id = Attribute_Constant_Indexing + or else Id = Attribute_Default_Iterator + or else Id = Attribute_Implicit_Dereference + or else Id = Attribute_Input + or else Id = Attribute_Iterator_Element + or else Id = Attribute_Iterable or else Id = Attribute_Output or else Id = Attribute_Read + or else Id = Attribute_Variable_Indexing or else Id = Attribute_Write or else Id = Attribute_External_Tag; end; -- 2.30.2