From patchwork Mon Jun 14 08:21:07 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 55486 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 8BF40B7D8A for ; Mon, 14 Jun 2010 18:21:24 +1000 (EST) Received: (qmail 18578 invoked by alias); 14 Jun 2010 08:21:21 -0000 Received: (qmail 18534 invoked by uid 22791); 14 Jun 2010 08:21:10 -0000 X-SWARE-Spam-Status: No, hits=-0.5 required=5.0 tests=AWL, BAYES_50, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 14 Jun 2010 08:20:58 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id E27B1CB021F; Mon, 14 Jun 2010 10:21:00 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id AD+IOLUq3cch; Mon, 14 Jun 2010 10:21:00 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id CB86ECB021C; Mon, 14 Jun 2010 10:21:00 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id CC9E8D8808; Mon, 14 Jun 2010 10:21:07 +0200 (CEST) Date: Mon, 14 Jun 2010 10:21:07 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Matthew Heaney Subject: [Ada] prevent overflow for index subtypes near extrema of base range Message-ID: <20100614082107.GA11103@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Manipulation of a vector container object must satify two constraints: the new length cannot exceed Count_Type'Last, and the new last index value cannot exceed Index_Type'Last. Checking that these constraints are satified requires computing sums that lie outside the range of the subtype. If the generic formal subtype Index_Type is declared near the end of its base type, then the addition can overflow the base range. Similarly, if subtype Index_Type is declared near the beginning of its base type, then subtraction can overflow. This patch prevents overflow from occurring. Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-14 Matthew Heaney * a-coinve.adb, a-convec.adb (operator "&"): Check both that new length and new last satisfy constraints. (Delete_Last): prevent overflow for subtraction of index values (To_Vector): prevent overflow for addition of index values Index: a-coinve.adb =================================================================== --- a-coinve.adb (revision 160705) +++ a-coinve.adb (working copy) @@ -117,22 +117,63 @@ package body Ada.Containers.Indefinite_V end if; declare - N : constant Int'Base := Int (LN) + Int (RN); - Last_As_Int : Int'Base; + N : constant Int'Base := Int (LN) + Int (RN); + J : Int'Base; begin - if Int (No_Index) > Int'Last - N then + -- There are two constraints we need to satisfy. The first constraint + -- is that a container cannot have more than Count_Type'Last + -- elements, so we must check the sum of the combined lengths. (It + -- would be rare for vectors to have such a large number of elements, + -- so we would normally expect this first check to succeed.) The + -- second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. + + if N > Count_Type'Pos (Count_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; - Last_As_Int := Int (No_Index) + N; + -- We now check whether the new length would create a Last index + -- value greater than Index_Type'Last. This calculation requires + -- care, because overflow can occur when Index_Type'First is near the + -- end of the range of Int. - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + if Index_Type'First <= 0 then + + -- Compute the potential Last index value in the normal way, using + -- Int as the type in which to perform intermediate + -- calculations. Int is a 64-bit type, and Count_Type is a 32-bit + -- type, so no overflow can occur. + + J := Int (Index_Type'First - 1) + N; + + if J > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + else + -- If Index_Type'First is within N of Int'Last, then overflow + -- would occur if we simply computed Last directly. So instead of + -- computing Last, and then determining whether its value is + -- greater than Index_Type'Last (as we do above), we work + -- backwards by computing the potential First index value, and + -- then checking whether that value is less than Index_Type'First. + + J := Int (Index_Type'Last) - N + 1; + + if J < Int (Index_Type'First) then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We have determined that Length would not create a Last index + -- value outside of the range of Index_Type, so we can now safely + -- compute its value. + + J := Int (Index_Type'First - 1) + N; end if; declare - Last : constant Index_Type := Index_Type (Last_As_Int); + Last : constant Index_Type := Index_Type (J); LE : Elements_Array renames Left.Elements.EA (Index_Type'First .. Left.Last); @@ -189,10 +230,8 @@ package body Ada.Containers.Indefinite_V end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is - LN : constant Count_Type := Length (Left); - begin - if LN = 0 then + if Left.Is_Empty then declare Elements : Elements_Access := new Elements_Type (Index_Type'First); @@ -209,70 +248,65 @@ package body Ada.Containers.Indefinite_V end; end if; - declare - Last_As_Int : Int'Base; - - begin - 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); + -- We must satisfy two constraints: the new length cannot exceed + -- Count_Type'Last, and the new Last index cannot exceed + -- Index_Type'Last. - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + if Left.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + if Left.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + declare + Last : constant Index_Type := Left.Last + 1; - Elements : Elements_Access := - new Elements_Type (Last); + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); - begin - for I in LE'Range loop - begin - if LE (I) /= null then - Elements.EA (I) := new Element_Type'(LE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; + Elements : Elements_Access := + new Elements_Type (Last); + begin + for I in LE'Range loop begin - Elements.EA (Last) := new Element_Type'(Right); + if LE (I) /= null then + Elements.EA (I) := new Element_Type'(LE (I).all); + end if; exception when others => - for J in Index_Type'First .. Last - 1 loop + for J in Index_Type'First .. I - 1 loop Free (Elements.EA (J)); end loop; Free (Elements); raise; end; + end loop; - return (Controlled with Elements, Last, 0, 0); + begin + Elements.EA (Last) := new Element_Type'(Right); + + exception + when others => + for J in Index_Type'First .. Last - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; end; + + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is - RN : constant Count_Type := Length (Right); - begin - if RN = 0 then + if Right.Is_Empty then declare Elements : Elements_Access := new Elements_Type (Index_Type'First); @@ -289,61 +323,58 @@ package body Ada.Containers.Indefinite_V end; end if; - declare - Last_As_Int : Int'Base; + -- We must satisfy two constraints: the new length cannot exceed + -- Count_Type'Last, and the new Last index cannot exceed + -- Index_Type'Last. - begin - 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 Right.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + if Right.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + declare + Last : constant Index_Type := Right.Last + 1; - 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 : Elements_Access := - new Elements_Type (Last); + Elements : Elements_Access := + new Elements_Type (Last); - I : Index_Type'Base := Index_Type'First; + I : Index_Type'Base := Index_Type'First; + begin begin + Elements.EA (I) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; + + for RI in RE'Range loop + I := I + 1; + begin - Elements.EA (I) := new Element_Type'(Left); + if RE (RI) /= null then + Elements.EA (I) := new Element_Type'(RE (RI).all); + end if; + exception when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + Free (Elements); raise; end; + end loop; - for RI in RE'Range loop - I := I + 1; - - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Last, 0, 0); - end; + return (Controlled with Elements, Last, 0, 0); end; end "&"; @@ -2498,73 +2529,145 @@ package body Ada.Containers.Indefinite_V --------------- function To_Vector (Length : Count_Type) return Vector is + Index : Int'Base; + Last : Index_Type; + Elements : Elements_Access; + begin if Length = 0 then return Empty_Vector; end if; - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - Elements : Elements_Access; + -- We create a vector object with a capacity that matches the specified + -- Length. We do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index), so we must check whether the specified Length would create a + -- Last index value greater than Index_Type'Last. This calculation + -- requires care, because overflow can occur when Index_Type'First is + -- near the end of the range of Int. + + if Index_Type'First <= 0 then + -- Compute the potential Last index value in the normal way, using + -- Int as the type in which to perform intermediate calculations. Int + -- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow + -- can occur. + Index := Int (Index_Type'First - 1) + Int (Length); - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + if Index > Int (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; - Last := Index_Type (Last_As_Int); - Elements := new Elements_Type (Last); + else + -- If Index_Type'First is within Length of Int'Last, then overflow + -- would occur if we simply computed Last directly. So instead of + -- computing Last, and then determining whether its value is greater + -- than Index_Type'Last, we work backwards by computing the potential + -- First index value, and then checking whether that value is less + -- than Index_Type'First. + Index := Int (Index_Type'Last) - Int (Length) + 1; - return (Controlled with Elements, Last, 0, 0); - end; + if Index < Int (Index_Type'First) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that Length would not create a Last index value + -- outside of the range of Index_Type, so we can now safely compute + -- its value. + Index := Int (Index_Type'First - 1) + Int (Length); + end if; + + Last := Index_Type (Index); + Elements := new Elements_Type (Last); + + return Vector'(Controlled with Elements, Last, 0, 0); end To_Vector; function To_Vector (New_Item : Element_Type; Length : Count_Type) return Vector is + Index : Int'Base; + Last : Index_Type; + Elements : Elements_Access; + begin if Length = 0 then return Empty_Vector; end if; - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type'Base; - Elements : Elements_Access; + -- We create a vector object with a capacity that matches the specified + -- Length. We do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index), so we must check whether the specified Length would create a + -- Last index value greater than Index_Type'Last. This calculation + -- requires care, because overflow can occur when Index_Type'First is + -- near the end of the range of Int. + + if Index_Type'First <= 0 then + -- Compute the potential Last index value in the normal way, using + -- Int as the type in which to perform intermediate calculations. Int + -- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow + -- can occur. + Index := Int (Index_Type'First - 1) + Int (Length); - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + if Index > Int (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; - Last := Index_Type (Last_As_Int); - Elements := new Elements_Type (Last); - - Last := Index_Type'First; + else + -- If Index_Type'First is within Length of Int'Last, then overflow + -- would occur if we simply computed Last directly. So instead of + -- computing Last, and then determining whether its value is greater + -- than Index_Type'Last, we work backwards by computing the potential + -- First index value, and then checking whether that value is less + -- than Index_Type'First. + Index := Int (Index_Type'Last) - Int (Length) + 1; - begin - loop - Elements.EA (Last) := new Element_Type'(New_Item); - exit when Last = Elements.Last; - Last := Last + 1; - end loop; + if Index < Int (Index_Type'First) then + raise Constraint_Error with "Length is out of range"; + end if; - exception - when others => - for J in Index_Type'First .. Last - 1 loop - Free (Elements.EA (J)); - end loop; + -- We have determined that Length would not create a Last index value + -- outside of the range of Index_Type, so we can now safely compute + -- its value. + Index := Int (Index_Type'First - 1) + Int (Length); + end if; + + Last := Index_Type (Index); + Elements := new Elements_Type (Last); + + -- We use Last as the index of the loop used to populate the internal + -- array with items. In general, we prefer to initialize the loop index + -- immediately prior to entering the loop. However, Last is also used in + -- the exception handler (it reclaims elements that have been allocated, + -- before propagating the exception), and the initialization of Last + -- after entering the block containing the handler confuses some static + -- analysis tools, with respect to whether Last has been properly + -- initialized when the handler executes. So here we initialize our loop + -- variable earlier than we prefer, before entering the block, so there + -- is no ambiguity. + Last := Index_Type'First; + + begin + loop + Elements.EA (Last) := new Element_Type'(New_Item); + exit when Last = Elements.Last; + Last := Last + 1; + end loop; - Free (Elements); - raise; - end; + exception + when others => + for J in Index_Type'First .. Last - 1 loop + Free (Elements.EA (J)); + end loop; - return (Controlled with Elements, Last, 0, 0); + Free (Elements); + raise; end; + + return (Controlled with Elements, Last, 0, 0); end To_Vector; -------------------- Index: a-convec.adb =================================================================== --- a-convec.adb (revision 160705) +++ a-convec.adb (working copy) @@ -81,22 +81,59 @@ package body Ada.Containers.Vectors is end if; declare - N : constant Int'Base := Int (LN) + Int (RN); - Last_As_Int : Int'Base; + N : constant Int'Base := Int (LN) + Int (RN); + J : Int'Base; begin - if Int (No_Index) > Int'Last - N then + -- There are two constraints we need to satisfy. The first constraint + -- is that a container cannot have more than Count_Type'Last + -- elements, so we must check the sum of the combined lengths. (It + -- would be rare for vectors to have such a large number of elements, + -- so we would normally expect this first check to succeed.) The + -- second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. + + if N > Count_Type'Pos (Count_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; - Last_As_Int := Int (No_Index) + N; + -- We now check whether the new length would create a Last index + -- value greater than Index_Type'Last. This calculation requires + -- care, because overflow can occur when Index_Type'First is near the + -- end of the range of Int. + + if Index_Type'First <= 0 then + -- Compute the potential Last index value in the normal way, using + -- Int as the type in which to perform intermediate + -- calculations. Int is a 64-bit type, and Count_Type is a 32-bit + -- type, so no overflow can occur. + J := Int (Index_Type'First - 1) + N; - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + if J > Int (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + else + -- If Index_Type'First is within N of Int'Last, then overflow + -- would occur if we simply computed Last directly. So instead of + -- computing Last, and then determining whether its value is + -- greater than Index_Type'Last (as we do above), we work + -- backwards by computing the potential First index value, and + -- then checking whether that value is less than Index_Type'First. + J := Int (Index_Type'Last) - N + 1; + + if J < Int (Index_Type'First) then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We have determined that Length would not create a Last index + -- value outside of the range of Index_Type, so we can now safely + -- compute its value. + J := Int (Index_Type'First - 1) + N; end if; declare - Last : constant Index_Type := Index_Type (Last_As_Int); + Last : constant Index_Type := Index_Type (J); LE : Elements_Array renames Left.Elements.EA (Index_Type'First .. Left.Last); @@ -114,10 +151,8 @@ package body Ada.Containers.Vectors is end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is - LN : constant Count_Type := Length (Left); - begin - if LN = 0 then + if Left.Is_Empty then declare Elements : constant Elements_Access := new Elements_Type' @@ -129,42 +164,37 @@ package body Ada.Containers.Vectors is end; end if; - declare - Last_As_Int : Int'Base; - - begin - if Int (Index_Type'First) > Int'Last - Int (LN) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We must satisfy two constraints: the new length cannot exceed + -- Count_Type'Last, and the new Last index cannot exceed + -- Index_Type'Last. - Last_As_Int := Int (Index_Type'First) + Int (LN); + if Left.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + if Left.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + declare + Last : constant Index_Type := Left.Last + 1; - 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' - (Last => Last, - EA => LE & Right); + Elements : constant Elements_Access := + new Elements_Type' + (Last => Last, + EA => LE & Right); - begin - return (Controlled with Elements, Last, 0, 0); - end; + begin + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is - RN : constant Count_Type := Length (Right); - begin - if RN = 0 then + if Right.Is_Empty then declare Elements : constant Elements_Access := new Elements_Type' @@ -176,34 +206,31 @@ package body Ada.Containers.Vectors is end; end if; - declare - Last_As_Int : Int'Base; + -- We must satisfy two constraints: the new length cannot exceed + -- Count_Type'Last, and the new Last index cannot exceed + -- Index_Type'Last. - begin - 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 Right.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + if Right.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + declare + Last : constant Index_Type := Right.Last + 1; - 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' - (Last => Last, - EA => Left & RE); + Elements : constant Elements_Access := + new Elements_Type' + (Last => Last, + EA => Left & RE); - begin - return (Controlled with Elements, Last, 0, 0); - end; + begin + return (Controlled with Elements, Last, 0, 0); end; end "&"; @@ -488,12 +515,13 @@ package body Ada.Containers.Vectors is "attempt to tamper with elements (vector is busy)"; end if; - Index := Int'Base (Container.Last) - Int'Base (Count); + if Count >= Container.Length then + Container.Last := No_Index; - Container.Last := - (if Index < Index_Type'Pos (Index_Type'First) - then No_Index - else Index_Type (Index)); + else + Index := Int (Container.Last) - Int (Count); + Container.Last := Index_Type (Index); + end if; end Delete_Last; ------------- @@ -2135,54 +2163,116 @@ package body Ada.Containers.Vectors is --------------- function To_Vector (Length : Count_Type) return Vector is + Index : Int'Base; + Last : Index_Type; + Elements : Elements_Access; + begin if Length = 0 then return Empty_Vector; end if; - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - Elements : Elements_Access; + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. This + -- calculation requires care, because overflow can occur when + -- Index_Type'First is near the end of the range of Int. + + if Index_Type'First <= 0 then + -- Compute the potential Last index value in the normal way, using + -- Int as the type in which to perform intermediate calculations. Int + -- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow + -- can occur. + Index := Int (Index_Type'First - 1) + Int (Length); - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + if Index > Int (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; - Last := Index_Type (Last_As_Int); - Elements := new Elements_Type (Last); + else + -- If Index_Type'First is within Length of Int'Last, then overflow + -- would occur if we simply computed Last directly. So instead of + -- computing Last, and then determining whether its value is greater + -- than Index_Type'Last, we work backwards by computing the potential + -- First index value, and then checking whether that value is less + -- than Index_Type'First. + Index := Int (Index_Type'Last) - Int (Length) + 1; - return Vector'(Controlled with Elements, Last, 0, 0); - end; + if Index < Int (Index_Type'First) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that Length would not create a Last index value + -- outside of the range of Index_Type, so we can now safely compute + -- its value. + Index := Int (Index_Type'First - 1) + Int (Length); + end if; + + Last := Index_Type (Index); + Elements := new Elements_Type (Last); + + return Vector'(Controlled with Elements, Last, 0, 0); end To_Vector; function To_Vector (New_Item : Element_Type; Length : Count_Type) return Vector is + Index : Int'Base; + Last : Index_Type; + Elements : Elements_Access; + begin if Length = 0 then return Empty_Vector; end if; - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - Elements : Elements_Access; + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. This + -- calculation requires care, because overflow can occur when + -- Index_Type'First is near the end of the range of Int. + + if Index_Type'First <= 0 then + -- Compute the potential Last index value in the normal way, using + -- Int as the type in which to perform intermediate calculations. Int + -- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow + -- can occur. + Index := Int (Index_Type'First - 1) + Int (Length); - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + if Index > Int (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; - Last := Index_Type (Last_As_Int); - Elements := new Elements_Type'(Last, EA => (others => New_Item)); + else + -- If Index_Type'First is within Length of Int'Last, then overflow + -- would occur if we simply computed Last directly. So instead of + -- computing Last, and then determining whether its value is greater + -- than Index_Type'Last, we work backwards by computing the potential + -- First index value, and then checking whether that value is less + -- than Index_Type'First. + Index := Int (Index_Type'Last) - Int (Length) + 1; - return Vector'(Controlled with Elements, Last, 0, 0); - end; + if Index < Int (Index_Type'First) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that Length would not create a Last index value + -- outside of the range of Index_Type, so we can now safely compute + -- its value. + Index := Int (Index_Type'First - 1) + Int (Length); + end if; + + Last := Index_Type (Index); + Elements := new Elements_Type'(Last, EA => (others => New_Item)); + + return Vector'(Controlled with Elements, Last, 0, 0); end To_Vector; --------------------