From 2602b64e3a4072c8819cad2f3abffe2d5ae69de3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 11 Apr 2013 12:41:49 +0200 Subject: [PATCH] [multiple changes] 2013-04-11 Robert Dewar * stand.ads: Minor reformatting. 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. From-SVN: r197765 --- gcc/ada/ChangeLog | 12 + gcc/ada/a-cobove.adb | 376 ++++++++++++++++++++++++-------- gcc/ada/a-coinve.adb | 603 ++++++++++++++++++++++++++++++++------------------- gcc/ada/a-convec.adb | 515 +++++++++++++++++++++++++++---------------- gcc/ada/stand.ads | 30 ++- 5 files changed, 1022 insertions(+), 514 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 238de70..3582e9f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,17 @@ 2013-04-11 Robert Dewar + * stand.ads: Minor reformatting. + +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. + +2013-04-11 Robert Dewar + * exp_ch11.ads, exp_ch11.adb (Expand_N_Raise_Expression): New procedure. * exp_util.adb (Insert_Actions): Add entry for N_Raise_Expression. * expander.adb: Add call to Expand_N_Raise_Expression. diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index 8ca958f..01755cf 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is -- 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -289,13 +299,40 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else Count2 := Count_Type'Base (Old_Last - Index + 1); end if; @@ -567,7 +603,6 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; - end if; - Delete (Container, Index_Type'First, Count); + else + Delete (Container, Index_Type'First, Count); + end if; end Delete_First; ----------------- @@ -738,13 +772,42 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; 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 @@ package body Ada.Containers.Bounded_Vectors is 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; - end; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Is_Sorted; ----------- @@ -862,7 +970,6 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is J := J - 1; end loop; + + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + exception + when others => + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + raise; end; end Merge; @@ -960,7 +1097,28 @@ package body Ada.Containers.Bounded_Vectors is "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 @@ package body Ada.Containers.Bounded_Vectors is -- 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is -- 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is -- 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is 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)"; - end if; - Container.Elements (To_Array_Index (Position.Index)) := New_Item; + else + Container.Elements (To_Array_Index (Position.Index)) := New_Item; + end if; end Replace_Element; ---------------------- @@ -2300,13 +2454,41 @@ package body Ada.Containers.Bounded_Vectors is 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); - end if; - end loop; + -- 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; - return No_Element; + 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; + end; end Reverse_Find; ------------------------ @@ -2318,17 +2500,39 @@ package body Ada.Containers.Bounded_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + Last : constant Index_Type'Base := 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 @@ package body Ada.Containers.Bounded_Vectors is 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 @@ package body Ada.Containers.Bounded_Vectors is -- 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); diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 5b59c01..d63ebc0 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -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 @@ package body Ada.Containers.Indefinite_Vectors is return (Controlled with Elements, Right.Last, 0, 0); end; - end if; if RN = 0 then @@ -243,7 +242,6 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -523,21 +529,49 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (vector is busy)"; - 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; + 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; end Clear; ------------------------ @@ -840,9 +864,9 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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"; - end if; - - Delete (Container, Position.Index, Count); - Position := No_Element; + else + Delete (Container, Position.Index, Count); + Position := No_Element; + end if; end Delete; ------------------ @@ -1013,14 +1034,14 @@ package body Ada.Containers.Indefinite_Vectors is begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; - end if; - Delete (Container, Index_Type'First, Count); + else + Delete (Container, Index_Type'First, Count); + end if; end Delete_First; ----------------- @@ -1110,13 +1131,12 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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; - end; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Is_Sorted; ----------- @@ -1361,7 +1453,6 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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. + + 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)))); - if I < Index_Type'First then 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 @@ package body Ada.Containers.Indefinite_Vectors is "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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is -- 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is -- 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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,8 +3168,7 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + Last : constant Index_Type'Base := (if Index > Container.Last then Container.Last else Index); + + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + 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 @@ package body Ada.Containers.Indefinite_Vectors is 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 @@ package body Ada.Containers.Indefinite_Vectors is 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; - Update_Element (Container, Position.Index, Process); + else + Update_Element (Container, Position.Index, Process); + end if; end Update_Element; ----------- diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index a67c156..5b722fe 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -84,12 +84,10 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -355,13 +352,40 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else Count2 := Count_Type'Base (Old_Last - Index + 1); end if; @@ -694,7 +706,6 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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"; - end if; - Delete (Container, Position.Index, Count); - Position := No_Element; + else + Delete (Container, Position.Index, Count); + Position := No_Element; + end if; end Delete; ------------------ @@ -750,14 +759,14 @@ package body Ada.Containers.Vectors is begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; - end if; - Delete (Container, Index_Type'First, Count); + else + Delete (Container, Index_Type'First, Count); + end if; end Delete_First; ----------------- @@ -823,9 +832,9 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (vector is busy)"; - end if; - Container.Elements := null; - Container.Last := No_Index; - Free (X); + else + Container.Elements := null; + Container.Last := No_Index; + Free (X); + end if; end Finalize; procedure Finalize (Object : in out Iterator) is @@ -899,13 +909,42 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; 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 @@ package body Ada.Containers.Vectors is 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; - end; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Is_Sorted; ----------- @@ -1053,23 +1137,38 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is J := J - 1; end loop; + + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + exception + when others => + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + raise; end; end Merge; @@ -1122,7 +1237,28 @@ package body Ada.Containers.Vectors is "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 @@ package body Ada.Containers.Vectors is -- 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is -- 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is -- 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 @@ package body Ada.Containers.Vectors is -- 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 @@ package body Ada.Containers.Vectors 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 @@ -2491,10 +2596,7 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors 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; procedure Previous (Position : in out Cursor) is @@ -2578,9 +2678,9 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is 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)"; - end if; + 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; + Container.Elements.EA (Position.Index) := New_Item; + end if; end Replace_Element; ---------------------- @@ -3126,13 +3224,42 @@ package body Ada.Containers.Vectors is 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 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + 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 @@ package body Ada.Containers.Vectors is 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"; - end if; - Swap (Container, I.Index, J.Index); + else + Swap (Container, I.Index, J.Index); + end if; end Swap; --------------- @@ -3286,13 +3433,11 @@ package body Ada.Containers.Vectors is 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; --------------- diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index 0eeeed6..33a184c 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -364,23 +364,21 @@ package Stand is Any_Type : Entity_Id; -- Used to represent some unknown type. Any_Type is the type of an -- unresolved operator, and it is the type of a node where a type error - -- has been detected. Any_Type plays an important role in avoiding - -- cascaded errors, because it is compatible with all other types, and is - -- propagated to any expression that has a subexpression of Any_Type. - -- When resolving operators, Any_Type is the initial type of the node - -- before any of its candidate interpretations has been examined. If after - -- examining all of them the type is still Any_Type, the node has no - -- possible interpretation and an error can be emitted (and Any_Type will - -- be propagated upwards). - + -- has been detected. Any_Type plays an important role in avoiding cascaded + -- errors, because it is compatible with all other types, and is propagated + -- to any expression that has a subexpression of Any_Type. When resolving + -- operators, Any_Type is the initial type of the node before any of its + -- candidate interpretations has been examined. If after examining all of + -- them the type is still Any_Type, the node has no possible interpretation + -- and an error can be emitted (and Any_Type will be propagated upwards). + -- -- There is one situation in which Any_Type is used to legitimately - -- represent a case where the type is not known pre-resolution, and - -- that is for the N_Raise_Expression node. In this case, the Etype - -- being set to Any_Type is normal and does not represent an error. - -- In particular, it is compatible with the type of any constituend of - -- the enclosing expression, if any. The type is eventually replaced - -- with the type of the context, which plays no role in the resolution - -- of the Raise_Expression. + -- represent a case where the type is not known pre-resolution, and that + -- is for the N_Raise_Expression node. In this case, the Etype being set to + -- Any_Type is normal and does not represent an error. In particular, it is + -- compatible with the type of any constituent of the enclosing expression, + -- if any. The type is eventually replaced with the type of the context, + -- which plays no role in the resolution of the Raise_Expression. Any_Access : Entity_Id; -- Used to resolve the overloaded literal NULL -- 2.7.4