From dc6b9ba2d18ecc4b22e1a23002cea7681d8786bc Mon Sep 17 00:00:00 2001 From: Matthew Heaney Date: Fri, 17 Feb 2006 17:08:48 +0100 Subject: [PATCH] a-convec.ads, [...]: (operator "&"): handle potential overflow for large index types 2006-02-17 Matthew Heaney * a-convec.ads, a-convec.adb: (operator "&"): handle potential overflow for large index types (Insert): removed Contraint_Error when using large index types (Insert_Space): removed Constraint_Error for large index types (Length): moved constraint check from Length to Insert * a-coinve.ads, a-coinve.adb: Stream attribute procedures are declared as not null access. Explicit raise statements now include an exception message. (operator "&"): handle potential overflow for large index types (Insert): removed Contraint_Error when using large index types (Insert_Space): removed Constraint_Error for large index types (Length): moved constraint check from Length to Insert From-SVN: r111197 --- gcc/ada/a-coinve.adb | 391 ++++++++++++++++++++++++++++------------------ gcc/ada/a-coinve.ads | 8 +- gcc/ada/a-convec.adb | 432 ++++++++++++++++++++++++++++++++------------------- gcc/ada/a-convec.ads | 8 +- 4 files changed, 522 insertions(+), 317 deletions(-) diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 2252f78..121ee3f 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -40,6 +40,7 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is type Int is range System.Min_Int .. System.Max_Int; + type UInt is mod System.Max_Binary_Modulus; procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -120,12 +121,18 @@ package body Ada.Containers.Indefinite_Vectors is end if; declare - Last_As_Int : constant Int'Base := -- TODO: handle overflow - Int (Index_Type'First) + Int (LN) + Int (RN) - 1; + N : constant Int'Base := Int (LN) + Int (RN); + Last_As_Int : Int'Base; begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if Int (No_Index) > Int'Last - N then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (No_Index) + N; + + if Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; end if; declare @@ -209,12 +216,17 @@ package body Ada.Containers.Indefinite_Vectors is end if; declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (LN); + Last_As_Int : Int'Base; begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if Int (Index_Type'First) > Int'Last - Int (LN) then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (Index_Type'First) + Int (LN); + + if Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; end if; declare @@ -285,12 +297,17 @@ package body Ada.Containers.Indefinite_Vectors is end if; declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (RN); + Last_As_Int : Int'Base; begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if Int (Index_Type'First) > Int'Last - Int (RN) then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (Index_Type'First) + Int (RN); + + if Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; end if; declare @@ -339,7 +356,7 @@ package body Ada.Containers.Indefinite_Vectors is function "&" (Left, Right : Element_Type) return Vector is begin if Index_Type'First >= Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with "new length is out of range"; end if; declare @@ -348,6 +365,7 @@ package body Ada.Containers.Indefinite_Vectors is subtype ET is Elements_Type (Index_Type'First .. Last); Elements : Elements_Access := new ET; + begin begin Elements (Elements'First) := new Element_Type'(Left); @@ -445,7 +463,7 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with "vector is already at its maximum length"; end if; Insert @@ -465,7 +483,7 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with "vector is already at its maximum length"; end if; Insert @@ -495,7 +513,8 @@ package body Ada.Containers.Indefinite_Vectors is procedure Clear (Container : in out Vector) is begin if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; while Container.Last >= Index_Type'First loop @@ -532,12 +551,12 @@ package body Ada.Containers.Indefinite_Vectors is is begin if Index < Index_Type'First then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range (too small)"; end if; if Index > Container.Last then if Index > Container.Last + 1 then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range (too large)"; end if; return; @@ -548,14 +567,14 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare Index_As_Int : constant Int := Int (Index); Old_Last_As_Int : constant Int := Int (Container.Last); - -- TODO: somewhat vestigial...fix ??? Count1 : constant Int'Base := Int (Count); Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1; N : constant Int'Base := Int'Min (Count1, Count2); @@ -609,13 +628,15 @@ package body Ada.Containers.Indefinite_Vectors is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unchecked_Access - or else Position.Index > Container.Last - then - raise Program_Error; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; end if; Delete (Container, Position.Index, Count); @@ -662,7 +683,8 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare @@ -693,7 +715,7 @@ package body Ada.Containers.Indefinite_Vectors is is begin if Index > Container.Last then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range"; end if; declare @@ -701,7 +723,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if EA = null then - raise Constraint_Error; + raise Constraint_Error with "element is empty"; end if; return EA.all; @@ -711,7 +733,7 @@ package body Ada.Containers.Indefinite_Vectors is function Element (Position : Cursor) return Element_Type is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; return Element (Position.Container.all, Position.Index); @@ -723,7 +745,7 @@ package body Ada.Containers.Indefinite_Vectors is procedure Finalize (Container : in out Vector) is begin - Clear (Container); + Clear (Container); -- Checks busy-bit declare X : Elements_Access := Container.Elements; @@ -743,11 +765,14 @@ package body Ada.Containers.Indefinite_Vectors is Position : Cursor := No_Element) return Cursor is begin - if Position.Container /= null - and then (Position.Container /= Container'Unchecked_Access - or else Position.Index > Container.Last) - then - raise Program_Error; + if Position.Container /= null then + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; end if; for J in Position.Index .. Container.Last loop @@ -888,7 +913,8 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Source.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; Target.Set_Length (Length (Target) + Length (Source)); @@ -963,7 +989,8 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; end if; Sort (Container.Elements (Index_Type'First .. Container.Last)); @@ -996,20 +1023,25 @@ package body Ada.Containers.Indefinite_Vectors is is N : constant Int := Int (Count); + First : constant Int := Int (Index_Type'First); New_Last_As_Int : Int'Base; New_Last : Index_Type; + New_Length : UInt; + Max_Length : constant UInt := UInt (Count_Type'Last); Dst : Elements_Access; begin if Before < Index_Type'First then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too large)"; end if; if Count = 0 then @@ -1020,17 +1052,28 @@ package body Ada.Containers.Indefinite_Vectors is Old_Last_As_Int : constant Int := Int (Container.Last); begin + if Old_Last_As_Int > Int'Last - N then -- see a-convec.adb ??? + raise Constraint_Error with "new length is out of range"; + end if; + New_Last_As_Int := Old_Last_As_Int + N; - if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if New_Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Length := UInt (New_Last_As_Int - First + 1); + + if New_Length > Max_Length then + raise Constraint_Error with "new length is out of range"; end if; New_Last := Index_Type (New_Last_As_Int); end; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; if Container.Elements = null then @@ -1050,6 +1093,7 @@ package body Ada.Containers.Indefinite_Vectors is if New_Last <= Container.Elements'Last then declare E : Elements_Type renames Container.Elements.all; + begin if Before <= Container.Last then declare @@ -1058,16 +1102,18 @@ package body Ada.Containers.Indefinite_Vectors is Index : constant Index_Type := Index_Type (Index_As_Int); - J : Index_Type'Base := Before; + J : Index_Type'Base; begin E (Index .. New_Last) := E (Before .. Container.Last); Container.Last := New_Last; + J := Before; while J < Index loop E (J) := new Element_Type'(New_Item); J := J + 1; end loop; + exception when others => E (J .. Index - 1) := (others => null); @@ -1086,35 +1132,40 @@ package body Ada.Containers.Indefinite_Vectors is end if; declare - First : constant Int := Int (Index_Type'First); - New_Size : constant Int'Base := New_Last_As_Int - First + 1; - Size : Int'Base := Int'Max (1, Container.Elements'Length); + C, CC : UInt; begin - while Size < New_Size loop - if Size > Int'Last / 2 then - Size := Int'Last; + C := UInt'Max (1, Container.Elements'Length); + while C < New_Length loop + if C > UInt'Last / 2 then + C := UInt'Last; exit; end if; - Size := 2 * Size; + C := 2 * C; end loop; - -- TODO: The following calculations aren't quite right, since - -- there will be overflow if Index_Type'Range is very large - -- (e.g. this package is instantiated with a 64-bit integer). - -- END TODO. + if C > Max_Length then + C := Max_Length; + end if; - declare - Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; - begin - if Size > Max_Size then - Size := Max_Size; - end if; - end; + if Index_Type'First <= 0 + and then Index_Type'Last >= 0 + then + CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; + + else + CC := UInt (Int (Index_Type'Last) - First + 1); + end if; + + if C > CC then + C := CC; + end if; declare - Dst_Last : constant Index_Type := Index_Type (First + Size - 1); + Dst_Last : constant Index_Type := + Index_Type (First + UInt'Pos (C) - Int'(1)); + begin Dst := new Elements_Type (Index_Type'First .. Dst_Last); end; @@ -1172,13 +1223,15 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before < Index_Type'First then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too large)"; end if; if N = 0 then @@ -1268,7 +1321,7 @@ package body Ada.Containers.Indefinite_Vectors is if Before.Container /= null and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Is_Empty (New_Item) then @@ -1279,7 +1332,8 @@ package body Ada.Containers.Indefinite_Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1303,7 +1357,7 @@ package body Ada.Containers.Indefinite_Vectors is if Before.Container /= null and then Before.Container /= Vector_Access'(Container'Unchecked_Access) then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Is_Empty (New_Item) then @@ -1322,7 +1376,8 @@ package body Ada.Containers.Indefinite_Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1346,9 +1401,9 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Count = 0 then @@ -1359,7 +1414,8 @@ package body Ada.Containers.Indefinite_Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1382,9 +1438,9 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Count = 0 then @@ -1403,7 +1459,8 @@ package body Ada.Containers.Indefinite_Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1428,20 +1485,25 @@ package body Ada.Containers.Indefinite_Vectors is is N : constant Int := Int (Count); + First : constant Int := Int (Index_Type'First); New_Last_As_Int : Int'Base; New_Last : Index_Type; + New_Length : UInt; + Max_Length : constant UInt := UInt (Count_Type'Last); Dst : Elements_Access; begin if Before < Index_Type'First then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too large)"; end if; if Count = 0 then @@ -1452,17 +1514,28 @@ package body Ada.Containers.Indefinite_Vectors is Old_Last_As_Int : constant Int := Int (Container.Last); begin + if Old_Last_As_Int > Int'Last - N then -- see a-convec.adb ??? + raise Constraint_Error with "new length is out of range"; + end if; + New_Last_As_Int := Old_Last_As_Int + N; - if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if New_Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Length := UInt (New_Last_As_Int - First + 1); + + if New_Length > Max_Length then + raise Constraint_Error with "new length is out of range"; end if; New_Last := Index_Type (New_Last_As_Int); end; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; if Container.Elements = null then @@ -1497,35 +1570,40 @@ package body Ada.Containers.Indefinite_Vectors is end if; declare - First : constant Int := Int (Index_Type'First); - New_Size : constant Int'Base := New_Last_As_Int - First + 1; - Size : Int'Base := Int'Max (1, Container.Elements'Length); + C, CC : UInt; begin - while Size < New_Size loop - if Size > Int'Last / 2 then - Size := Int'Last; + C := UInt'Max (1, Container.Elements'Length); + while C < New_Length loop + if C > UInt'Last / 2 then + C := UInt'Last; exit; end if; - Size := 2 * Size; + C := 2 * C; end loop; - -- TODO: The following calculations aren't quite right, since - -- there will be overflow if Index_Type'Range is very large - -- (e.g. this package is instantiated with a 64-bit integer). - -- END TODO. + if C > Max_Length then + C := Max_Length; + end if; - declare - Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; - begin - if Size > Max_Size then - Size := Max_Size; - end if; - end; + if Index_Type'First <= 0 + and then Index_Type'Last >= 0 + then + CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; + + else + CC := UInt (Int (Index_Type'Last) - First + 1); + end if; + + if C > CC then + C := CC; + end if; declare - Dst_Last : constant Index_Type := Index_Type (First + Size - 1); + Dst_Last : constant Index_Type := + Index_Type (First + UInt'Pos (C) - 1); + begin Dst := new Elements_Type (Index_Type'First .. Dst_Last); end; @@ -1570,9 +1648,9 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Count = 0 then @@ -1591,7 +1669,8 @@ package body Ada.Containers.Indefinite_Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1682,10 +1761,6 @@ package body Ada.Containers.Indefinite_Vectors is N : constant Int'Base := L - F + 1; begin - if N > Count_Type'Pos (Count_Type'Last) then - raise Constraint_Error; - end if; - return Count_Type (N); end Length; @@ -1703,10 +1778,11 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Source.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (Source is busy)"; end if; - Clear (Target); + Clear (Target); -- Checks busy-bit declare Target_Elements : constant Elements_Access := Target.Elements; @@ -1819,11 +1895,11 @@ package body Ada.Containers.Indefinite_Vectors is begin if Index > Container.Last then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range"; end if; if V.Elements (Index) = null then - raise Constraint_Error; + raise Constraint_Error with "element is null"; end if; B := B + 1; @@ -1848,7 +1924,7 @@ package body Ada.Containers.Indefinite_Vectors is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; Query_Element (Position.Container.all, Position.Index, Process); @@ -1859,7 +1935,7 @@ package body Ada.Containers.Indefinite_Vectors is ---------- procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : out Vector) is Length : Count_Type'Base; @@ -1891,11 +1967,11 @@ package body Ada.Containers.Indefinite_Vectors is end Read; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Position : out Cursor) is begin - raise Program_Error; + raise Program_Error with "attempt to stream vector cursor"; end Read; --------------------- @@ -1909,11 +1985,12 @@ package body Ada.Containers.Indefinite_Vectors is is begin if Index > Container.Last then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range"; end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; end if; declare @@ -1931,11 +2008,11 @@ package body Ada.Containers.Indefinite_Vectors is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with "Position cursor denotes wrong container"; end if; Replace_Element (Container, Position.Index, New_Item); @@ -1963,7 +2040,8 @@ package body Ada.Containers.Indefinite_Vectors is elsif N < Container.Elements'Length then if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare @@ -1994,7 +2072,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + raise Constraint_Error with "new length is out of range"; end if; declare @@ -2014,7 +2092,8 @@ package body Ada.Containers.Indefinite_Vectors is if Capacity <= N then if N < Container.Elements'Length then if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare @@ -2043,7 +2122,8 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare @@ -2052,7 +2132,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + raise Constraint_Error with "new length is out of range"; end if; declare @@ -2093,15 +2173,18 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; end if; declare - I : Index_Type := Index_Type'First; - J : Index_Type := Container.Last; + I : Index_Type; + J : Index_Type; E : Elements_Type renames Container.Elements.all; begin + I := Index_Type'First; + J := Container.Last; while I < J loop declare EI : constant Element_Access := E (I); @@ -2132,7 +2215,7 @@ package body Ada.Containers.Indefinite_Vectors is if Position.Container /= null and then Position.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Position cursor denotes wrong container"; end if; if Position.Container = null @@ -2226,7 +2309,8 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; if Length < N then @@ -2267,10 +2351,12 @@ package body Ada.Containers.Indefinite_Vectors is I, J : Index_Type) is begin - if I > Container.Last - or else J > Container.Last - then - raise Constraint_Error; + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; end if; if I = J then @@ -2278,7 +2364,8 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; end if; declare @@ -2298,16 +2385,20 @@ package body Ada.Containers.Indefinite_Vectors is I, J : Cursor) is begin - if I.Container = null - or else J.Container = null - then - raise Constraint_Error; + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access - or else J.Container /= Container'Unrestricted_Access - then - raise Program_Error; + if J.Container = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; + end if; + + if J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; end if; Swap (Container, I.Index, J.Index); @@ -2364,7 +2455,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + raise Constraint_Error with "Length is out of range"; end if; Last := Index_Type (Last_As_Int); @@ -2391,7 +2482,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + raise Constraint_Error with "Length is out of range"; end if; Last := Index_Type (Last_As_Int); @@ -2433,11 +2524,11 @@ package body Ada.Containers.Indefinite_Vectors is begin if Index > Container.Last then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range"; end if; if Container.Elements (Index) = null then - raise Constraint_Error; + raise Constraint_Error with "element is null"; end if; B := B + 1; @@ -2463,11 +2554,11 @@ package body Ada.Containers.Indefinite_Vectors is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with "Position cursor denotes wrong container"; end if; Update_Element (Container, Position.Index, Process); @@ -2478,7 +2569,7 @@ package body Ada.Containers.Indefinite_Vectors is ----------- procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : Vector) is N : constant Count_Type := Length (Container); @@ -2499,7 +2590,7 @@ package body Ada.Containers.Indefinite_Vectors is -- There's another way to do this. Instead a separate -- Boolean for each element, you could write a Boolean -- followed by a count of how many nulls or non-nulls - -- follow in the array. + -- follow in the array. ??? if E (Indx) = null then Boolean'Write (Stream, False); @@ -2512,11 +2603,11 @@ package body Ada.Containers.Indefinite_Vectors is end Write; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Position : Cursor) is begin - raise Program_Error; + raise Program_Error with "attempt to stream vector cursor"; end Write; end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index 822e797..e5587f1 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -324,13 +324,13 @@ private use Ada.Streams; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : Vector); for Vector'Write use Write; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : out Vector); for Vector'Read use Read; @@ -346,13 +346,13 @@ private end record; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Position : Cursor); for Cursor'Write use Write; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Position : out Cursor); for Cursor'Read use Read; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 2a60303..ecffd32 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2006 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -41,6 +41,7 @@ with System; use type System.Address; package body Ada.Containers.Vectors is type Int is range System.Min_Int .. System.Max_Int; + type UInt is mod System.Max_Binary_Modulus; procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -86,12 +87,18 @@ package body Ada.Containers.Vectors is end if; declare - Last_As_Int : constant Int'Base := -- TODO: handle overflow - Int (Index_Type'First) + Int (LN) + Int (RN) - 1; + N : constant Int'Base := Int (LN) + Int (RN); + Last_As_Int : Int'Base; begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if Int (No_Index) > Int'Last - N then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (No_Index) + N; + + if Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; end if; declare @@ -130,12 +137,17 @@ package body Ada.Containers.Vectors is end if; declare - Last_As_Int : constant Int'Base := -- TODO: handle overflow - Int (Index_Type'First) + Int (LN); + Last_As_Int : Int'Base; begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if Int (Index_Type'First) > Int'Last - Int (LN) then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (Index_Type'First) + Int (LN); + + if Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; end if; declare @@ -172,12 +184,17 @@ package body Ada.Containers.Vectors is end if; declare - Last_As_Int : constant Int'Base := -- TODO: handle overflow - Int (Index_Type'First) + Int (RN); + Last_As_Int : Int'Base; begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if Int (Index_Type'First) > Int'Last - Int (RN) then + raise Constraint_Error with "new length is out of range"; + end if; + + Last_As_Int := Int (Index_Type'First) + Int (RN); + + if Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; end if; declare @@ -196,10 +213,10 @@ package body Ada.Containers.Vectors is end; end "&"; - function "&" (Left, Right : Element_Type) return Vector is + function "&" (Left, Right : Element_Type) return Vector is begin if Index_Type'First >= Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with "new length is out of range"; end if; declare @@ -273,7 +290,7 @@ package body Ada.Containers.Vectors is end if; if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with "vector is already at its maximum length"; end if; Insert @@ -293,7 +310,7 @@ package body Ada.Containers.Vectors is end if; if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with "vector is already at its maximum length"; end if; Insert @@ -323,7 +340,8 @@ package body Ada.Containers.Vectors is procedure Clear (Container : in out Vector) is begin if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; Container.Last := No_Index; @@ -352,12 +370,12 @@ package body Ada.Containers.Vectors is is begin if Index < Index_Type'First then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range (too small)"; end if; if Index > Container.Last then if Index > Container.Last + 1 then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range (too large)"; end if; return; @@ -368,7 +386,8 @@ package body Ada.Containers.Vectors is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare @@ -409,13 +428,15 @@ package body Ada.Containers.Vectors is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access - or else Position.Index > Container.Last - then - raise Program_Error; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; end if; Delete (Container, Position.Index, Count); @@ -470,7 +491,8 @@ package body Ada.Containers.Vectors is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; Index := Int'Base (Container.Last) - Int'Base (Count); @@ -492,7 +514,7 @@ package body Ada.Containers.Vectors is is begin if Index > Container.Last then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range"; end if; return Container.Elements (Index); @@ -501,7 +523,7 @@ package body Ada.Containers.Vectors is function Element (Position : Cursor) return Element_Type is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; return Element (Position.Container.all, Position.Index); @@ -516,7 +538,8 @@ package body Ada.Containers.Vectors is begin if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; Container.Elements := null; @@ -534,11 +557,14 @@ package body Ada.Containers.Vectors is Position : Cursor := No_Element) return Cursor is begin - if Position.Container /= null - and then (Position.Container /= Container'Unrestricted_Access - or else Position.Index > Container.Last) - then - raise Program_Error; + if Position.Container /= null then + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; end if; for J in Position.Index .. Container.Last loop @@ -653,7 +679,8 @@ package body Ada.Containers.Vectors is end if; if Source.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; Target.Set_Length (Length (Target) + Length (Source)); @@ -708,7 +735,8 @@ package body Ada.Containers.Vectors is end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; end if; Sort (Container.Elements (Index_Type'First .. Container.Last)); @@ -741,20 +769,25 @@ package body Ada.Containers.Vectors is is N : constant Int := Count_Type'Pos (Count); + First : constant Int := Int (Index_Type'First); New_Last_As_Int : Int'Base; New_Last : Index_Type; + New_Length : UInt; + Max_Length : constant UInt := UInt (Count_Type'Last); Dst : Elements_Access; begin if Before < Index_Type'First then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too large)"; end if; if Count = 0 then @@ -762,22 +795,59 @@ package body Ada.Containers.Vectors is end if; declare - Old_Last : constant Extended_Index := Container.Last; - - Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last); + Old_Last_As_Int : constant Int := Int (Container.Last); begin + if Old_Last_As_Int > Int'Last - N then + + -- ??? + + -- The purpose of this test is to ensure that the calculation of + -- New_Last_As_Int (see below) doesn't overflow. + + -- This isn't quite right, since the only requirements are: + -- V.Last <= Index_Type'Last + -- V.Length <= Count_Type'Last + + -- To be strictly correct there's no (explicit) requirement that + -- Old_Last + N <= Int'Last + + -- However, there might indeed be an implied requirement, since + -- machine constraints dictate that + -- Index_Type'Last <= Int'Last + -- and so this check is perhaps proper after all. + + -- This shouldn't be an issue in practice, since it can only + -- happen when N is very large, or V.Last is near Int'Last. + + -- N isn't likely to be large, since there's probably not enough + -- storage. + + -- V.Last would only be large if IT'First is very large (and + -- V.Length has some "normal" size). But typically IT'First is + -- either 0 or 1. + + raise Constraint_Error with "new length is out of range"; + end if; + New_Last_As_Int := Old_Last_As_Int + N; - if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if New_Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Length := UInt (New_Last_As_Int - First + Int'(1)); + + if New_Length > Max_Length then + raise Constraint_Error with "new length is out of range"; end if; New_Last := Index_Type (New_Last_As_Int); end; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; if Container.Elements = null then @@ -795,6 +865,7 @@ package body Ada.Containers.Vectors is if New_Last <= Container.Elements'Last then declare E : Elements_Type renames Container.Elements.all; + begin if Before <= Container.Last then declare @@ -820,35 +891,40 @@ package body Ada.Containers.Vectors is end if; declare - First : constant Int := Int (Index_Type'First); - New_Size : constant Int'Base := New_Last_As_Int - First + 1; - Size : Int'Base := Int'Max (1, Container.Elements'Length); + C, CC : UInt; begin - while Size < New_Size loop - if Size > Int'Last / 2 then - Size := Int'Last; + C := UInt'Max (1, Container.Elements'Length); + while C < New_Length loop + if C > UInt'Last / 2 then + C := UInt'Last; exit; end if; - Size := 2 * Size; + C := 2 * C; end loop; - -- TODO: The following calculations aren't quite right, since - -- there will be overflow if Index_Type'Range is very large - -- (e.g. this package is instantiated with a 64-bit integer). - -- END TODO. + if C > Max_Length then + C := Max_Length; + end if; - declare - Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; - begin - if Size > Max_Size then - Size := Max_Size; - end if; - end; + if Index_Type'First <= 0 + and then Index_Type'Last >= 0 + then + CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; + + else + CC := UInt (Int (Index_Type'Last) - First + 1); + end if; + + if C > CC then + C := CC; + end if; declare - Dst_Last : constant Index_Type := Index_Type (First + Size - 1); + Dst_Last : constant Index_Type := + Index_Type (First + UInt'Pos (C) - 1); + begin Dst := new Elements_Type (Index_Type'First .. Dst_Last); end; @@ -900,13 +976,15 @@ package body Ada.Containers.Vectors is begin if Before < Index_Type'First then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too large)"; end if; if N = 0 then @@ -984,9 +1062,9 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Is_Empty (New_Item) then @@ -997,7 +1075,8 @@ package body Ada.Containers.Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1019,9 +1098,9 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Is_Empty (New_Item) then @@ -1040,7 +1119,8 @@ package body Ada.Containers.Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1064,9 +1144,9 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Count = 0 then @@ -1077,7 +1157,8 @@ package body Ada.Containers.Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1100,9 +1181,9 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Count = 0 then @@ -1121,7 +1202,8 @@ package body Ada.Containers.Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1171,20 +1253,25 @@ package body Ada.Containers.Vectors is is N : constant Int := Count_Type'Pos (Count); + First : constant Int := Int (Index_Type'First); New_Last_As_Int : Int'Base; New_Last : Index_Type; + New_Length : UInt; + Max_Length : constant UInt := UInt (Count_Type'Last); Dst : Elements_Access; begin if Before < Index_Type'First then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then - raise Constraint_Error; + raise Constraint_Error with + "Before index is out of range (too large)"; end if; if Count = 0 then @@ -1192,22 +1279,31 @@ package body Ada.Containers.Vectors is end if; declare - Old_Last : constant Extended_Index := Container.Last; - - Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last); + Old_Last_As_Int : constant Int := Int (Container.Last); begin + if Old_Last_As_Int > Int'Last - N then -- see Insert ??? + raise Constraint_Error with "new length is out of range"; + end if; + New_Last_As_Int := Old_Last_As_Int + N; - if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + if New_Last_As_Int > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + New_Length := UInt (New_Last_As_Int - First + Int'(1)); + + if New_Length > Max_Length then + raise Constraint_Error with "new length is out of range"; end if; New_Last := Index_Type (New_Last_As_Int); end; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; if Container.Elements = null then @@ -1240,35 +1336,40 @@ package body Ada.Containers.Vectors is end if; declare - First : constant Int := Int (Index_Type'First); - New_Size : constant Int'Base := New_Last_As_Int - First + 1; - Size : Int'Base := Int'Max (1, Container.Elements'Length); + C, CC : UInt; begin - while Size < New_Size loop - if Size > Int'Last / 2 then - Size := Int'Last; + C := UInt'Max (1, Container.Elements'Length); + while C < New_Length loop + if C > UInt'Last / 2 then + C := UInt'Last; exit; end if; - Size := 2 * Size; + C := 2 * C; end loop; - -- TODO: The following calculations aren't quite right, since - -- there will be overflow if Index_Type'Range is very large - -- (e.g. this package is instantiated with a 64-bit integer). - -- END TODO. + if C > Max_Length then + C := Max_Length; + end if; - declare - Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; - begin - if Size > Max_Size then - Size := Max_Size; - end if; - end; + if Index_Type'First <= 0 + and then Index_Type'Last >= 0 + then + CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; + + else + CC := UInt (Int (Index_Type'Last) - First + 1); + end if; + + if C > CC then + C := CC; + end if; declare - Dst_Last : constant Index_Type := Index_Type (First + Size - 1); + Dst_Last : constant Index_Type := + Index_Type (First + UInt'Pos (C) - 1); + begin Dst := new Elements_Type (Index_Type'First .. Dst_Last); end; @@ -1317,9 +1418,9 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Before cursor denotes wrong container"; end if; if Count = 0 then @@ -1338,7 +1439,8 @@ package body Ada.Containers.Vectors is or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then - raise Constraint_Error; + raise Constraint_Error with + "vector is already at its maximum length"; end if; Index := Container.Last + 1; @@ -1429,10 +1531,6 @@ package body Ada.Containers.Vectors is N : constant Int'Base := L - F + 1; begin - if N > Count_Type'Pos (Count_Type'Last) then - raise Constraint_Error; - end if; - return Count_Type (N); end Length; @@ -1450,11 +1548,13 @@ package body Ada.Containers.Vectors is end if; if Target.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (Target is busy)"; end if; if Source.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (Source is busy)"; end if; declare @@ -1568,7 +1668,7 @@ package body Ada.Containers.Vectors is begin if Index > Container.Last then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range"; end if; B := B + 1; @@ -1593,7 +1693,7 @@ package body Ada.Containers.Vectors is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; Query_Element (Position.Container.all, Position.Index, Process); @@ -1604,7 +1704,7 @@ package body Ada.Containers.Vectors is ---------- procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : out Vector) is Length : Count_Type'Base; @@ -1627,11 +1727,11 @@ package body Ada.Containers.Vectors is end Read; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Position : out Cursor) is begin - raise Program_Error; + raise Program_Error with "attempt to stream vector cursor"; end Read; --------------------- @@ -1645,11 +1745,12 @@ package body Ada.Containers.Vectors is is begin if Index > Container.Last then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range"; end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; end if; Container.Elements (Index) := New_Item; @@ -1662,11 +1763,11 @@ package body Ada.Containers.Vectors is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with "Position cursor denotes wrong container"; end if; Replace_Element (Container, Position.Index, New_Item); @@ -1694,7 +1795,8 @@ package body Ada.Containers.Vectors is elsif N < Container.Elements'Length then if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare @@ -1725,7 +1827,7 @@ package body Ada.Containers.Vectors is begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + raise Constraint_Error with "new length is out of range"; end if; declare @@ -1733,6 +1835,7 @@ package body Ada.Containers.Vectors is subtype Array_Subtype is Elements_Type (Index_Type'First .. Last); + begin Container.Elements := new Array_Subtype; end; @@ -1744,7 +1847,8 @@ package body Ada.Containers.Vectors is if Capacity <= N then if N < Container.Elements'Length then if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare @@ -1774,7 +1878,8 @@ package body Ada.Containers.Vectors is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; declare @@ -1783,7 +1888,7 @@ package body Ada.Containers.Vectors is begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + raise Constraint_Error with "new length is out of range"; end if; declare @@ -1832,15 +1937,17 @@ package body Ada.Containers.Vectors is end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; end if; declare - I : Index_Type := Index_Type'First; - J : Index_Type := Container.Last; - E : Elements_Type renames Container.Elements.all; + I, J : Index_Type; + E : Elements_Type renames Container.Elements.all; begin + I := Index_Type'First; + J := Container.Last; while I < J loop declare EI : constant Element_Type := E (I); @@ -1869,10 +1976,9 @@ package body Ada.Containers.Vectors is begin if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) + and then Position.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with "Position cursor denotes wrong container"; end if; if Position.Container = null @@ -1957,7 +2063,8 @@ package body Ada.Containers.Vectors is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; end if; if Length > Capacity (Container) then @@ -1978,10 +2085,12 @@ package body Ada.Containers.Vectors is procedure Swap (Container : in out Vector; I, J : Index_Type) is begin - if I > Container.Last - or else J > Container.Last - then - raise Constraint_Error; + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; end if; if I = J then @@ -1989,7 +2098,8 @@ package body Ada.Containers.Vectors is end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (vector is locked)"; end if; declare @@ -2006,16 +2116,20 @@ package body Ada.Containers.Vectors is procedure Swap (Container : in out Vector; I, J : Cursor) is begin - if I.Container = null - or else J.Container = null - then - raise Constraint_Error; + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access - or else J.Container /= Container'Unrestricted_Access - then - raise Program_Error; + if J.Container = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; + end if; + + if J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; end if; Swap (Container, I.Index, J.Index); @@ -2072,13 +2186,13 @@ package body Ada.Containers.Vectors is begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + raise Constraint_Error with "Length is out of range"; end if; Last := Index_Type (Last_As_Int); Elements := new Elements_Type (Index_Type'First .. Last); - return (Controlled with Elements, Last, 0, 0); + return Vector'(Controlled with Elements, Last, 0, 0); end; end To_Vector; @@ -2099,13 +2213,13 @@ package body Ada.Containers.Vectors is begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error; + raise Constraint_Error with "Length is out of range"; end if; Last := Index_Type (Last_As_Int); Elements := new Elements_Type'(Index_Type'First .. Last => New_Item); - return (Controlled with Elements, Last, 0, 0); + return Vector'(Controlled with Elements, Last, 0, 0); end; end To_Vector; @@ -2123,7 +2237,7 @@ package body Ada.Containers.Vectors is begin if Index > Container.Last then - raise Constraint_Error; + raise Constraint_Error with "Index is out of range"; end if; B := B + 1; @@ -2149,11 +2263,11 @@ package body Ada.Containers.Vectors is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with "Position cursor denotes wrong container"; end if; Update_Element (Container, Position.Index, Process); @@ -2164,7 +2278,7 @@ package body Ada.Containers.Vectors is ----------- procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : Vector) is begin @@ -2176,11 +2290,11 @@ package body Ada.Containers.Vectors is end Write; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Position : Cursor) is begin - raise Program_Error; + raise Program_Error with "attempt to stream vector cursor"; end Write; end Ada.Containers.Vectors; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 5b268b5..4fa0281 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -332,13 +332,13 @@ private use Ada.Streams; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : Vector); for Vector'Write use Write; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : out Vector); for Vector'Read use Read; @@ -354,13 +354,13 @@ private end record; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Position : Cursor); for Cursor'Write use Write; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Position : out Cursor); for Cursor'Read use Read; -- 2.7.4