From patchwork Thu Apr 11 10:42:00 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 235696 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 262482C00A6 for ; Thu, 11 Apr 2013 20:42:16 +1000 (EST) 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=LkwFHahBk57t7Yim2OiHgthZnpF4/eHlhIwtnZMCIhqwm9hJYu 41npW63clfwU41NCJQ0ZaMYaJMn5Y1dXrY/bRaDMheKag/UPe6IdNuVxX46q9yfE nnpMvIMJNkNM8A72UxPbQDWtzGr3IvcZp1glJk9NBNo3wavds1NiO1b6o= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; 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; s= default; bh=yps0ZFszju/CGRscGY+DFyqzrQ0=; b=HiU9pLljWsuyIdJcvwDV d13eJaejhXCxXBlPaj6Zv1pw2UORtK4E9/l5QtNPxPJ4CdOt3Q9Ild3XGGQNrmWS XMlFBiXNQ9gXBQz/CNPLvXZgTfxPzo7Zp57Qi5OD826aFZsijvnHRzViRfqK8WxF rbG8tf9MKqserHgHQp3tGow= Received: (qmail 20762 invoked by alias); 11 Apr 2013 10:42:07 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 20672 invoked by uid 89); 11 Apr 2013 10:42:07 -0000 X-Spam-SWARE-Status: No, score=-0.4 required=5.0 tests=AWL, BAYES_00, FILL_THIS_FORM, FILL_THIS_FORM_LOAN, RCVD_IN_HOSTKARMA_NO autolearn=no version=3.3.1 Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Thu, 11 Apr 2013 10:42:02 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A87A52EA8A; Thu, 11 Apr 2013 06:42:00 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id B31zqgiGadik; Thu, 11 Apr 2013 06:42:00 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 834D12E123; Thu, 11 Apr 2013 06:42:00 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 796EF3FF09; Thu, 11 Apr 2013 06:42:00 -0400 (EDT) Date: Thu, 11 Apr 2013 06:42:00 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Matthew Heaney Subject: [Ada] Check for container tampering Message-ID: <20130411104200.GA15461@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) X-Virus-Found: No There are several operations (e.g. Find) that call the generic operation for element equality. In principle it is possible for the generic actual to tamper with the elements of the container while the operation is in progress, but such behavior would be undefined. AI05-0022 requires that the implementation detect when container manipulation occurs through the equality operator, and to raise Program_Error as necessary to prevent erroneous execution. We do that here by incrementing the lock counters before entering the loop. If tamper-sensitive operations are called while the loop is executing, the non-zero lock count will be detected and Program_Error raised. The text of AI05-0022 can be found here: http://www.ada-auth.org/cgi-bin/cvsweb.cgi/ai05s/ai05-0022-1.txt Tested on x86_64-pc-linux-gnu, committed on trunk 2013-04-11 Matthew Heaney * a-convec.adb, a-coinve.adb, a-cobove.adb ("="): Increment lock counts before entering loop. (Find, Find_Index): Ditto. (Is_Sorted, Merge, Sort): Ditto. (Reverse_Find, Reverse_Find_Index): Ditto. Index: a-coinve.adb =================================================================== --- a-coinve.adb (revision 197743) +++ a-coinve.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -117,7 +117,6 @@ return (Controlled with Elements, Right.Last, 0, 0); end; - end if; if RN = 0 then @@ -243,7 +242,6 @@ 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); @@ -514,6 +512,14 @@ --------- 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; @@ -523,21 +529,49 @@ 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 if Left.Elements.EA (J) = null then if Right.Elements.EA (J) /= null then - return False; + Result := False; + exit; end if; elsif Right.Elements.EA (J) = null then - return False; + Result := False; + exit; elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then - return False; + Result := False; + exit; end if; end loop; - return True; + 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; end "="; ------------ @@ -564,12 +598,12 @@ Container.Elements := new Elements_Type (L); - for I in E'Range loop - if E (I) /= null then - Container.Elements.EA (I) := new Element_Type'(E (I).all); + for J in E'Range loop + if E (J) /= null then + Container.Elements.EA (J) := new Element_Type'(E (J).all); end if; - Container.Last := I; + Container.Last := J; end loop; end; end Adjust; @@ -596,16 +630,11 @@ begin if Is_Empty (New_Item) then return; - end if; - - if Container.Last = Index_Type'Last then + elsif 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); end if; - - Insert - (Container, - Container.Last + 1, - New_Item); end Append; procedure Append @@ -616,17 +645,11 @@ begin if Count = 0 then return; - end if; - - if Container.Last = Index_Type'Last then + elsif 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; - - Insert - (Container, - Container.Last + 1, - New_Item, - Count); end Append; ------------ @@ -637,10 +660,10 @@ begin if Target'Address = Source'Address then return; + else + Target.Clear; + Target.Append (Source); end if; - - Target.Clear; - Target.Append (Source); end Assign; -------------- @@ -651,9 +674,9 @@ begin if Container.Elements = null then return 0; + else + return Container.Elements.EA'Length; end if; - - return Container.Elements.EA'Length; end Capacity; ----------- @@ -665,17 +688,18 @@ if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (vector is busy)"; + + 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; ------------------------ @@ -840,9 +864,9 @@ if Index > Old_Last then if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; + else + return; end if; - - return; end if; -- Here and elsewhere we treat deleting 0 items from the container as a @@ -934,7 +958,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then New_Last := Old_Last - Index_Type'Base (Count); J := Index + Index_Type'Base (Count); - else New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); J := Index_Type'Base (Count_Type'Base (Index) + Count); @@ -987,19 +1010,17 @@ begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - if Position.Index > Container.Last then + 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; end if; - - Delete (Container, Position.Index, Count); - - Position := No_Element; end Delete; ------------------ @@ -1013,14 +1034,14 @@ begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; + + else + Delete (Container, Index_Type'First, Count); end if; - - Delete (Container, Index_Type'First, Count); end Delete_First; ----------------- @@ -1110,13 +1131,12 @@ declare EA : constant Element_Access := Container.Elements.EA (Index); - begin if EA = null then raise Constraint_Error with "element is empty"; + else + return EA.all; end if; - - return EA.all; end; end Element; @@ -1132,14 +1152,13 @@ declare EA : constant Element_Access := - Position.Container.Elements.EA (Position.Index); - + Position.Container.Elements.EA (Position.Index); begin if EA = null then raise Constraint_Error with "element is empty"; + else + return EA.all; end if; - - return EA.all; end; end Element; @@ -1201,15 +1220,44 @@ end if; end if; - for J in Position.Index .. Container.Last loop - if Container.Elements.EA (J) /= null - and then Container.Elements.EA (J).all = Item - then - return (Container'Unrestricted_Access, J); + -- 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; + + 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; + 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; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ---------------- @@ -1221,16 +1269,38 @@ 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; for Indx in Index .. Container.Last loop if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Find_Index; ----------- @@ -1281,14 +1351,13 @@ declare EA : constant Element_Access := - Container.Elements.EA (Index_Type'First); - + Container.Elements.EA (Index_Type'First); begin if EA = null then raise Constraint_Error with "first element is empty"; + else + return EA.all; end if; - - return EA.all; end; end First_Element; @@ -1340,17 +1409,40 @@ return True; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare 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 - return False; + Result := False; + exit; end if; end loop; + + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end; - - return True; end Is_Sorted; ----------- @@ -1361,7 +1453,6 @@ I, J : Index_Type'Base; begin - -- The semantics of Merge changed slightly per AI05-0021. It was -- originally the case that if Target and Source denoted the same -- container object, then the GNAT implementation of Merge did @@ -1392,53 +1483,86 @@ I := Target.Last; -- original value (before Set_Length) Target.Set_Length (Length (Target) + Length (Source)); - J := Target.Last; -- new value (after Set_Length) - while Source.Last >= Index_Type'First loop - pragma Assert - (Source.Last <= Index_Type'First - or else not (Is_Less - (Source.Elements.EA (Source.Last), - Source.Elements.EA (Source.Last - 1)))); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if I < Index_Type'First then + declare + 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; + + 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 + (Source.Last <= Index_Type'First + or else not (Is_Less (SA (Source.Last), + SA (Source.Last - 1)))); + + if I < Index_Type'First then + declare + Src : Elements_Array renames + SA (Index_Type'First .. Source.Last); + begin + TA (Index_Type'First .. J) := Src; + Src := (others => null); + end; + + Source.Last := No_Index; + exit; + end if; + + pragma Assert + (I <= Index_Type'First + or else not (Is_Less (TA (I), TA (I - 1)))); + declare - Src : Elements_Array renames - Source.Elements.EA (Index_Type'First .. Source.Last); + Src : Element_Access renames SA (Source.Last); + Tgt : Element_Access renames TA (I); begin - Target.Elements.EA (Index_Type'First .. J) := Src; - Src := (others => null); + if Is_Less (Src, Tgt) then + Target.Elements.EA (J) := Tgt; + Tgt := null; + I := I - 1; + + else + Target.Elements.EA (J) := Src; + Src := null; + Source.Last := Source.Last - 1; + end if; end; - Source.Last := No_Index; - return; - end if; + J := J - 1; + end loop; - pragma Assert - (I <= Index_Type'First - or else not (Is_Less - (Target.Elements.EA (I), - Target.Elements.EA (I - 1)))); + TB := TB - 1; + TL := TL - 1; - declare - Src : Element_Access renames Source.Elements.EA (Source.Last); - Tgt : Element_Access renames Target.Elements.EA (I); + SB := SB - 1; + SL := SL - 1; - begin - if Is_Less (Src, Tgt) then - Target.Elements.EA (J) := Tgt; - Tgt := null; - I := I - 1; + exception + when others => + TB := TB - 1; + TL := TL - 1; - else - Target.Elements.EA (J) := Src; - Src := null; - Source.Last := Source.Last - 1; - end if; - end; + SB := SB - 1; + SL := SL - 1; - J := J - 1; - end loop; + raise; + end; end Merge; ---------- @@ -1475,7 +1599,28 @@ "attempt to tamper with cursors (vector is busy)"; end if; - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + -- 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; + + 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; @@ -1488,9 +1633,9 @@ begin if Position.Container = null then return False; + else + return Position.Index <= Position.Container.Last; end if; - - return Position.Index <= Position.Container.Last; end Has_Element; ------------ @@ -1663,7 +1808,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (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); end if; @@ -1859,7 +2003,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else Dst_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); @@ -1888,9 +2031,8 @@ -- The new items are being appended to the vector, so no -- sliding of existing elements is required. - -- We have copied the elements from to the old, source array to - -- the new, destination array, so we can now deallocate the old - -- array. + -- We have copied the elements from to the old source array to the + -- new destination array, so we can now deallocate the old array. Container.Elements := Dst; Free (Src); @@ -1899,11 +2041,11 @@ for Idx in Before .. New_Last loop - -- In order to preserve container invariants, we always - -- attempt the element allocation first, before setting the - -- Last index value, in case the allocation fails (either - -- because there is no storage available, or because element - -- initialization fails). + -- In order to preserve container invariants, we always attempt + -- the element allocation first, before setting the Last index + -- value, in case the allocation fails (either because there + -- is no storage available, or because element initialization + -- fails). declare -- The element allocator may need an accessibility check in @@ -1928,24 +2070,21 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - -- We have copied the elements from to the old, source array to - -- the new, destination array, so we can now deallocate the old - -- array. + -- We have copied the elements from to the old source array to the + -- new destination array, so we can now deallocate the old array. Container.Elements := Dst; Container.Last := New_Last; Free (Src); -- The new array has a range in the middle containing null access - -- values. We now fill in that partition of the array with the new - -- items. + -- values. Fill in that partition of the array with the new items. for Idx in Before .. Index - 1 loop @@ -2081,7 +2220,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then J := Before + Index_Type'Base (N); - else J := Index_Type'Base (Count_Type'Base (Before) + N); end if; @@ -2105,7 +2243,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Index := J - Index_Type'Base (Src'Length); - else Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); end if; @@ -2138,9 +2275,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2172,9 +2307,7 @@ end if; if Is_Empty (New_Item) 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); @@ -2183,9 +2316,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2221,9 +2352,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2266,9 +2395,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2330,9 +2457,7 @@ -- 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 + if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; @@ -2453,7 +2578,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (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); end if; @@ -2490,7 +2614,8 @@ end if; if New_Length <= Container.Elements.EA'Length then - -- In this case, we're inserting elements into a vector that has + + -- In this case, we are inserting elements into a vector that has -- already allocated an internal array, and the existing array has -- enough unused storage for the new items. @@ -2501,13 +2626,12 @@ if Before <= Container.Last then -- The new space is being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. We use the wider of Index_Type'Base and + -- elements, so we must slide the existing elements up to + -- 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 Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -2554,7 +2678,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else Dst_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); @@ -2585,7 +2708,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -2619,9 +2741,7 @@ 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); @@ -2810,14 +2930,13 @@ declare EA : constant Element_Access := - Container.Elements.EA (Container.Last); - + Container.Elements.EA (Container.Last); begin if EA = null then raise Constraint_Error with "last element is empty"; + else + return EA.all; end if; - - return EA.all; end; end Last_Element; @@ -2903,36 +3022,30 @@ begin if Position.Container = null then return No_Element; - end if; - - if Position.Index < Position.Container.Last then + elsif Position.Index < Position.Container.Last then return (Position.Container, Position.Index + 1); + else + return No_Element; end if; - - return No_Element; end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; + else + return Next (Position); end if; - - return Next (Position); end Next; procedure Next (Position : in out Cursor) is begin if Position.Container = null then return; - end if; - - if Position.Index < Position.Container.Last then + elsif Position.Index < Position.Container.Last then Position.Index := Position.Index + 1; else Position := No_Element; @@ -2954,10 +3067,7 @@ Count : Count_Type := 1) is begin - Insert (Container, - Index_Type'First, - New_Item, - Count); + Insert (Container, Index_Type'First, New_Item, Count); end Prepend; -------------- @@ -2968,9 +3078,7 @@ begin if Position.Container = null then return; - end if; - - if Position.Index > Index_Type'First then + elsif Position.Index > Index_Type'First then Position.Index := Position.Index - 1; else Position := No_Element; @@ -2981,27 +3089,23 @@ begin if Position.Container = null then return No_Element; - end if; - - if Position.Index > Index_Type'First then + elsif Position.Index > Index_Type'First then return (Position.Container, Position.Index - 1); + else + return No_Element; end if; - - return No_Element; end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; ------------------- @@ -3049,9 +3153,9 @@ begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + else + Query_Element (Position.Container.all, Position.Index, Process); end if; - - Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -3064,9 +3168,8 @@ is Length : Count_Type'Base; Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); + B : Boolean; - B : Boolean; - begin Clear (Container); @@ -3616,23 +3719,50 @@ raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Container = null - or else Position.Index > Container.Last - then + if Position.Container = null or else Position.Index > Container.Last then Last := Container.Last; else Last := Position.Index; end if; - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) /= null - and then Container.Elements.EA (Indx).all = Item - then - return (Container'Unrestricted_Access, Indx); + -- 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; + + 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; + 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; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; ------------------------ @@ -3644,18 +3774,41 @@ 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; + + 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 - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Reverse_Find_Index; --------------------- @@ -3800,13 +3953,11 @@ begin if Position.Container = null then return No_Index; - end if; - - if Position.Index <= Position.Container.Last then + elsif Position.Index <= Position.Container.Last then return Position.Index; + else + return No_Index; end if; - - return No_Index; end To_Index; --------------- @@ -4072,13 +4223,13 @@ begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; + + else + Update_Element (Container, Position.Index, Process); end if; - - Update_Element (Container, Position.Index, Process); end Update_Element; ----------- Index: a-cobove.adb =================================================================== --- a-cobove.adb (revision 197743) +++ a-cobove.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -112,8 +112,8 @@ 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. + -- It is now safe to compute the length of the new vector, without fear + -- of overflow. N := LN + RN; @@ -122,6 +122,7 @@ -- 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. @@ -150,6 +151,7 @@ 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. @@ -280,6 +282,14 @@ --------- 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; @@ -289,13 +299,40 @@ 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 Count_Type range 1 .. Left.Length loop if Left.Elements (J) /= Right.Elements (J) then - return False; + Result := False; + exit; end if; end loop; - return True; + 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; end "="; ------------ @@ -543,7 +580,6 @@ 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; @@ -567,7 +603,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Off := Count_Type'Base (Index - Index_Type'First); New_Last := Old_Last - Index_Type'Base (Count); - else Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); @@ -579,7 +614,6 @@ declare EA : Elements_Array renames Container.Elements; Idx : constant Count_Type := EA'First + Off; - begin EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); Container.Last := New_Last; @@ -621,14 +655,14 @@ begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; + + else + Delete (Container, Index_Type'First, Count); end if; - - Delete (Container, Index_Type'First, Count); end Delete_First; ----------------- @@ -738,13 +772,42 @@ end if; end if; - for J in Position.Index .. Container.Last loop - if Container.Elements (To_Array_Index (J)) = Item then - return (Container'Unrestricted_Access, J); + -- 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; + + begin + B := B + 1; + L := L + 1; + + Result := No_Index; + for J in Position.Index .. Container.Last loop + if Container.Elements (To_Array_Index (J)) = Item then + Result := J; + exit; + 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; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ---------------- @@ -756,14 +819,36 @@ 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; for Indx in Index .. Container.Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Find_Index; ----------- @@ -841,17 +926,40 @@ return True; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare EA : Elements_Array renames Container.Elements; + + 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 J in 1 .. Container.Length - 1 loop if EA (J + 1) < EA (J) then - return False; + Result := False; + exit; end if; end loop; + + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end; - - return True; end Is_Sorted; ----------- @@ -862,7 +970,6 @@ I, J : Count_Type; begin - -- The semantics of Merge changed slightly per AI05-0021. It was -- originally the case that if Target and Source denoted the same -- container object, then the GNAT implementation of Merge did @@ -893,21 +1000,35 @@ I := Target.Length; Target.Set_Length (I + Source.Length); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare TA : Elements_Array renames Target.Elements; SA : Elements_Array renames Source.Elements; + TB : Natural renames Target.Busy; + TL : Natural renames Target.Lock; + + SB : Natural renames Source.Busy; + SL : Natural renames Source.Lock; + begin + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + J := Target.Length; while not Source.Is_Empty loop pragma Assert (Source.Length <= 1 - or else not (SA (Source.Length) < - SA (Source.Length - 1))); + or else not (SA (Source.Length) < SA (Source.Length - 1))); if I = 0 then TA (1 .. J) := SA (1 .. Source.Length); Source.Last := No_Index; - return; + exit; end if; pragma Assert (I <= 1 @@ -924,6 +1045,22 @@ 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; @@ -960,7 +1097,28 @@ "attempt to tamper with cursors (vector is busy)"; end if; - Sort (Container.Elements (1 .. Container.Length)); + -- 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; + + begin + B := B + 1; + L := L + 1; + + Sort (Container.Elements (1 .. Container.Length)); + + B := B - 1; + L := L - 1; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Sort; end Generic_Sorting; @@ -1056,10 +1214,12 @@ -- acceptable, then we compute the new last index from that. if Index_Type'Base'Last >= Count_Type'Pos (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. if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is -- less than 0, so it is safe to compute the following sum without -- fear of overflow. @@ -1067,6 +1227,7 @@ Index := No_Index + Index_Type'Base (Count_Type'Last); if Index <= Index_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. @@ -1091,6 +1252,7 @@ end if; elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less -- than 0, so it is safe to compute the following sum without fear of -- overflow. @@ -1098,6 +1260,7 @@ J := Count_Type'Base (No_Index) + Count_Type'Last; if J <= Count_Type'Base (Index_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. @@ -1151,6 +1314,7 @@ J := To_Array_Index (Before); if Before > Container.Last then + -- The new items are being appended to the vector, so no -- sliding of existing elements is required. @@ -1508,10 +1672,12 @@ -- acceptable, then we compute the new last index from that. if Index_Type'Base'Last >= Count_Type'Pos (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. if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is -- less than 0, so it is safe to compute the following sum without -- fear of overflow. @@ -1519,6 +1685,7 @@ Index := No_Index + Index_Type'Base (Count_Type'Last); if Index <= Index_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. @@ -1543,6 +1710,7 @@ end if; elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less -- than 0, so it is safe to compute the following sum without fear of -- overflow. @@ -1550,6 +1718,7 @@ J := Count_Type'Base (No_Index) + Count_Type'Last; if J <= Count_Type'Base (Index_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. @@ -1608,6 +1777,7 @@ -- unused storage for the new items. if Before <= Container.Last then + -- The space is being inserted before some existing elements, -- so we must slide the existing elements up to their new home. @@ -1927,36 +2097,30 @@ begin if Position.Container = null then return No_Element; - end if; - - if Position.Index < Position.Container.Last then + elsif Position.Index < Position.Container.Last then return (Position.Container, Position.Index + 1); + else + return No_Element; end if; - - return No_Element; end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; + else + return Next (Position); end if; - - return Next (Position); end Next; procedure Next (Position : in out Cursor) is begin if Position.Container = null then return; - end if; - - if Position.Index < Position.Container.Last then + elsif Position.Index < Position.Container.Last then Position.Index := Position.Index + 1; else Position := No_Element; @@ -1992,9 +2156,7 @@ begin if Position.Container = null then return; - end if; - - if Position.Index > Index_Type'First then + elsif Position.Index > Index_Type'First then Position.Index := Position.Index - 1; else Position := No_Element; @@ -2005,27 +2167,23 @@ begin if Position.Container = null then return No_Element; - end if; - - if Position.Index > Index_Type'First then + elsif Position.Index > Index_Type'First then return (Position.Container, Position.Index - 1); + else + return No_Element; end if; - - return No_Element; end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; ------------------- @@ -2069,9 +2227,9 @@ begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + else + Query_Element (Position.Container.all, Position.Index, Process); end if; - - Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -2146,9 +2304,9 @@ declare A : Elements_Array renames Container.Elements; - I : constant Count_Type := To_Array_Index (Position.Index); + J : constant Count_Type := To_Array_Index (Position.Index); begin - return (Element => A (I)'Access); + return (Element => A (J)'Access); end; end Reference; @@ -2163,9 +2321,9 @@ declare A : Elements_Array renames Container.Elements; - I : constant Count_Type := To_Array_Index (Index); + J : constant Count_Type := To_Array_Index (Index); begin - return (Element => A (I)'Access); + return (Element => A (J)'Access); end; end Reference; @@ -2181,14 +2339,12 @@ begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; - end if; - - if Container.Lock > 0 then + elsif Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (vector is locked)"; + else + Container.Elements (To_Array_Index (Index)) := New_Item; end if; - - Container.Elements (To_Array_Index (Index)) := New_Item; end Replace_Element; procedure Replace_Element @@ -2199,22 +2355,20 @@ begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - if Position.Index > Container.Last then + elsif Position.Index > Container.Last then raise Constraint_Error with "Position cursor is out of range"; - end if; - if Container.Lock > 0 then + elsif Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (vector is locked)"; + + else + Container.Elements (To_Array_Index (Position.Index)) := New_Item; end if; - - Container.Elements (To_Array_Index (Position.Index)) := New_Item; end Replace_Element; ---------------------- @@ -2300,13 +2454,41 @@ then Container.Last else Position.Index); - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements (To_Array_Index (Indx)) = Item then - return (Container'Unrestricted_Access, Indx); + -- 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; + + begin + B := B + 1; + L := L + 1; + + Result := No_Index; + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + Result := Indx; + exit; + 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; - end loop; - - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; ------------------------ @@ -2318,17 +2500,39 @@ 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 := 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 (To_Array_Index (Indx)) = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Reverse_Find_Index; --------------------- @@ -2375,10 +2579,8 @@ if Count >= 0 then Container.Delete_Last (Count); - elsif Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; - else Container.Insert_Space (Container.Last + 1, -Count); end if; @@ -2451,11 +2653,11 @@ -- hence we also know that -- Index - Index_Type'First >= 0 - -- The issue is that even though 0 is guaranteed to be a value - -- in the type Index_Type'Base, there's no guarantee that the - -- difference is a value in that type. To prevent overflow we - -- use the wider of Count_Type'Base and Index_Type'Base to - -- perform intermediate calculations. + -- The issue is that even though 0 is guaranteed to be a value in + -- the type Index_Type'Base, there's no guarantee that the difference + -- is a value in that type. To prevent overflow we use the wider + -- of Count_Type'Base and Index_Type'Base to perform intermediate + -- calculations. if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Offset := Count_Type'Base (Index - Index_Type'First); Index: a-convec.adb =================================================================== --- a-convec.adb (revision 197743) +++ a-convec.adb (working copy) @@ -84,12 +84,10 @@ end if; declare - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); Elements : constant Elements_Access := - new Elements_Type'(Right.Last, RE); - + new Elements_Type'(Right.Last, RE); begin return (Controlled with Elements, Right.Last, 0, 0); end; @@ -97,12 +95,10 @@ if RN = 0 then declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); Elements : constant Elements_Access := - new Elements_Type'(Left.Last, LE); - + new Elements_Type'(Left.Last, LE); begin return (Controlled with Elements, Left.Last, 0, 0); end; @@ -197,15 +193,12 @@ 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); - + 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); - + new Elements_Type'(Last, LE & RE); begin return (Controlled with Elements, Last, 0, 0); end; @@ -247,14 +240,11 @@ end if; declare - Last : constant Index_Type := Left.Last + 1; - - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - + 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); - + new Elements_Type'(Last => Last, EA => LE & Right); begin return (Controlled with Elements, Last, 0, 0); end; @@ -275,7 +265,6 @@ new Elements_Type' (Last => Index_Type'First, EA => (others => Left)); - begin return (Controlled with Elements, Index_Type'First, 0, 0); end; @@ -346,6 +335,14 @@ --------- 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; @@ -355,13 +352,40 @@ 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 - return False; + Result := False; + exit; end if; end loop; - return True; + 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; end "="; ------------ @@ -418,16 +442,11 @@ begin if Is_Empty (New_Item) then return; - end if; - - if Container.Last = Index_Type'Last then + elsif 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); end if; - - Insert - (Container, - Container.Last + 1, - New_Item); end Append; procedure Append @@ -438,17 +457,11 @@ begin if Count = 0 then return; - end if; - - if Container.Last = Index_Type'Last then + elsif 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; - - Insert - (Container, - Container.Last + 1, - New_Item, - Count); end Append; ------------ @@ -459,10 +472,10 @@ begin if Target'Address = Source'Address then return; + else + Target.Clear; + Target.Append (Source); end if; - - Target.Clear; - Target.Append (Source); end Assign; -------------- @@ -638,9 +651,9 @@ if Index > Old_Last then if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; + else + return; end if; - - return; end if; -- Here and elsewhere we treat deleting 0 items from the container as a @@ -668,7 +681,6 @@ 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; @@ -694,7 +706,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then New_Last := Old_Last - Index_Type'Base (Count); J := Index + Index_Type'Base (Count); - else New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); J := Index_Type'Base (Count_Type'Base (Index) + Count); @@ -708,7 +719,6 @@ declare EA : Elements_Array renames Container.Elements.EA; - begin EA (Index .. New_Last) := EA (J .. Old_Last); Container.Last := New_Last; @@ -725,18 +735,17 @@ begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - if Position.Index > Container.Last then + 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; end if; - - Delete (Container, Position.Index, Count); - Position := No_Element; end Delete; ------------------ @@ -750,14 +759,14 @@ begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; + + else + Delete (Container, Index_Type'First, Count); end if; - - Delete (Container, Index_Type'First, Count); end Delete_First; ----------------- @@ -823,9 +832,9 @@ begin if 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 @@ -850,11 +859,12 @@ if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (vector is busy)"; + + else + Container.Elements := null; + Container.Last := No_Index; + Free (X); end if; - - Container.Elements := null; - Container.Last := No_Index; - Free (X); end Finalize; procedure Finalize (Object : in out Iterator) is @@ -899,13 +909,42 @@ end if; end if; - for J in Position.Index .. Container.Last loop - if Container.Elements.EA (J) = Item then - return (Container'Unrestricted_Access, J); + -- 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; + + 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; + 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; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ---------------- @@ -917,14 +956,36 @@ 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; for Indx in Index .. Container.Last loop if Container.Elements.EA (Indx) = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Find_Index; ----------- @@ -1002,17 +1063,40 @@ return True; end if; + -- Per AI05-0022, the container implementation is required to detect + -- 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; + 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 - return False; + Result := False; + exit; end if; end loop; + + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end; - - return True; end Is_Sorted; ----------- @@ -1053,23 +1137,38 @@ Target.Set_Length (Length (Target) + Length (Source)); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare 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; + 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 - or else not (SA (Source.Last) < - SA (Source.Last - 1))); + or else not (SA (Source.Last) < + SA (Source.Last - 1))); if I < Index_Type'First then TA (Index_Type'First .. J) := SA (Index_Type'First .. Source.Last); Source.Last := No_Index; - return; + exit; end if; pragma Assert (I <= Index_Type'First @@ -1086,6 +1185,22 @@ 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; @@ -1122,7 +1237,28 @@ "attempt to tamper with cursors (vector is busy)"; end if; - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + -- 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; + + 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; @@ -1182,9 +1318,7 @@ -- 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 + if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; @@ -1374,7 +1508,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -1402,9 +1535,9 @@ if New_Capacity > Count_Type'Last / 2 then New_Capacity := Count_Type'Last; exit; + else + New_Capacity := 2 * New_Capacity; end if; - - New_Capacity := 2 * New_Capacity; end loop; if New_Capacity > Max_Length then @@ -1421,7 +1554,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else Dst_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); @@ -1455,7 +1587,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -1475,6 +1606,7 @@ declare X : Elements_Access := Container.Elements; + begin -- We first isolate the old internal array, removing it from the -- container and replacing it with the new internal array, before we @@ -1518,7 +1650,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then J := (Before - 1) + Index_Type'Base (N); - else J := Index_Type'Base (Count_Type'Base (Before - 1) + N); end if; @@ -1549,7 +1680,7 @@ Index_Type'First .. L; Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + Container.Elements.EA (Src_Index_Subtype); K : Index_Type'Base; @@ -1562,7 +1693,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then K := L + Index_Type'Base (Src'Length); - else K := Index_Type'Base (Count_Type'Base (L) + Src'Length); end if; @@ -1594,7 +1724,7 @@ F .. Container.Last; Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + Container.Elements.EA (Src_Index_Subtype); K : Index_Type'Base; @@ -1606,7 +1736,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then K := F - Index_Type'Base (Src'Length); - else K := Index_Type'Base (Count_Type'Base (F) - Src'Length); end if; @@ -1633,9 +1762,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -1666,9 +1793,7 @@ end if; if Is_Empty (New_Item) 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); @@ -1677,9 +1802,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -1715,9 +1838,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -1749,9 +1870,7 @@ 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); @@ -1760,9 +1879,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -1799,7 +1916,6 @@ is New_Item : Element_Type; -- Default-initialized value pragma Warnings (Off, New_Item); - begin Insert (Container, Before, New_Item, Position, Count); end Insert; @@ -1849,9 +1965,7 @@ -- 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 + if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; @@ -1973,7 +2087,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (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); end if; @@ -2081,7 +2194,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else Dst_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); @@ -2113,7 +2225,6 @@ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -2166,9 +2277,7 @@ 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); @@ -2177,9 +2286,7 @@ return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2250,9 +2357,9 @@ -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => No_Index) + (Limited_Controlled with + Container => V, + Index => No_Index) do B := B + 1; end return; @@ -2303,9 +2410,9 @@ -- is a forward or reverse iteration. return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => Start.Index) + (Limited_Controlled with + Container => V, + Index => Start.Index) do B := B + 1; end return; @@ -2455,14 +2562,12 @@ begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; + else + return Next (Position); end if; - - return Next (Position); end Next; procedure Next (Position : in out Cursor) is @@ -2491,10 +2596,7 @@ Count : Count_Type := 1) is begin - Insert (Container, - Index_Type'First, - New_Item, - Count); + Insert (Container, Index_Type'First, New_Item, Count); end Prepend; -------------- @@ -2516,14 +2618,12 @@ begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; procedure Previous (Position : in out Cursor) is @@ -2578,9 +2678,9 @@ begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + else + Query_Element (Position.Container.all, Position.Index, Process); end if; - - Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -2677,6 +2777,7 @@ begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; + else declare C : Vector renames Container'Unrestricted_Access.all; @@ -2706,14 +2807,12 @@ begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; - end if; - - if Container.Lock > 0 then + 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; - - Container.Elements.EA (Index) := New_Item; end Replace_Element; procedure Replace_Element @@ -2724,22 +2823,21 @@ begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - if Position.Index > Container.Last then + elsif Position.Index > Container.Last then raise Constraint_Error with "Position cursor is out of range"; - end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; + else + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + Container.Elements.EA (Position.Index) := New_Item; end if; - - Container.Elements.EA (Position.Index) := New_Item; end Replace_Element; ---------------------- @@ -3126,13 +3224,42 @@ then Container.Last else Position.Index); - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) = Item then - return (Container'Unrestricted_Access, Indx); + -- 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; + + 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; + 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; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; ------------------------ @@ -3144,17 +3271,39 @@ 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 := 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 - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Reverse_Find_Index; --------------------- @@ -3245,21 +3394,19 @@ begin if I.Container = null then raise Constraint_Error with "I cursor has no element"; - end if; - if J.Container = null then + elsif J.Container = null then raise Constraint_Error with "J cursor has no element"; - end if; - if I.Container /= Container'Unrestricted_Access then + elsif I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor denotes wrong container"; - end if; - if J.Container /= Container'Unrestricted_Access then + elsif J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor denotes wrong container"; + + else + Swap (Container, I.Index, J.Index); end if; - - Swap (Container, I.Index, J.Index); end Swap; --------------- @@ -3286,13 +3433,11 @@ begin if Position.Container = null then return No_Index; - end if; - - if Position.Index <= Position.Container.Last then + elsif Position.Index <= Position.Container.Last then return Position.Index; + else + return No_Index; end if; - - return No_Index; end To_Index; ---------------