[Ada] Check suppression in Ada.Containers

Message ID	20151016130813.GA131102@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-return-410374-incoming=patchwork.ozlabs.org@gcc.gnu.org> DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=bj8IDxmAe/Ov0M0oAH6CJ3oYNo2qUq/nl/euY1MH6UjMpUrHUl vdumItgpVWHZCiGCPa9j+vkBTH+AQ+IvMcPSVsxQLPVfbKUMzgxSZCHsY2B1gkbH pVx5v/rq9tLwxKA2s8W03+hvngdHSzv1aSW4TxiASsEMCx2npBbd3E3gA= Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk Sender: gcc-patches-owner@gcc.gnu.org Date: Fri, 16 Oct 2015 09:08:13 -0400 From: Arnaud Charlet <charlet@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Bob Duff <duff@adacore.com> Subject: [Ada] Check suppression in Ada.Containers Message-ID: <20151016130813.GA131102@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="a8Wt8u1KmwUX3Y2C" Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12)

Index: a-contai.adb =================================================================== --- a-contai.adb (revision 0) +++ a-contai.adb (revision 0) @@ -0,0 +1,189 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +------------------------------------------------------------------------------ + +package body Ada.Containers is + + package body Generic_Implementation is + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + pragma Assert (T_Check); -- not called if check suppressed + begin + if Control.T_Counts /= null then + Lock (Control.T_Counts.all); + end if; + end Adjust; + + ---------- + -- Busy -- + ---------- + + procedure Busy (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + declare + B : Natural renames T_Counts.Busy; + begin + B := B + 1; + end; + end if; + end Busy; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + pragma Assert (T_Check); -- not called if check suppressed + begin + if Control.T_Counts /= null then + Unlock (Control.T_Counts.all); + Control.T_Counts := null; + end if; + end Finalize; + + -- No need to protect against double Finalize here, because these types + -- are limited. + + procedure Finalize (Busy : in out With_Busy) is + pragma Assert (T_Check); -- not called if check suppressed + begin + Unbusy (Busy.T_Counts.all); + end Finalize; + + procedure Finalize (Lock : in out With_Lock) is + pragma Assert (T_Check); -- not called if check suppressed + begin + Unlock (Lock.T_Counts.all); + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Busy : in out With_Busy) is + pragma Assert (T_Check); -- not called if check suppressed + begin + Generic_Implementation.Busy (Busy.T_Counts.all); + end Initialize; + + procedure Initialize (Lock : in out With_Lock) is + pragma Assert (T_Check); -- not called if check suppressed + begin + Generic_Implementation.Lock (Lock.T_Counts.all); + end Initialize; + + ---------- + -- Lock -- + ---------- + + procedure Lock (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + declare + B : Natural renames T_Counts.Busy; + L : Natural renames T_Counts.Lock; + begin + L := L + 1; + B := B + 1; + end; + end if; + end Lock; + + -------------- + -- TC_Check -- + -------------- + + procedure TC_Check (T_Counts : Tamper_Counts) is + begin + if T_Check and then T_Counts.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors"; + end if; + end TC_Check; + + -------------- + -- TE_Check -- + -------------- + + procedure TE_Check (T_Counts : Tamper_Counts) is + begin + if T_Check and then T_Counts.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements"; + end if; + end TE_Check; + + ------------ + -- Unbusy -- + ------------ + + procedure Unbusy (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + declare + B : Natural renames T_Counts.Busy; + begin + B := B - 1; + end; + end if; + end Unbusy; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + declare + B : Natural renames T_Counts.Busy; + L : Natural renames T_Counts.Lock; + begin + L := L - 1; + B := B - 1; + end; + end if; + end Unlock; + + ----------------- + -- Zero_Counts -- + ----------------- + + procedure Zero_Counts (T_Counts : out Tamper_Counts) is + begin + if T_Check then + T_Counts := (others => <>); + end if; + end Zero_Counts; + + end Generic_Implementation; + +end Ada.Containers; Index: a-contai.ads =================================================================== --- a-contai.ads (revision 228884) +++ a-contai.ads (working copy) @@ -13,6 +13,17 @@ -- -- ------------------------------------------------------------------------------ +pragma Check_Name (Container_Checks); +pragma Check_Name (Tampering_Check); +-- The above checks are not in the Ada RM. They are added in order to allow +-- suppression of checks within containers packages. Suppressing +-- Tampering_Check suppresses the tampering checks and associated machinery, +-- which is very expensive. Suppressing Container_Checks suppresses +-- Tampering_Check as well as all the other (not-so-expensive) containers +-- checks. + +private with Ada.Finalization; + package Ada.Containers is pragma Pure; @@ -21,4 +32,123 @@ Capacity_Error : exception; +private + + type Tamper_Counts is record + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + -- Busy is positive when tampering with cursors is prohibited. Busy and + -- Lock are both positive when tampering with elements is prohibited. + + type Tamper_Counts_Access is access all Tamper_Counts; + for Tamper_Counts_Access'Storage_Size use 0; + + generic + package Generic_Implementation is + + -- Generic package used in the implementation of containers. + -- ???Currently used by Vectors; not yet by all other containers. + + -- This needs to be generic so that the 'Enabled attribute will return + -- the value that is relevant at the point where a container generic is + -- instantiated. For example: + -- + -- pragma Suppress (Container_Checks); + -- package My_Vectors is new Ada.Containers.Vectors (...); + -- + -- should suppress all container-related checks within the instance + -- My_Vectors. + + -- Shorthands for "checks enabled" and "tampering checks enabled". Note + -- that suppressing either Container_Checks or Tampering_Check disables + -- tampering checks. Note that this code needs to be in a generic + -- package, because we want to take account of check suppressions at the + -- instance. We use these flags, along with pragma Inline, to ensure + -- that the compiler can optimize away the checks, as well as the + -- tampering check machinery, when checks are suppressed. + + Checks : constant Boolean := Container_Checks'Enabled; + T_Check : constant Boolean := + Container_Checks'Enabled and Tampering_Check'Enabled; + + -- Reference_Control_Type is used as a component of reference types, to + -- prohibit tampering with elements so long as references exist. + + type Reference_Control_Type is + new Finalization.Controlled with record + T_Counts : Tamper_Counts_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + procedure Zero_Counts (T_Counts : out Tamper_Counts); + pragma Inline (Zero_Counts); + -- Set Busy and Lock to zero + + procedure Busy (T_Counts : in out Tamper_Counts); + pragma Inline (Busy); + -- Prohibit tampering with cursors + + procedure Unbusy (T_Counts : in out Tamper_Counts); + pragma Inline (Unbusy); + -- Allow tampering with cursors + + procedure Lock (T_Counts : in out Tamper_Counts); + pragma Inline (Lock); + -- Prohibit tampering with elements + + procedure Unlock (T_Counts : in out Tamper_Counts); + pragma Inline (Unlock); + -- Allow tampering with elements + + procedure TC_Check (T_Counts : Tamper_Counts); + pragma Inline (TC_Check); + -- Tampering-with-cursors check + + procedure TE_Check (T_Counts : Tamper_Counts); + pragma Inline (TE_Check); + -- Tampering-with-elements check + + ----------------- + -- RAII Types -- + ----------------- + + -- Initialize of With_Busy increments the Busy count, and Finalize + -- decrements it. Thus, to prohibit tampering with elements within a + -- given scope, declare an object of type With_Busy. The Busy count + -- will be correctly decremented in case of exception or abort. + + -- With_Lock is the same as With_Busy, except it increments/decrements + -- BOTH Busy and Lock, thus prohibiting tampering with cursors. + + type With_Busy (T_Counts : not null access Tamper_Counts) is + new Finalization.Limited_Controlled with null record + with Disable_Controlled => not T_Check; + overriding procedure Initialize (Busy : in out With_Busy); + overriding procedure Finalize (Busy : in out With_Busy); + + type With_Lock (T_Counts : not null access Tamper_Counts) is + new Finalization.Limited_Controlled with null record + with Disable_Controlled => not T_Check; + overriding procedure Initialize (Lock : in out With_Lock); + overriding procedure Finalize (Lock : in out With_Lock); + + -- Variables of type With_Busy and With_Lock are declared only for the + -- effects of Initialize and Finalize, so they are not referenced; + -- disable warnings about that. Note that all variables of these types + -- have names starting with "Busy" or "Lock". These pragmas need to be + -- present wherever these types are used. + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + + end Generic_Implementation; + end Ada.Containers; Index: a-convec.adb =================================================================== --- a-convec.adb (revision 228884) +++ a-convec.adb (working copy) @@ -36,29 +36,13 @@ pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers + procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - procedure Append_Slow_Path (Container : in out Vector; New_Item : Element_Type; @@ -70,273 +54,45 @@ -- "&" -- --------- - function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); - N : Count_Type'Base; -- length of result - J : Count_Type'Base; -- for computing intermediate index values - Last : Index_Type'Base; -- Last index of result + -- We decide that the capacity of the result of "&" is the minimum needed + -- -- the sum of the lengths of the vector parameters. We could decide to + -- make it larger, but we have no basis for knowing how much larger, so we + -- just allocate the minimum amount of storage. + function "&" (Left, Right : Vector) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the vector parameters. We could decide to make it larger, but we - -- have no basis for knowing how much larger, so we just allocate the - -- minimum amount of storage. - - -- Here we handle the easy cases first, when one of the vector - -- parameters is empty. (We say "easy" because there's nothing to - -- compute, that can potentially overflow.) - - if LN = 0 then - if RN = 0 then - return Empty_Vector; - end if; - - declare - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - Elements : constant Elements_Access := - new Elements_Type'(Right.Last, RE); - begin - return (Controlled with Elements, Right.Last, others => <>); - end; - end if; - - if RN = 0 then - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := - new Elements_Type'(Left.Last, LE); - begin - return (Controlled with Elements, Left.Last, others => <>); - end; - - end if; - - -- Neither of the vector parameters is empty, so must compute the length - -- of the result vector and its last index. (This is the harder case, - -- because our computations must avoid overflow.) - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the combined lengths. Note that we cannot - -- simply add the lengths, because of the possibility of overflow. - - if LN > Count_Type'Last - RN then - raise Constraint_Error with "new length is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - N := LN + RN; - - -- The second constraint is that the new Last index value cannot - -- exceed Index_Type'Last. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (N); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Last > Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of length. - - J := Count_Type'Base (No_Index) + N; -- Last - - if J > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (J); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - - if J < Count_Type'Base (No_Index) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We have determined that the result length would not create a Last - -- index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + N); - end if; - - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - Elements : constant Elements_Access := - new Elements_Type'(Last, LE & RE); - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Handle easy case first, when the vector parameter (Left) is empty - - if Left.Is_Empty then - declare - Elements : constant Elements_Access := - new Elements_Type' - (Last => Index_Type'First, - EA => (others => Right)); - - begin - return (Controlled with Elements, Index_Type'First, others => <>); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Left.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Left.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Left.Last + 1; - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := - new Elements_Type'(Last => Last, EA => LE & Right); - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Handle easy case first, when the vector parameter (Right) is empty - - if Right.Is_Empty then - declare - Elements : constant Elements_Access := - new Elements_Type' - (Last => Index_Type'First, - EA => (others => Left)); - begin - return (Controlled with Elements, Index_Type'First, others => <>); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Right.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Right.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Right.Last + 1; - - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : constant Elements_Access := - new Elements_Type' - (Last => Last, - EA => Left & RE); - - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left, Right : Element_Type) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- We must compute the length of the result vector and its last index, - -- but in such a way that overflow is avoided. We must satisfy two - -- constraints: the new length cannot exceed Count_Type'Last (here, we - -- know that that condition is satisfied), and the new Last index cannot - -- exceed Index_Type'Last. - - if Index_Type'First >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Index_Type'First + 1; - - Elements : constant Elements_Access := - new Elements_Type' - (Last => Last, - EA => (Left, Right)); - - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; --------- @@ -344,57 +100,20 @@ --------- overriding function "=" (Left, Right : Vector) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - - if Left.Last /= Right.Last then - return False; - end if; - -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - Result := True; - for J in Index_Type range Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) /= Right.Elements.EA (J) then - Result := False; - exit; - end if; - end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + Left_Valid : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + Right_Valid : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + begin + return Left_Valid = Right_Valid; + end; end "="; ------------ @@ -415,8 +134,7 @@ begin Container.Elements := null; - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); -- Note: it may seem that the following assignment to Container.Last -- is useless, since we assign it to L below. However this code is @@ -429,20 +147,6 @@ end; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Append -- ------------ @@ -451,7 +155,7 @@ begin if Is_Empty (New_Item) then return; - elsif Container.Last = Index_Type'Last then + elsif Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Insert (Container, Container.Last + 1, New_Item); @@ -472,10 +176,7 @@ and then Container.Elements /= null and then Container.Last /= Container.Elements.Last then - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Increment Container.Last after assigning the New_Item, so we -- leave the Container unmodified in case Finalize/Adjust raises @@ -505,7 +206,7 @@ begin if Count = 0 then return; - elsif Container.Last = Index_Type'Last then + elsif Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Insert (Container, Container.Last + 1, New_Item, Count); @@ -545,12 +246,8 @@ procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - else - Container.Last := No_Index; - end if; + TC_Check (Container.TC); + Container.Last := No_Index; end Clear; ------------------------ @@ -562,31 +259,37 @@ Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; - declare - C : Vector renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin + if T_Check then + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Position.Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + else return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; + Control => (Controlled with null)); + end if; end Constant_Reference; function Constant_Reference @@ -594,22 +297,26 @@ Index : Index_Type) return Constant_Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - else + end if; + + if T_Check then declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; + else + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => (Controlled with null)); end if; end Constant_Reference; @@ -642,7 +349,7 @@ elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -685,7 +392,7 @@ -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Index < Index_Type'First then + if Checks and then Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; @@ -697,7 +404,7 @@ -- algorithm, so that case is treated as a proper error.) if Index > Old_Last then - if Index > Old_Last + 1 then + if Checks and then Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; else return; @@ -717,10 +424,7 @@ -- the count on exit. Delete checks the count to determine whether it is -- being called while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We first calculate what's available for deletion starting at -- Index. Here and elsewhere we use the wider of Index_Type'Base and @@ -778,22 +482,21 @@ 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"; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; - elsif Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - - else - Delete (Container, Position.Index, Count); - Position := No_Element; + elsif Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; end Delete; ------------------ @@ -842,10 +545,7 @@ -- it is being called while the associated callback procedure is -- executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- There is no restriction on how large Count can be when deleting -- items. If it is equal or greater than the current length, then this @@ -878,7 +578,7 @@ Index : Index_Type) return Element_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; else return Container.Elements.EA (Index); @@ -887,13 +587,15 @@ function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - elsif Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - else - return Position.Container.Elements.EA (Position.Index); + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; + + return Position.Container.Elements.EA (Position.Index); end Element; -------------- @@ -909,34 +611,15 @@ Free (X); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); end Finalize; procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; + pragma Assert (T_Check); -- not called if check suppressed begin - B := B - 1; + Unbusy (Object.Container.TC); end Finalize; - procedure Finalize (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; - - Control.Container := null; - end if; - end Finalize; - ---------- -- Find -- ---------- @@ -947,7 +630,7 @@ Position : Cursor := No_Element) return Cursor is begin - if Position.Container /= null then + if Checks and then Position.Container /= null then if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -961,38 +644,15 @@ -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for J in Position.Index .. Container.Last loop if Container.Elements.EA (J) = Item then - Result := J; - exit; + return Cursor'(Container'Unrestricted_Access, J); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Find; @@ -1005,37 +665,18 @@ Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; - - Result := No_Index; + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin for Indx in Index .. Container.Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Find_Index; ----------- @@ -1080,7 +721,7 @@ function First_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; else return Container.Elements.EA (Index_Type'First); @@ -1117,36 +758,16 @@ -- element tampering by a generic actual subprogram. declare - EA : Elements_Array renames Container.Elements.EA; - - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Boolean; - + Lock : With_Lock (Container.TC'Unrestricted_Access); + EA : Elements_Array renames Container.Elements.EA; begin - B := B + 1; - L := L + 1; - - Result := True; for J in Index_Type'First .. Container.Last - 1 loop if EA (J + 1) < EA (J) then - Result := False; - exit; + return False; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return True; end; end Is_Sorted; @@ -1171,7 +792,7 @@ return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; @@ -1181,10 +802,7 @@ return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Source.TC); Target.Set_Length (Length (Target) + Length (Source)); @@ -1195,19 +813,9 @@ TA : Elements_Array renames Target.Elements.EA; SA : Elements_Array renames Source.Elements.EA; - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; - + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - J := Target.Last; while Source.Last >= Index_Type'First loop pragma Assert (Source.Last <= Index_Type'First @@ -1236,22 +844,6 @@ J := J - 1; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -1283,33 +875,15 @@ -- an artifact of our array-based implementation. Logically Sort -- requires a check for cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; end Sort; @@ -1358,31 +932,33 @@ Dst : Elements_Access; -- new, expanded internal array begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -1398,7 +974,7 @@ -- Note: we cannot simply add these values, because of the possibility -- of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -1506,7 +1082,7 @@ -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -1551,10 +1127,7 @@ -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- An internal array has already been allocated, so we must determine -- whether there is enough unused storage for the new items. @@ -1828,7 +1401,7 @@ Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1839,7 +1412,7 @@ end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1862,7 +1435,7 @@ Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1879,7 +1452,7 @@ end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1904,7 +1477,7 @@ Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1915,7 +1488,7 @@ end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -1939,7 +1512,7 @@ Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1956,7 +1529,7 @@ end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -2019,31 +1592,33 @@ Dst : Elements_Access; -- new, expanded internal array begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -2059,7 +1634,7 @@ -- Note: we cannot simply add these values, because of the possibility -- of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -2167,7 +1742,7 @@ -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -2211,10 +1786,7 @@ -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- An internal array has already been allocated, so we must determine -- whether there is enough unused storage for the new items. @@ -2360,7 +1932,7 @@ Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -2377,7 +1949,7 @@ end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -2410,22 +1982,11 @@ (Container : Vector; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Iterate; function Iterate @@ -2433,8 +1994,6 @@ return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- The value of its Index component influences the behavior of the First -- and Last selector functions of the iterator object. When the Index @@ -2451,7 +2010,7 @@ Container => V, Index => No_Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2461,8 +2020,6 @@ return Vector_Iterator_Interfaces.Reversible_Iterator'class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -2475,19 +2032,21 @@ -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start.Container = null then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; + if Checks then + if Start.Container = null then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; - if Start.Container /= V then - raise Program_Error with - "Start cursor of Iterate designates wrong vector"; - end if; + if Start.Container /= V then + raise Program_Error with + "Start cursor of Iterate designates wrong vector"; + end if; - if Start.Index > V.Last then - raise Constraint_Error with - "Start position for iterator equals No_Element"; + if Start.Index > V.Last then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; end if; -- The value of its Index component influences the behavior of the First @@ -2504,7 +2063,7 @@ Container => V, Index => Start.Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2549,7 +2108,7 @@ function Last_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; else return Container.Elements.EA (Container.Last); @@ -2612,16 +2171,9 @@ return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Target is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Source is busy)"; - end if; - declare Target_Elements : constant Elements_Access := Target.Elements; begin @@ -2652,7 +2204,7 @@ begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + elsif Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; else @@ -2708,7 +2260,7 @@ begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + elsif Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; else @@ -2734,15 +2286,10 @@ function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type is - C : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -2755,29 +2302,15 @@ Index : Index_Type; Process : not null access procedure (Element : Element_Type)) is + Lock : With_Lock (Container.TC'Unrestricted_Access); V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (V.Elements.EA (Index)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (V.Elements.EA (Index)); end Query_Element; procedure Query_Element @@ -2785,7 +2318,7 @@ Process : not null access procedure (Element : Element_Type)) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; else Query_Element (Position.Container.all, Position.Index, Process); @@ -2852,31 +2385,37 @@ Position : Cursor) return Reference_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; - declare - C : Vector renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin + if T_Check then + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Container.Elements.EA (Position.Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + else return R : constant Reference_Type := (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; + Control => (Controlled with null)); + end if; end Reference; function Reference @@ -2884,23 +2423,26 @@ Index : Index_Type) return Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; + end if; - else + if T_Check then declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; + else + return R : constant Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => (Controlled with null)); end if; end Reference; @@ -2914,14 +2456,12 @@ New_Item : Element_Type) is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - else - Container.Elements.EA (Index) := New_Item; end if; + + TE_Check (Container.TC); + Container.Elements.EA (Index) := New_Item; end Replace_Element; procedure Replace_Element @@ -2930,23 +2470,20 @@ New_Item : Element_Type) is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; - elsif Position.Index > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - - else - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; + elsif Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; end if; - - Container.Elements.EA (Position.Index) := New_Item; end if; + + TE_Check (Container.TC); + Container.Elements.EA (Position.Index) := New_Item; end Replace_Element; ---------------------- @@ -3008,10 +2545,7 @@ -- so this is the best we can do with respect to minimizing -- storage). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare subtype Src_Index_Subtype is Index_Type'Base range @@ -3068,7 +2602,9 @@ -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index + then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3080,7 +2616,7 @@ -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3092,7 +2628,7 @@ Index := Count_Type'Base (No_Index) + Capacity; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3109,7 +2645,7 @@ Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3148,10 +2684,7 @@ -- new internal array having a length that exactly matches the -- number of items in the container. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare subtype Src_Index_Subtype is Index_Type'Base range @@ -3208,10 +2741,7 @@ -- number of active elements in the container.) We must check whether -- the container is busy before doing anything else. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We now allocate a new internal array, having a length different from -- its current value. @@ -3283,10 +2813,7 @@ -- implementation. Logically Reverse_Elements requires a check for -- cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare K : Index_Type; @@ -3322,7 +2849,7 @@ Last : Index_Type'Base; begin - if Position.Container /= null + if Checks and then Position.Container /= null and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; @@ -3337,38 +2864,15 @@ -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Cursor'(Container'Unrestricted_Access, Indx); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Reverse_Find; @@ -3381,67 +2885,36 @@ Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + Lock : With_Lock (Container.TC'Unrestricted_Access); + Last : constant Index_Type'Base := Index_Type'Min (Container.Last, Index); - Result : Index_Type'Base; - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Reverse_Find_Index; --------------------- -- Reverse_Iterate -- --------------------- - procedure Reverse_Iterate (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Reverse_Iterate; ---------------- @@ -3462,7 +2935,7 @@ if Count >= 0 then Container.Delete_Last (Count); - elsif Container.Last >= Index_Type'Last then + elsif Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -3476,22 +2949,21 @@ procedure Swap (Container : in out Vector; I, J : Index_Type) is begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; + if Checks then + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; end if; if I = J then return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + TE_Check (Container.TC); declare EI_Copy : constant Element_Type := Container.Elements.EA (I); @@ -3503,21 +2975,22 @@ procedure Swap (Container : in out Vector; I, J : Cursor) is begin - if I.Container = null then - raise Constraint_Error with "I cursor has no element"; + if Checks then + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; - elsif J.Container = null then - raise Constraint_Error with "J cursor has no element"; + elsif J.Container = null then + raise Constraint_Error with "J cursor has no element"; - elsif I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; + elsif I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; - elsif J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; - - else - Swap (Container, I.Index, J.Index); + elsif J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; + end if; end if; + + Swap (Container, I.Index, J.Index); end Swap; --------------- @@ -3585,7 +3058,9 @@ -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -3597,7 +3072,7 @@ -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -3609,7 +3084,7 @@ Index := Count_Type'Base (No_Index) + Length; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -3626,7 +3101,7 @@ Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -3675,7 +3150,9 @@ -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -3687,7 +3164,7 @@ -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -3699,7 +3176,7 @@ Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -3716,7 +3193,7 @@ Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -3741,28 +3218,13 @@ Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (Container.Elements.EA (Index)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Container.Elements.EA (Index)); end Update_Element; procedure Update_Element @@ -3771,13 +3233,15 @@ 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; ----------- Index: a-convec.ads =================================================================== --- a-convec.ads (revision 228884) +++ a-convec.ads (working copy) @@ -366,8 +366,10 @@ pragma Inline (Next); pragma Inline (Previous); + package Implementation is new Generic_Implementation; + use Implementation; + type Elements_Array is array (Index_Type range <>) of aliased Element_Type; - function "=" (L, R : Elements_Array) return Boolean is abstract; type Elements_Type (Last : Extended_Index) is limited record EA : Elements_Array (Index_Type'First .. Last); @@ -375,14 +377,13 @@ type Elements_Access is access all Elements_Type; - use Ada.Finalization; - use Ada.Streams; + use Finalization; + use Streams; 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); @@ -420,17 +421,9 @@ for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : Vector_Access; - end record; + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - type Constant_Reference_Type (Element : not null access constant Element_Type) is record @@ -477,7 +470,7 @@ -- 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 Sem_Ch5 for + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for -- details. function Pseudo_Reference @@ -501,4 +494,25 @@ -- Count_Type'Last as a universal_integer, so we can compare Index_Type -- values against this without type conversions that might overflow. + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type'Base; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Vectors;

[Ada] Check suppression in Ada.Containers

Commit Message

Patch