From 5bec9717c3c211d060c7f83dab629157755469f8 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 22 Jun 2010 18:35:15 +0200 Subject: [PATCH] [multiple changes] 2010-06-22 Matthew Heaney * a-convec.adb, a-coinve.adb: Removed 64-bit types Int and UInt. 2010-06-22 Paul Hilfinger * s-rannum.adb (Random_Float_Template): Replace with unbiased version that is able to produce all representable floating-point numbers in the unit interval. Remove template parameter Shift_Right, no longer used. * gnat_rm.texi: Document the period of the pseudo-random number generator under the description of its algorithm. * gcc-interface/Make-lang.in: Update dependencies. From-SVN: r161202 --- gcc/ada/ChangeLog | 13 + gcc/ada/a-coinve.adb | 1945 ++++++++++++++++++++-------- gcc/ada/a-convec.adb | 1648 ++++++++++++++++------- gcc/ada/gcc-interface/Make-lang.in | 449 +++---- gcc/ada/gnat_rm.texi | 3 +- gcc/ada/s-rannum.adb | 171 ++- 6 files changed, 2920 insertions(+), 1309 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c8fda574cf2..b3834978de0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2010-06-22 Matthew Heaney + + * a-convec.adb, a-coinve.adb: Removed 64-bit types Int and UInt. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb (Random_Float_Template): Replace with unbiased version + that is able to produce all representable floating-point numbers in the + unit interval. Remove template parameter Shift_Right, no longer used. + * gnat_rm.texi: Document the period of the pseudo-random number + generator under the description of its algorithm. + * gcc-interface/Make-lang.in: Update dependencies. + 2010-06-22 Thomas Quinot * exp_aggr.adb (Rewrite_Discriminant): Fix predicate used to identify diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index fb4038db259..6443644b4f6 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, 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- -- @@ -33,9 +33,6 @@ 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); @@ -47,10 +44,22 @@ package body Ada.Containers.Indefinite_Vectors is --------- function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + N : Count_Type'Base; -- length of result + J : Count_Type'Base; -- for computing intermediate values + Last : Index_Type'Base; -- Last index of result begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the vector parameters. We could decide to make it larger, but we + -- have no basis for knowing how much larger, so we just allocate the + -- minimum amount of storage. + + -- Here we handle the easy cases first, when one of the vector + -- parameters is empty. (We say "easy" because there's nothing to + -- compute, that can potentially overflow.) + if LN = 0 then if RN = 0 then return Empty_Vector; @@ -64,6 +73,11 @@ package body Ada.Containers.Indefinite_Vectors is new Elements_Type (Right.Last); begin + -- Elements of an indefinite vector are allocated, so we cannot + -- use simple slice assignment to give a value to our result. + -- Hence we must walk the array of the Right vector, and copy + -- each source element individually. + for I in Elements.EA'Range loop begin if RE (I) /= null then @@ -95,6 +109,11 @@ package body Ada.Containers.Indefinite_Vectors is new Elements_Type (Left.Last); begin + -- Elements of an indefinite vector are allocated, so we cannot + -- use simple slice assignment to give a value to our result. + -- Hence we must walk the array of the Left vector, and copy + -- each source element individually. + for I in Elements.EA'Range loop begin if LE (I) /= null then @@ -116,121 +135,161 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - declare - N : constant Int'Base := Int (LN) + Int (RN); - J : Int'Base; + -- Neither of the vector parameters is empty, so we must compute the + -- length of the result vector and its last index. (This is the harder + -- case, because our computations must avoid overflow.) - begin - -- 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. + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the combined lengths. Note that we cannot + -- simply add the lengths, because of the possibilty of overflow. - if N > Count_Type'Pos (Count_Type'Last) then + if LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe compute the length of the new vector. + + N := LN + RN; + + -- The second constraint is that the new Last index value cannot + -- exceed Index_Type'Last. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. + + if Index_Type'Base'Last >= Count_Type'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. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then raise Constraint_Error with "new length is out of range"; end if; - -- We now 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. + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - if Index_Type'First <= 0 then + Last := No_Index + Index_Type'Base (N); - -- 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. + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: - 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; + if Last > Index_Type'Last then + raise Constraint_Error with "new length is out of range"; end if; - declare - Last : constant Index_Type := Index_Type (J); + elsif Index_Type'First <= 0 then - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + -- 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. - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); + J := Count_Type'Base (No_Index) + N; -- Last - Elements : Elements_Access := new Elements_Type (Last); + if J > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; - I : Index_Type'Base := No_Index; + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: - begin - for LI in LE'Range loop - I := I + 1; + Last := Index_Type'Base (J); - begin - if LE (LI) /= null then - Elements.EA (I) := new Element_Type'(LE (LI).all); - end if; + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; + J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - Free (Elements); - raise; - end; - end loop; + if J < Count_Type'Base (No_Index) then + raise Constraint_Error with "new length is out of range"; + end if; - for RI in RE'Range loop - I := I + 1; + -- We have determined that the result length would not create a Last + -- index value outside of the range of Index_Type, so we can now + -- safely compute its value. - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; + Last := Index_Type'Base (Count_Type'Base (No_Index) + N); + end if; - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; + declare + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); - Free (Elements); - raise; - end; - end loop; + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); - return (Controlled with Elements, Last, 0, 0); - end; + Elements : Elements_Access := new Elements_Type (Last); + + I : Index_Type'Base := No_Index; + + begin + -- Elements of an indefinite vector are allocated, so we cannot use + -- simple slice assignment to give a value to our result. Hence we + -- must walk the array of each vector parameter, and copy each source + -- element individually. + + for LI in LE'Range loop + I := I + 1; + + begin + if LE (LI) /= null then + Elements.EA (I) := new Element_Type'(LE (LI).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; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Left) + -- is empty. + if Left.Is_Empty then declare Elements : Elements_Access := new Elements_Type (Index_Type'First); @@ -248,8 +307,10 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - -- We must satisfy two constraints: the new length cannot exceed - -- Count_Type'Last, and the new Last index cannot exceed + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed -- Index_Type'Last. if Left.Length = Count_Type'Last then @@ -306,6 +367,14 @@ package body Ada.Containers.Indefinite_Vectors is function "&" (Left : Element_Type; Right : Vector) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Right) + -- is empty. + if Right.Is_Empty then declare Elements : Elements_Access := new Elements_Type (Index_Type'First); @@ -323,8 +392,10 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - -- We must satisfy two constraints: the new length cannot exceed - -- Count_Type'Last, and the new Last index cannot exceed + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed -- Index_Type'Last. if Right.Length = Count_Type'Last then @@ -380,6 +451,17 @@ package body Ada.Containers.Indefinite_Vectors is function "&" (Left, Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We must compute the length of the result vector and its last index, + -- but in such a way that overflow is avoided. We must satisfy two + -- constraints: the new length cannot exceed Count_Type'Last (here, we + -- know that that condition is satisfied), and the new Last index cannot + -- exceed Index_Type'Last. + if Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -572,75 +654,177 @@ package body Ada.Containers.Indefinite_Vectors is Index : Extended_Index; Count : Count_Type := 1) is + Old_Last : constant Index_Type'Base := Container.Last; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + J : Index_Type'Base; -- first index of items that slide down + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; - if Index > Container.Last then - if Index > Container.Last + 1 then + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; return; end if; + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + if Count = 0 then return; end if; + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, so we handle that case here in order to avoid having to + -- check it later. (Note that an empty vector can never be busy, so + -- there's no semantic harm in returning early.) + + if Container.Is_Empty then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - declare - Index_As_Int : constant Int := Int (Index); - Old_Last_As_Int : constant Int := Int (Container.Last); + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) - 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); + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - J_As_Int : constant Int'Base := Index_As_Int + N; - E : Elements_Array renames Container.Elements.EA; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; - begin - if J_As_Int > Old_Last_As_Int then + -- If the number of elements requested (Count) for deletion is equal to + -- (or greater than) the number of elements available (Count2) for + -- deletion beginning at Index, then everything from Index to + -- Container.Last is deleted (this is equivalent to Delete_Last). + + if Count >= Count2 then + -- Elements in an indefinite vector are allocated, so we must iterate + -- over the loop and deallocate elements one-at-a-time. We work from + -- back to front, deleting the last element during each pass, in + -- order to gracefully handle deallocation failures. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin while Container.Last >= Index loop declare K : constant Index_Type := Container.Last; - X : Element_Access := E (K); + X : Element_Access := EA (K); begin - E (K) := null; + -- We first isolate the element we're deleting, removing it + -- from the vector before we attempt to deallocate it, in + -- case the deallocation fails. + + EA (K) := null; Container.Last := K - 1; + + -- Container invariants have been restored, so it is now + -- safe to attempt to deallocate the element. + Free (X); end; end loop; + end; - else + return; + end if; + + -- There are some elements that aren't being deleted (the requested + -- count was less than the available count), so we must slide them down + -- to Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. For the elements that slide down, + -- index value New_Last is the last index value of their new home, and + -- index value J is the first index of their old home. + + 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); + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, but we have that guarantee here because we know we have + -- elements to slide. The array index values for each slice have + -- already been determined, so what remains to be done is to first + -- deallocate the elements that are being deleted, and then slide down + -- to Index the elements that aren't being deleted. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + -- Before we can slide down the elements that aren't being deleted, + -- we need to deallocate the elements that are being deleted. + + for K in Index .. J - 1 loop declare - J : constant Index_Type := Index_Type (J_As_Int); - - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; - New_Last : constant Index_Type := - Index_Type (New_Last_As_Int); + X : Element_Access := EA (K); begin - for K in Index .. J - 1 loop - declare - X : Element_Access := E (K); - begin - E (K) := null; - Free (X); - end; - end loop; + -- First we remove the element we're about to deallocate from + -- the vector, in case the deallocation fails, in order to + -- preserve representation invariants. - E (Index .. New_Last) := E (J .. Container.Last); - Container.Last := New_Last; + EA (K) := null; + + -- The element has been removed from the vector, so it is now + -- safe to attempt to deallocate it. + + Free (X); end; - end if; + end loop; + + EA (Index .. New_Last) := EA (J .. Old_Last); + Container.Last := New_Last; end; end Delete; @@ -698,32 +882,64 @@ package body Ada.Containers.Indefinite_Vectors is (Container : in out Vector; Count : Count_Type := 1) is - N : constant Count_Type := Length (Container); - begin - if Count = 0 - or else N = 0 - then + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + + if Count = 0 then return; end if; + -- We cannot simply subsume the empty case into the loop below (the loop + -- would iterate 0 times), because we rename the internal array object + -- (which is allocated), but an empty vector isn't guaranteed to have + -- actually allocated an array. (Note that an empty vector can never be + -- busy, so there's no semantic harm in returning early here.) + + if Container.Is_Empty then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- Elements in an indefinite vector are allocated, so we must iterate + -- over the loop and deallocate elements one-at-a-time. We work from + -- back to front, deleting the last element during each pass, in order + -- to gracefully handle deallocation failures. + declare E : Elements_Array renames Container.Elements.EA; begin - for Indx in 1 .. Count_Type'Min (Count, N) loop + for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop declare J : constant Index_Type := Container.Last; X : Element_Access := E (J); begin + -- Note that we first isolate the element we're deleting, + -- removing it from the vector, before we actually deallocate + -- it, in order to preserve representation invariants even if + -- the deallocation fails. + E (J) := null; Container.Last := J - 1; + + -- Container invariants have been restored, so it is now safe + -- to deallocate the element. + Free (X); end; end loop; @@ -1073,22 +1289,42 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Element_Type; Count : Count_Type := 1) is - N : constant Int := Int (Count); + Old_Length : constant Count_Type := Container.Length; - 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); + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - Dst : Elements_Access; + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1096,197 +1332,371 @@ package body Ada.Containers.Indefinite_Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- 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 current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length 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. + + 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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Last_As_Int := Old_Last_As_Int + N; + 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. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + 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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + 1); + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; - end if; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; - New_Last := Index_Type (New_Last_As_Int); - end; + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + 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; + + if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In an indefinite vector, elements are allocated individually, and + -- stored as access values on the internal array (the length of which + -- represents the vector "capacity"), which is separately allocated. + + Container.Elements := new Elements_Type (New_Last); + + -- The element backbone has been successfully allocated, so now we + -- allocate the elements. + + for Idx in Container.Elements.EA'Range 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). + + Container.Elements.EA (Idx) := new Element_Type'(New_Item); + + -- The allocation of the element succeeded, so it is now safe to + -- update the Last index, restoring container invariants. + + Container.Last := Idx; + end loop; + + return; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - if Container.Elements = null then - Container.Elements := new Elements_Type (New_Last); - Container.Last := No_Index; + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. - for J in Container.Elements.EA'Range loop - Container.Elements.EA (J) := new Element_Type'(New_Item); - Container.Last := J; - end loop; - - return; - end if; - - if New_Last <= Container.Elements.Last then declare E : Elements_Array renames Container.Elements.EA; + K : Index_Type'Base; begin - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. - Index : constant Index_Type := Index_Type (Index_As_Int); + 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). - J : Index_Type'Base; + E (Idx) := new Element_Type'(New_Item); - begin - -- The new items are being inserted in the middle of the - -- array, in the range [Before, Index). Copy the existing - -- elements to the end of the array, to make room for the - -- new items. + -- The allocation of the element succeeded, so it is now + -- safe to update the Last index, restoring container + -- invariants. - E (Index .. New_Last) := E (Before .. Container.Last); - Container.Last := New_Last; - - -- We have copied the existing items up to the end of the - -- array, to make room for the new items in the middle of - -- the array. Now we actually allocate the new items. - - -- Note: initialize J outside loop to make it clear that - -- J always has a value if the exception handler triggers. - - J := Before; - begin - while J < Index loop - E (J) := new Element_Type'(New_Item); - J := J + 1; - end loop; - - exception - when others => - - -- Values in the range [Before, J) were successfully - -- allocated, but values in the range [J, Index) are - -- stale (these array positions contain copies of the - -- old items, that did not get assigned a new item, - -- because the allocation failed). We must finish what - -- we started by clearing out all of the stale values, - -- leaving a "hole" in the middle of the array. - - E (J .. Index - 1) := (others => null); - raise; - end; - end; + Container.Last := Idx; + end loop; else - for J in Before .. New_Last loop - E (J) := new Element_Type'(New_Item); - Container.Last := J; - end loop; + -- The new items are 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 + -- 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; + + -- The new items are being inserted in the middle of the array, + -- in the range [Before, Index). Copy the existing elements to + -- the end of the array, to make room for the new items. + + E (Index .. New_Last) := E (Before .. Container.Last); + Container.Last := New_Last; + + -- We have copied the existing items up to the end of the + -- array, to make room for the new items in the middle of + -- the array. Now we actually allocate the new items. + + -- Note: initialize K outside loop to make it clear that + -- K always has a value if the exception handler triggers. + + K := Before; + begin + while K < Index loop + E (K) := new Element_Type'(New_Item); + K := K + 1; + end loop; + + exception + when others => + + -- Values in the range [Before, K) were successfully + -- allocated, but values in the range [K, Index) are + -- stale (these array positions contain copies of the + -- old items, that did not get assigned a new item, + -- because the allocation failed). We must finish what + -- we started by clearing out all of the stale values, + -- leaving a "hole" in the middle of the array. + + E (K .. Index - 1) := (others => null); + raise; + end; end if; end; return; end if; - -- There follows LOTS of code completely devoid of comments ??? - -- This is not our general style ??? + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; + + New_Capacity := 2 * New_Capacity; + end loop; + + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) + + New_Capacity := Max_Length; + end if; + + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. + + 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); + end if; + + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array) to the new array (the "destination" array), and then + -- deallocate the old array. declare - C, CC : UInt; + Src : Elements_Access := Container.Elements; begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; + Dst.EA (Index_Type'First .. Before - 1) := + Src.EA (Index_Type'First .. Before - 1); + + if Before > Container.Last then + -- 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. + + Container.Elements := Dst; + Free (Src); + + -- Now we append the new items. + + 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). + + Dst.EA (Idx) := new Element_Type'(New_Item); + + -- The allocation of the element succeeded, so it is now safe + -- to update the Last index, restoring container invariants. + + Container.Last := Idx; + end loop; + + else + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. + + 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; - C := 2 * C; - end loop; - - if C > Max_Length then - C := Max_Length; - end if; - - 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 + UInt'Pos (C) - Int'(1)); - - begin - Dst := new Elements_Type (Dst_Last); - end; - end; - - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; - - Index : constant Index_Type := Index_Type (Index_As_Int); - - Src : Elements_Access := Container.Elements; - - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); - 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. + Container.Elements := Dst; Container.Last := New_Last; Free (Src); - for J in Before .. Index - 1 loop - Dst.EA (J) := new Element_Type'(New_Item); + -- The new array has a range in the middle containing null access + -- values. We now fill in that partion of the array with the new + -- items. + + for Idx in Before .. Index - 1 loop + -- Note that container invariants have already been satisfied + -- (in particular, the Last index value of the vector has + -- already been updated), so if this allocation fails we simply + -- let it propagate. + + Dst.EA (Idx) := new Element_Type'(New_Item); end loop; - end; - - else - declare - Src : Elements_Access := Container.Elements; - - begin - Dst.EA (Index_Type'First .. Container.Last) := - Src.EA (Index_Type'First .. Container.Last); - - Container.Elements := Dst; - Free (Src); - - for J in Before .. New_Last loop - Dst.EA (J) := new Element_Type'(New_Item); - Container.Last := J; - end loop; - end; - end if; + end if; + end; end Insert; procedure Insert @@ -1295,96 +1705,147 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Vector) is N : constant Count_Type := Length (New_Item); + J : Index_Type'Base; begin - if Before < Index_Type'First then - 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 with - "Before index is out of range (too large)"; - end if; - - if N = 0 then - return; - end if; + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. Insert_Space (Container, Before, Count => N); + if N = 0 then + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + + return; + end if; + + if Container'Address /= New_Item'Address then + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. + + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. New_Item.Last; + + Src : Elements_Array renames + New_Item.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + Dst_Index := Before - 1; + for Src_Index in Src'Range loop + Dst_Index := Dst_Index + 1; + + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; + + return; + end if; + + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The first source slice is + -- [Index_Type'First, Before), and the second source slice is + -- [J, Container.Last], where index value J is the first index of the + -- second slice. (J gets computed below, but only after we have + -- determined that the second source slice is non-empty.) The + -- destination slice is always the range [Before, J). We perform the + -- copy in two steps, using each of the two slices of the source items. + declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; + L : constant Index_Type'Base := Before - 1; - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. L; - Dst : Elements_Array renames - Container.Elements.EA (Before .. Dst_Last); + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); - Dst_Index : Index_Type'Base := Before - 1; + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; begin - if Container'Address /= New_Item'Address then - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. New_Item.Last; + -- We first copy the source items that precede the space we + -- inserted. (If Before equals Index_Type'First, then this first + -- source slice will be empty, which is harmless.) - Src : Elements_Array renames - New_Item.Elements.EA (Src_Index_Subtype); + Dst_Index := Before - 1; + for Src_Index in Src'Range loop + Dst_Index := Dst_Index + 1; - begin - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; + if Src'Length = N then + -- The new items were effectively appended to the container, so we + -- have already copied all of the items that need to be copied. + -- We return early here, even though the source slice below is + -- empty (so the assignment would be harmless), because we want to + -- avoid computing J, which will overflow if J is greater than + -- Index_Type'Base'Last. return; end if; + end; - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Before - 1; + -- Index value J is the first index of the second source slice. (It is + -- also 1 greater than the last index of the destination slice.) Note + -- that we want to avoid computing J, if J is greater than + -- Index_Type'Base'Last, in order to avoid overflow. We prevent that by + -- returning early above, immediately after copying the first slice of + -- the source, and determining that this second slice of the source is + -- empty. - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + J := Before + Index_Type'Base (N); - begin - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; + else + J := Index_Type'Base (Count_Type'Base (Before) + N); + end if; - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; + declare + subtype Src_Index_Subtype is Index_Type'Base range + J .. Container.Last; - if Dst_Last = Container.Last then - return; + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + -- We next copy the source items that follow the space we + -- inserted. Index value Dst_Index is the first index of that portion + -- of the destination that receives this slice of the source. (For + -- the reasons given above, this slice is guaranteed to be + -- non-empty.) + + 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; - declare - subtype Src_Index_Subtype is Index_Type'Base range - Dst_Last + 1 .. Container.Last; + for Src_Index in Src'Range loop + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - begin - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; + Dst_Index := Dst_Index + 1; + end loop; end; end Insert; @@ -1561,22 +2022,42 @@ package body Ada.Containers.Indefinite_Vectors is Before : Extended_Index; Count : Count_Type := 1) is - N : constant Int := Int (Count); + Old_Length : constant Count_Type := Container.Length; - 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); + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - Dst : Elements_Access; + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1584,60 +2065,178 @@ package body Ada.Containers.Indefinite_Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- 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 current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length 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. + + 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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Last_As_Int := Old_Last_As_Int + N; + 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. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + 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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + 1); + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; - end if; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; - New_Last := Index_Type (New_Last_As_Int); - end; + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + 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; + + if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In an indefinite vector, elements are allocated individually, and + -- stored as access values on the internal array (the length of which + -- represents the vector "capacity"), which is separately + -- allocated. We have no elements here (because we're inserting + -- "space"), so all we need to do is allocate the backbone. + + Container.Elements := new Elements_Type (New_Last); + Container.Last := New_Last; + + return; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - if Container.Elements = null then - Container.Elements := new Elements_Type (New_Last); - Container.Last := New_Last; - return; - end if; + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. - if New_Last <= Container.Elements.Last then declare E : Elements_Array renames Container.Elements.EA; begin if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- 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 + -- Count_Type'Base as the type for intermediate index values. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - E (Index .. New_Last) := E (Before .. Container.Last); - E (Before .. Index - 1) := (others => null); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + E (Index .. New_Last) := E (Before .. Container.Last); + E (Before .. Index - 1) := (others => null); end if; end; @@ -1645,68 +2244,80 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - declare - C, CC : UInt; + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; - - C := 2 * C; - end loop; - - if C > Max_Length then - C := Max_Length; + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; end if; - 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; + New_Capacity := 2 * New_Capacity; + end loop; - if C > CC then - C := CC; - end if; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - 1); + New_Capacity := Max_Length; + end if; - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. + + 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); + end if; + + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array) to the new array (the "destination" array), and then + -- deallocate the old array. declare Src : Elements_Access := Container.Elements; begin + Dst.EA (Index_Type'First .. Before - 1) := + Src.EA (Index_Type'First .. Before - 1); + if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - end; - - else - Dst.EA (Index_Type'First .. Container.Last) := - Src.EA (Index_Type'First .. Container.Last); + Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); end if; + -- We have copied the elements from to the old, source array to the + -- new, destination array, so we can now restore invariants, and + -- deallocate the old array. + Container.Elements := Dst; Container.Last := New_Last; Free (Src); @@ -1808,7 +2419,7 @@ package body Ada.Containers.Indefinite_Vectors is return (Container'Unchecked_Access, Container.Last); end Last; - ------------------ + ----------------- -- Last_Element -- ------------------ @@ -1845,12 +2456,33 @@ package body Ada.Containers.Indefinite_Vectors is ------------ function Length (Container : Vector) return Count_Type is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; begin - return Count_Type (N); + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; end Length; ---------- @@ -2131,17 +2763,53 @@ package body Ada.Containers.Indefinite_Vectors is is N : constant Count_Type := Length (Container); + Index : Count_Type'Base; + Last : Index_Type'Base; + begin + -- Reserve_Capacity can be used to either expand the storage available + -- for elements (this would be its typical use, in anticipation of + -- future insertion), or to trim back storage. In the latter case, + -- storage can only be trimmed back to the limit of the container + -- length. Note that Reserve_Capacity neither deletes (active) elements + -- nor inserts elements; it only affects container capacity, never + -- container length. + if Capacity = 0 then + -- This is a request to trim back storage, to the minimum amount + -- possible given the current state of the container. + if N = 0 then + -- The container is empty, so in this unique case we can + -- deallocate the entire internal array. Note that an empty + -- container can never be busy, so there's no need to check the + -- tampering bits. + declare X : Elements_Access := Container.Elements; begin + -- First we remove the internal array from the container, to + -- handle the case when the deallocation raises an exception + -- (although that's unlikely, since this is simply an array of + -- access values, all of which are null). + Container.Elements := null; + + -- Container invariants have been restored, so it is now safe + -- to attempt to deallocate the internal array. + Free (X); end; elsif N < Container.Elements.EA'Length then + -- The container is not empty, and the current length is less than + -- the current capacity, so there's storage available to trim. In + -- this case, we allocate a new internal array having a length + -- that exactly matches the number of items in the + -- container. (Reserve_Capacity does not delete active elements, + -- so this is the best we can do with respect to minimizing + -- storage). + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -2157,7 +2825,19 @@ package body Ada.Containers.Indefinite_Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (because there is not enough storage), we + -- let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so we can + -- deallocate the old array. + Free (X); end; end if; @@ -2165,29 +2845,102 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; + -- Reserve_Capacity can be used to expand the storage available for + -- elements, but we do not let the capacity grow beyond the number of + -- values in Index_Type'Range. (Were it otherwise, there would be no way + -- to refer to the elements with index values greater than + -- Index_Type'Last, so that storage would be wasted.) Here we compute + -- the Last index value of the new internal array, in a way that avoids + -- any possibility of overflow. + + 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. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Capacity); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Capacity is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Capacity. + + Index := Count_Type'Base (No_Index) + Capacity; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We have determined that the value of Capacity would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); + end if; + + -- The requested capacity is non-zero, but we don't know yet whether + -- this is a request for expansion or contraction of storage. + if Container.Elements = null then - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; - - begin - if Last_As_Int > Index_Type'Pos (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); - - begin - Container.Elements := new Elements_Type (Last); - end; - end; + -- The container is empty (it doesn't even have an internal array), + -- so this represents a request to allocate storage having the given + -- capacity. + Container.Elements := new Elements_Type (Last); return; end if; if Capacity <= N then + -- This is a request to trim back storage, but only to the limit of + -- what's already in the container. (Reserve_Capacity never deletes + -- active elements, it only reclaims excess storage.) + if N < Container.Elements.EA'Length then + -- The container is not empty (because the requested capacity is + -- positive, and less than or equal to the container length), and + -- the current length is less than the current capacity, so + -- there's storage available to trim. In this case, we allocate a + -- new internal array having a length that exactly matches the + -- number of items in the container. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -2203,7 +2956,19 @@ package body Ada.Containers.Indefinite_Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (because there is not enough storage), we + -- let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to deallocate the old array. + Free (X); end; end if; @@ -2211,47 +2976,57 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; + -- The requested capacity is larger than the container length (the + -- number of active elements). Whether this represents a request for + -- expansion or contraction of the current capacity depends on what the + -- current capacity is. + if Capacity = Container.Elements.EA'Length then + -- The requested capacity matches the existing capacity, so there's + -- nothing to do here. We treat this case as a no-op, and simply + -- return without checking the busy bit. + return; end if; + -- There is a change in the capacity of a non-empty container, so a new + -- internal array will be allocated. (The length of the new internal + -- array could be less or greater than the old internal array. We know + -- only that the length of the new internal array is greater than the + -- number of active elements in the container.) We must check whether + -- the container is busy before doing anything else. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- We now allocate a new internal array, having a length different from + -- its current value. + declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + X : Elements_Access := Container.Elements; + + subtype Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We now allocate a new internal array, having a length different + -- from its current value. - declare - Last : constant Index_Type := Index_Type (Last_As_Int); - X : Elements_Access := Container.Elements; + Container.Elements := new Elements_Type (Last); - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + -- We have successfully allocated the new internal array, so now we + -- move the existing elements from the existing the old internal + -- array onto the new one. Note that we're just copying access + -- values, to this should not raise any exceptions. - begin - Container.Elements := new Elements_Type (Last); + Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype); - declare - Src : Elements_Array renames - X.EA (Index_Subtype); + -- We have moved the elements from the old interal array, so now we + -- can deallocate it. - Tgt : Elements_Array renames - Container.Elements.EA (Index_Subtype); - - begin - Tgt := Src; - end; - - Free (X); - end; + Free (X); end; end Reserve_Capacity; @@ -2388,45 +3163,25 @@ package body Ada.Containers.Indefinite_Vectors is (Container : in out Vector; Length : Count_Type) is - N : constant Count_Type := Indefinite_Vectors.Length (Container); + Count : constant Count_Type'Base := Container.Length - Length; begin - if Length = N then - return; + -- Set_Length allows the user to set the length explicitly, instead of + -- implicitly as a side-effect of deletion or insertion. If the + -- requested length is less than the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent to + -- inserting "space" (nonce items) at the end. + + 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; - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - - if Length < N then - for Index in 1 .. N - Length loop - declare - J : constant Index_Type := Container.Last; - X : Element_Access := Container.Elements.EA (J); - - begin - Container.Elements.EA (J) := null; - Container.Last := J - 1; - Free (X); - end; - end loop; - - return; - end if; - - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; - - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Length) - 1; - - begin - Container.Last := Index_Type (Last_As_Int); - end; end Set_Length; ---------- @@ -2529,8 +3284,8 @@ package body Ada.Containers.Indefinite_Vectors is --------------- function To_Vector (Length : Count_Type) return Vector is - Index : Int'Base; - Last : Index_Type; + Index : Count_Type'Base; + Last : Index_Type'Base; Elements : Elements_Access; begin @@ -2539,45 +3294,75 @@ package body Ada.Containers.Indefinite_Vectors is end if; -- We create a vector object with a capacity that matches the specified - -- Length. We do not allow the vector capacity (the length of the + -- 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), 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. + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. - 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); + 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. - if Index > Int (Index_Type'Last) then + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + 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; + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - if Index < Int (Index_Type'First) then + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) 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); + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); end if; - Last := Index_Type (Index); Elements := new Elements_Type (Last); return Vector'(Controlled with Elements, Last, 0, 0); @@ -2587,8 +3372,8 @@ package body Ada.Containers.Indefinite_Vectors is (New_Item : Element_Type; Length : Count_Type) return Vector is - Index : Int'Base; - Last : Index_Type; + Index : Count_Type'Base; + Last : Index_Type'Base; Elements : Elements_Access; begin @@ -2597,51 +3382,81 @@ package body Ada.Containers.Indefinite_Vectors is end if; -- We create a vector object with a capacity that matches the specified - -- Length. We do not allow the vector capacity (the length of the + -- 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), 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. + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. - 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); + 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. - if Index > Int (Index_Type'Last) then + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + 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; + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - if Index < Int (Index_Type'First) then + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) 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); + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + 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, + -- the exception handler (to reclaim 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 diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 8d146b07dec..501128b9d89 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, 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- -- @@ -34,9 +34,6 @@ 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); @@ -45,10 +42,22 @@ package body Ada.Containers.Vectors is --------- function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + N : Count_Type'Base; -- length of result + J : Count_Type'Base; -- for computing intermediate index values + Last : Index_Type'Base; -- Last index of result begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the vector parameters. We could decide to make it larger, but we + -- have no basis for knowing how much larger, so we just allocate the + -- minimum amount of storage. + + -- Here we handle the easy cases first, when one of the vector + -- parameters is empty. (We say "easy" because there's nothing to + -- compute, that can potentially overflow.) + if LN = 0 then if RN = 0 then return Empty_Vector; @@ -80,82 +89,116 @@ package body Ada.Containers.Vectors is end if; - declare - N : constant Int'Base := Int (LN) + Int (RN); - J : Int'Base; + -- Neither of the vector parameters is empty, so must compute the length + -- of the result vector and its last index. (This is the harder case, + -- because our computations must avoid overflow.) - begin - -- 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. + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the combined lengths. Note that we cannot + -- simply add the lengths, because of the possibilty of overflow. - if N > Count_Type'Pos (Count_Type'Last) then + if LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + N := LN + RN; + + -- The second constraint is that the new Last index value cannot + -- exceed Index_Type'Last. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. + + if Index_Type'Base'Last >= Count_Type'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. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then raise Constraint_Error with "new length is out of range"; end if; - -- We now 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. + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - if Index_Type'First <= 0 then + Last := No_Index + Index_Type'Base (N); - -- 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. + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: - 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; + if Last > Index_Type'Last then + raise Constraint_Error with "new length is out of range"; end if; - declare - Last : constant Index_Type := Index_Type (J); + 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. - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + J := Count_Type'Base (No_Index) + N; -- Last - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); + if J > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; - Elements : constant Elements_Access := - new Elements_Type'(Last, LE & RE); + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: - begin - return (Controlled with Elements, Last, 0, 0); - end; + Last := Index_Type'Base (J); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + J := Count_Type'Base (Index_Type'Last) - N; -- No_Index + + if J < Count_Type'Base (No_Index) then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We have determined that the result length would not create a Last + -- index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + N); + end if; + + declare + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + + Elements : constant Elements_Access := + new Elements_Type'(Last, LE & RE); + + begin + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Left) + -- is empty. + if Left.Is_Empty then declare Elements : constant Elements_Access := @@ -168,8 +211,10 @@ package body Ada.Containers.Vectors is end; end if; - -- We must satisfy two constraints: the new length cannot exceed - -- Count_Type'Last, and the new Last index cannot exceed + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed -- Index_Type'Last. if Left.Length = Count_Type'Last then @@ -198,6 +243,14 @@ package body Ada.Containers.Vectors is function "&" (Left : Element_Type; Right : Vector) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Right) + -- is empty. + if Right.Is_Empty then declare Elements : constant Elements_Access := @@ -210,8 +263,10 @@ package body Ada.Containers.Vectors is end; end if; - -- We must satisfy two constraints: the new length cannot exceed - -- Count_Type'Last, and the new Last index cannot exceed + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed -- Index_Type'Last. if Right.Length = Count_Type'Last then @@ -240,6 +295,17 @@ package body Ada.Containers.Vectors is function "&" (Left, Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We must compute the length of the result vector and its last index, + -- but in such a way that overflow is avoided. We must satisfy two + -- constraints: the new length cannot exceed Count_Type'Last (here, we + -- know that that condition is satisfied), and the new Last index cannot + -- exceed Index_Type'Last. + if Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -401,56 +467,117 @@ package body Ada.Containers.Vectors is Index : Extended_Index; Count : Count_Type := 1) is + Old_Last : constant Index_Type'Base := Container.Last; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + J : Index_Type'Base; -- first index of items that slide down + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; - if Index > Container.Last then - if Index > Container.Last + 1 then + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; return; end if; + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + if Count = 0 then return; end if; + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + 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; + + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. + + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; + + -- There are some elements aren't being deleted (the requested count was + -- less than the available count), so we must slide them down to + -- Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. For the elements that slide down, + -- index value New_Last is the last index value of their new home, and + -- index value J is the first index of their old home. + + 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); + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, but we have that guarantee here because we know we have + -- elements to slide. The array index values for each slice have + -- already been determined, so we just slide down to Index the elements + -- that weren't deleted. + declare - I_As_Int : constant Int := Int (Index); - Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); - - Count1 : constant Int'Base := Count_Type'Pos (Count); - Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; - N : constant Int'Base := Int'Min (Count1, Count2); - - J_As_Int : constant Int'Base := I_As_Int + N; + EA : Elements_Array renames Container.Elements.EA; begin - if J_As_Int > Old_Last_As_Int then - Container.Last := Index - 1; - - else - declare - J : constant Index_Type := Index_Type (J_As_Int); - EA : Elements_Array renames Container.Elements.EA; - - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; - New_Last : constant Index_Type := - Index_Type (New_Last_As_Int); - - begin - EA (Index .. New_Last) := EA (J .. Container.Last); - Container.Last := New_Last; - end; - end if; + EA (Index .. New_Last) := EA (J .. Old_Last); + Container.Last := New_Last; end; end Delete; @@ -507,24 +634,47 @@ package body Ada.Containers.Vectors is (Container : in out Vector; Count : Count_Type := 1) is - Index : Int'Base; - begin + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + if Count = 0 then return; end if; + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) + if Count >= Container.Length then Container.Last := No_Index; + elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := Container.Last - Index_Type'Base (Count); + else - Index := Int (Container.Last) - Int (Count); - Container.Last := Index_Type (Index); + Container.Last := + Index_Type'Base (Count_Type'Base (Container.Last) - Count); end if; end Delete_Last; @@ -804,22 +954,42 @@ package body Ada.Containers.Vectors is New_Item : Element_Type; Count : Count_Type := 1) is - N : constant Int := Count_Type'Pos (Count); + Old_Length : constant Count_Type := Container.Length; - 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); + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - Dst : Elements_Access; + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -827,67 +997,192 @@ package body Ada.Containers.Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- 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 current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length 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. + + 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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Last_As_Int := Old_Last_As_Int + N; + 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. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + 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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + Int'(1)); + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; - end if; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; - New_Last := Index_Type (New_Last_As_Int); - end; + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + 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; + + if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In order to preserve container invariants, we allocate the new + -- internal array first, before setting the Last index value, in case + -- the allocation fails (which can happen either because there is no + -- storage available, or because element initialization fails). + + Container.Elements := new Elements_Type' + (Last => New_Last, + EA => (others => New_Item)); + + -- The allocation of the new, internal array succeeded, so it is now + -- safe to update the Last index, restoring container invariants. + + Container.Last := New_Last; + + return; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - if Container.Elements = null then - Container.Elements := new Elements_Type' - (Last => New_Last, - EA => (others => New_Item)); - Container.Last := New_Last; - return; - end if; + -- An internal array has already been allocated, so we must determine + -- whether there is enough unused storage for the new items. + + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. - if New_Last <= Container.Elements.Last then declare EA : Elements_Array renames Container.Elements.EA; begin - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. - Index : constant Index_Type := Index_Type (Index_As_Int); - - begin - EA (Index .. New_Last) := EA (Before .. Container.Last); - - EA (Before .. Index_Type'Pred (Index)) := - (others => New_Item); - end; + EA (Before .. New_Last) := (others => New_Item); else - EA (Before .. New_Last) := (others => New_Item); + -- The new items are 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 + -- 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; + + EA (Index .. New_Last) := EA (Before .. Container.Last); + EA (Before .. Index - 1) := (others => New_Item); end if; end; @@ -895,67 +1190,79 @@ package body Ada.Containers.Vectors is return; end if; + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; + + New_Capacity := 2 * New_Capacity; + end loop; + + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) + + New_Capacity := Max_Length; + end if; + + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. + + 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); + end if; + + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array, object SA below) to the new array (the "destination" array, + -- object DA below), and then deallocate the old array. + declare - C, CC : UInt; + SA : Elements_Array renames Container.Elements.EA; -- source + DA : Elements_Array renames Dst.EA; -- destination begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; + DA (Index_Type'First .. Before - 1) := + SA (Index_Type'First .. Before - 1); + + if Before > Container.Last then + DA (Before .. New_Last) := (others => New_Item); + + else + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. + + 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; - C := 2 * C; - end loop; - - if C > Max_Length then - C := Max_Length; - end if; - - 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 + UInt'Pos (C) - 1); - - begin - Dst := new Elements_Type (Dst_Last); - end; - end; - - declare - SA : Elements_Array renames Container.Elements.EA; - DA : Elements_Array renames Dst.EA; - - begin - DA (Index_Type'First .. Index_Type'Pred (Before)) := - SA (Index_Type'First .. Index_Type'Pred (Before)); - - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; - - Index : constant Index_Type := Index_Type (Index_As_Int); - - begin - DA (Before .. Index_Type'Pred (Index)) := (others => New_Item); - DA (Index .. New_Last) := SA (Before .. Container.Last); - end; - - else - DA (Before .. New_Last) := (others => New_Item); + DA (Before .. Index - 1) := (others => New_Item); + DA (Index .. New_Last) := SA (Before .. Container.Last); end if; exception when others => @@ -963,11 +1270,23 @@ package body Ada.Containers.Vectors is raise; end; + -- We have successfully copied the items onto the new array, so the + -- final thing to do is deallocate the old array. + 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 + -- deallocate the old array (which can fail if finalization of + -- elements propagates an exception). + Container.Elements := Dst; Container.Last := New_Last; + + -- The container invariants have been restored, so it is now safe to + -- attempt to deallocate the old array. + Free (X); end; end Insert; @@ -978,83 +1297,118 @@ package body Ada.Containers.Vectors is New_Item : Vector) is N : constant Count_Type := Length (New_Item); + J : Index_Type'Base; begin - if Before < Index_Type'First then - 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 with - "Before index is out of range (too large)"; - end if; - - if N = 0 then - return; - end if; + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. Insert_Space (Container, Before, Count => N); - declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; + if N = 0 then + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + return; + end if; + + -- We calculate the last index value of the destination slice using the + -- wider of Index_Type'Base and count_Type'Base. + + 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; + + if Container'Address /= New_Item'Address then + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. + + Container.Elements.EA (Before .. J) := + New_Item.Elements.EA (Index_Type'First .. New_Item.Last); + + return; + end if; + + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The destination is always the + -- range [Before, J], but the source is [Index_Type'First, Before) and + -- (J, Container.Last]. We perform the copy in two steps, using each of + -- the two slices of the source items. + + declare + L : constant Index_Type'Base := Before - 1; + + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. L; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + K : Index_Type'Base; begin - if Container'Address /= New_Item'Address then - Container.Elements.EA (Before .. Dst_Last) := - New_Item.Elements.EA (Index_Type'First .. New_Item.Last); + -- We first copy the source items that precede the space we + -- inserted. Index value K is the last index of that portion + -- destination that receives this slice of the source. (If Before + -- equals Index_Type'First, then this first source slice will be + -- empty, which is harmless.) + + 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; + + Container.Elements.EA (Before .. K) := Src; + + if Src'Length = N then + -- The new items were effectively appended to the container, so we + -- have already copied all of the items that need to be copied. + -- We return early here, even though the source slice below is + -- empty (so the assignment would be harmless), because we want to + -- avoid computing J + 1, which will overflow if J equals + -- Index_Type'Base'Last. return; end if; + end; - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Before - 1; + declare + -- Note that we want to avoid computing J + 1 here, in case J equals + -- Index_Type'Base'Last. We prevent that by returning early above, + -- immediately after copying the first slice of the source, and + -- determining that this second slice of the source is empty. - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + F : constant Index_Type'Base := J + 1; - Index_As_Int : constant Int'Base := - Int (Before) + Src'Length - 1; + subtype Src_Index_Subtype is Index_Type'Base range + F .. Container.Last; - Index : constant Index_Type'Base := - Index_Type'Base (Index_As_Int); + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); - Dst : Elements_Array renames - Container.Elements.EA (Before .. Index); + K : Index_Type'Base; - begin - Dst := Src; - end; + begin + -- We next copy the source items that follow the space we + -- inserted. Index value K is the first index of that portion of the + -- destination that receives this slice of the source. (For the + -- reasons given above, this slice is guaranteed to be non-empty.) - if Dst_Last = Container.Last then - return; + 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; - declare - subtype Src_Index_Subtype is Index_Type'Base range - Dst_Last + 1 .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - Index_As_Int : constant Int'Base := - Dst_Last_As_Int - Src'Length + 1; - - Index : constant Index_Type := - Index_Type (Index_As_Int); - - Dst : Elements_Array renames - Container.Elements.EA (Index .. Dst_Last); - - begin - Dst := Src; - end; + Container.Elements.EA (K .. J) := Src; end; end Insert; @@ -1256,22 +1610,42 @@ package body Ada.Containers.Vectors is Before : Extended_Index; Count : Count_Type := 1) is - N : constant Int := Count_Type'Pos (Count); + Old_Length : constant Count_Type := Container.Length; - 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); + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - Dst : Elements_Access; + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1279,58 +1653,184 @@ package body Ada.Containers.Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- 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 current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length 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. + + 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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Last_As_Int := Old_Last_As_Int + N; + 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. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + 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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + Int'(1)); + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; - end if; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; - New_Last := Index_Type (New_Last_As_Int); - end; + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + 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; + + if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In order to preserve container invariants, we allocate the new + -- internal array first, before setting the Last index value, in case + -- the allocation fails (which can happen either because there is no + -- storage available, or because default-valued element + -- initialization fails). + + Container.Elements := new Elements_Type (New_Last); + + -- The allocation of the new, internal array succeeded, so it is now + -- safe to update the Last index, restoring container invariants. + + Container.Last := New_Last; + + return; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - if Container.Elements = null then - Container.Elements := new Elements_Type (New_Last); - Container.Last := New_Last; - return; - end if; + -- An internal array has already been allocated, so we must determine + -- whether there is enough unused storage for the new items. if New_Last <= Container.Elements.Last then + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, and the existing array has enough + -- unused storage for the new items. + declare EA : Elements_Array renames Container.Elements.EA; + begin if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The 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 + -- Count_Type'Base as the type for intermediate index values. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - EA (Index .. New_Last) := EA (Before .. Container.Last); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + EA (Index .. New_Last) := EA (Before .. Container.Last); end if; end; @@ -1338,63 +1838,75 @@ package body Ada.Containers.Vectors is return; end if; - declare - C, CC : UInt; + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; - - C := 2 * C; - end loop; - - if C > Max_Length then - C := Max_Length; + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; end if; - 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; + New_Capacity := 2 * New_Capacity; + end loop; - if C > CC then - C := CC; - end if; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - 1); + New_Capacity := Max_Length; + end if; - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. + + 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); + end if; + + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array, object SA below) to the new array (the "destination" array, + -- object DA below), and then deallocate the old array. declare - SA : Elements_Array renames Container.Elements.EA; - DA : Elements_Array renames Dst.EA; + SA : Elements_Array renames Container.Elements.EA; -- source + DA : Elements_Array renames Dst.EA; -- destination begin - DA (Index_Type'First .. Index_Type'Pred (Before)) := - SA (Index_Type'First .. Index_Type'Pred (Before)); + DA (Index_Type'First .. Before - 1) := + SA (Index_Type'First .. Before - 1); if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The space is being inserted before some existing elements, so + -- we must slide the existing elements up to their new home. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - DA (Index .. New_Last) := SA (Before .. Container.Last); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + DA (Index .. New_Last) := SA (Before .. Container.Last); end if; exception when others => @@ -1402,11 +1914,24 @@ package body Ada.Containers.Vectors is raise; end; + -- We have successfully copied the items onto the new array, so the + -- final thing to do is restore invariants, and deallocate the old + -- array. + 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 + -- deallocate the old array (which can fail if finalization of + -- elements propagates an exception). + Container.Elements := Dst; Container.Last := New_Last; + + -- The container invariants have been restored, so it is now safe to + -- attempt to deallocate the old array. + Free (X); end; end Insert_Space; @@ -1533,12 +2058,33 @@ package body Ada.Containers.Vectors is ------------ function Length (Container : Vector) return Count_Type is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; begin - return Count_Type (N); + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; end Length; ---------- @@ -1799,17 +2345,51 @@ package body Ada.Containers.Vectors is is N : constant Count_Type := Length (Container); + Index : Count_Type'Base; + Last : Index_Type'Base; + begin + -- Reserve_Capacity can be used to either expand the storage available + -- for elements (this would be its typical use, in anticipation of + -- future insertion), or to trim back storage. In the latter case, + -- storage can only be trimmed back to the limit of the container + -- length. Note that Reserve_Capacity neither deletes (active) elements + -- nor inserts elements; it only affects container capacity, never + -- container length. + if Capacity = 0 then + -- This is a request to trim back storage, to the minimum amount + -- possible given the current state of the container. + if N = 0 then + -- The container is empty, so in this unique case we can + -- deallocate the entire internal array. Note that an empty + -- container can never be busy, so there's no need to check the + -- tampering bits. + declare X : Elements_Access := Container.Elements; begin + -- First we remove the internal array from the container, to + -- handle the case when the deallocation raises an exception. + Container.Elements := null; + + -- Container invariants have been restored, so it is now safe + -- to attempt to deallocate the internal array. + Free (X); end; elsif N < Container.Elements.EA'Length then + -- The container is not empty, and the current length is less than + -- the current capacity, so there's storage available to trim. In + -- this case, we allocate a new internal array having a length + -- that exactly matches the number of items in the + -- container. (Reserve_Capacity does not delete active elements, + -- so this is the best we can do with respect to minimizing + -- storage). + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -1825,7 +2405,23 @@ package body Ada.Containers.Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (either because there is not enough + -- storage, or because initialization of the elements fails), + -- we let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to attempt to deallocate the old array. The old array + -- has been isolated, and container invariants have been + -- restored, so if the deallocation fails (because finalization + -- of the elements fails), we simply let it propagate. + Free (X); end; end if; @@ -1833,29 +2429,102 @@ package body Ada.Containers.Vectors is return; end if; + -- Reserve_Capacity can be used to expand the storage available for + -- elements, but we do not let the capacity grow beyond the number of + -- values in Index_Type'Range. (Were it otherwise, there would be no way + -- to refer to the elements with an index value greater than + -- Index_Type'Last, so that storage would be wasted.) Here we compute + -- the Last index value of the new internal array, in a way that avoids + -- any possibility of overflow. + + 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. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Capacity); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Capacity is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Capacity. + + Index := Count_Type'Base (No_Index) + Capacity; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We have determined that the value of Capacity would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); + end if; + + -- The requested capacity is non-zero, but we don't know yet whether + -- this is a request for expansion or contraction of storage. + if Container.Elements = null then - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; - - begin - if Last_As_Int > Index_Type'Pos (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); - - begin - Container.Elements := new Elements_Type (Last); - end; - end; + -- The container is empty (it doesn't even have an internal array), + -- so this represents a request to allocate (expand) storage having + -- the given capacity. + Container.Elements := new Elements_Type (Last); return; end if; if Capacity <= N then + -- This is a request to trim back storage, but only to the limit of + -- what's already in the container. (Reserve_Capacity never deletes + -- active elements, it only reclaims excess storage.) + if N < Container.Elements.EA'Length then + -- The container is not empty (because the requested capacity is + -- positive, and less than or equal to the container length), and + -- the current length is less than the current capacity, so + -- there's storage available to trim. In this case, we allocate a + -- new internal array having a length that exactly matches the + -- number of items in the container. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -1871,63 +2540,99 @@ package body Ada.Containers.Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (either because there is not enough + -- storage, or because initialization of the elements fails), + -- we let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to attempt to deallocate the old array. The old array + -- has been isolated, and container invariants have been + -- restored, so if the deallocation fails (because finalization + -- of the elements fails), we simply let it propagate. + Free (X); end; - end if; return; end if; + -- The requested capacity is larger than the container length (the + -- number of active elements). Whether this represents a request for + -- expansion or contraction of the current capacity depends on what the + -- current capacity is. + if Capacity = Container.Elements.EA'Length then + -- The requested capacity matches the existing capacity, so there's + -- nothing to do here. We treat this case as a no-op, and simply + -- return without checking the busy bit. + return; end if; + -- There is a change in the capacity of a non-empty container, so a new + -- internal array will be allocated. (The length of the new internal + -- array could be less or greater than the old internal array. We know + -- only that the length of the new internal array is greater than the + -- number of active elements in the container.) We must check whether + -- the container is busy before doing anything else. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- We now allocate a new internal array, having a length different from + -- its current value. + declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + E : Elements_Access := new Elements_Type (Last); begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We have successfully allocated the new internal array. We first + -- attempt to copy the existing elements from the old internal array + -- ("src" elements) onto the new internal array ("tgt" elements). declare - Last : constant Index_Type := Index_Type (Last_As_Int); + subtype Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; - E : Elements_Access := new Elements_Type (Last); + Src : Elements_Array renames + Container.Elements.EA (Index_Subtype); + + Tgt : Elements_Array renames E.EA (Index_Subtype); begin - declare - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + Tgt := Src; - Src : Elements_Array renames - Container.Elements.EA (Index_Subtype); + exception + when others => + Free (E); + raise; + end; - Tgt : Elements_Array renames E.EA (Index_Subtype); + -- We have successfully copied the existing elements onto the new + -- internal array, so now we can attempt to deallocate the old one. - begin - Tgt := Src; + declare + X : Elements_Access := Container.Elements; + begin + -- First we isolate the old internal array, and replace it in the + -- container with the new internal array. - exception - when others => - Free (E); - raise; - end; + Container.Elements := E; - declare - X : Elements_Access := Container.Elements; - begin - Container.Elements := E; - Free (X); - end; + -- Container invariants have been restored, so it is now safe to + -- attempt to deallocate the old internal array. + + Free (X); end; end; end Reserve_Capacity; @@ -2055,26 +2760,25 @@ package body Ada.Containers.Vectors is ---------------- procedure Set_Length (Container : in out Vector; Length : Count_Type) is + Count : constant Count_Type'Base := Container.Length - Length; + begin - if Length = Vectors.Length (Container) then - return; - end if; + -- Set_Length allows the user to set the length explicitly, instead of + -- implicitly as a side-effect of deletion or insertion. If the + -- requested length is less then the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent to + -- inserting "space" (nonce items) at the end. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; + if Count >= 0 then + Container.Delete_Last (Count); - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; + elsif Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Length) - 1; - begin - Container.Last := Index_Type'Base (Last_As_Int); - end; + else + Container.Insert_Space (Container.Last + 1, -Count); + end if; end Set_Length; ---------- @@ -2167,8 +2871,8 @@ package body Ada.Containers.Vectors is --------------- function To_Vector (Length : Count_Type) return Vector is - Index : Int'Base; - Last : Index_Type; + Index : Count_Type'Base; + Last : Index_Type'Base; Elements : Elements_Access; begin @@ -2181,41 +2885,71 @@ package body Ada.Containers.Vectors is -- 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. + -- create a Last index value greater than Index_Type'Last. - 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); + 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. - if Index > Int (Index_Type'Last) then + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + 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; + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - if Index < Int (Index_Type'First) then + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) 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); + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); end if; - Last := Index_Type (Index); Elements := new Elements_Type (Last); return Vector'(Controlled with Elements, Last, 0, 0); @@ -2225,8 +2959,8 @@ package body Ada.Containers.Vectors is (New_Item : Element_Type; Length : Count_Type) return Vector is - Index : Int'Base; - Last : Index_Type; + Index : Count_Type'Base; + Last : Index_Type'Base; Elements : Elements_Access; begin @@ -2239,41 +2973,71 @@ package body Ada.Containers.Vectors is -- 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. + -- create a Last index value greater than Index_Type'Last. - 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); + 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. - if Index > Int (Index_Type'Last) then + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + 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; + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - if Index < Int (Index_Type'First) then + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) 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); + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); end if; - Last := Index_Type (Index); Elements := new Elements_Type'(Last, EA => (others => New_Item)); return Vector'(Controlled with Elements, Last, 0, 0); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 85773c91ad7..11b3a9f9102 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1574,7 +1574,8 @@ ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/elists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/elists.ads \ @@ -1735,29 +1736,20 @@ ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_cg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_cg.ads ada/exp_cg.adb \ - ada/exp_ch11.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/exp_cg.ads ada/exp_cg.adb ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_disp.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1833,8 +1825,8 @@ ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ ada/exp_ch3.ads ada/exp_ch3.adb ada/exp_ch4.ads ada/exp_ch6.ads \ @@ -1842,27 +1834,24 @@ ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_pakd.ads ada/exp_smem.ads ada/exp_strm.ads ada/exp_tss.ads \ ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/urealp.ads ada/validsw.ads ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1949,21 +1938,21 @@ ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_mech.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ ada/widechar.ads @@ -2030,21 +2019,21 @@ ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch11.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch11.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elab.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2108,10 +2097,10 @@ ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ @@ -2126,33 +2115,26 @@ ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_atag.ads ada/exp_ch11.ads \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_dist.adb ada/exp_strm.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/exp_atag.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_dist.adb ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2203,7 +2185,7 @@ ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2767,31 +2749,23 @@ ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib-util.ads ada/lib-util.adb ada/lib-xref.ads ada/lib-xref.adb \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ + ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib-util.ads \ + ada/lib-util.adb ada/lib-xref.ads ada/lib-xref.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads \ + ada/osint-c.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_prag.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads ada/lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \ @@ -3328,26 +3302,26 @@ ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ ada/scng.adb ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/widechar.ads + ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ + ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/snames.adb ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads \ + ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/validsw.ads ada/widechar.ads ada/sem_aux.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3546,23 +3520,23 @@ ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb \ - ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_case.ads \ + ada/sem_case.adb ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_mech.ads ada/sem_res.ads \ + ada/sem_scil.ads ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ ada/validsw.ads ada/widechar.ads @@ -3647,25 +3621,25 @@ ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch6.adb ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch6.adb \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads \ + ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3778,11 +3752,11 @@ ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_disp.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_disp.adb ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ @@ -3843,29 +3817,19 @@ ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elim.ads ada/sem_elim.adb \ - ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_elim.ads \ + ada/sem_elim.adb ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ ada/urealp.ads ada/widechar.ads @@ -3882,23 +3846,24 @@ ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ + ada/sem_ch13.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads ada/sem_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3949,25 +3914,25 @@ ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.ads \ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_prag.adb \ - ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads \ + ada/sem_prag.adb ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ ada/validsw.ads ada/widechar.ads diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 9fe022bbd22..31d97c74711 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -8869,7 +8869,8 @@ A.5.2(32). @end cartouche @noindent The algorithm is the Mersenne Twister, as documented in the source file -@file{s-rannum.adb}. +@file{s-rannum.adb}. This version of the algorithm has a period of +2**19937-1. @sp 1 @cartouche diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb index 29a8e949c82..aa6191344df 100644 --- a/gcc/ada/s-rannum.adb +++ b/gcc/ada/s-rannum.adb @@ -191,17 +191,21 @@ package body System.Random_Numbers is generic type Unsigned is mod <>; type Real is digits <>; - with function Shift_Right (Value : Unsigned; Amount : Natural) - return Unsigned is <>; with function Random (G : Generator) return Unsigned is <>; function Random_Float_Template (Gen : Generator) return Real; pragma Inline (Random_Float_Template); -- Template for a random-number generator implementation that delivers - -- values of type Real in the half-open range [0 .. 1), using values from - -- Gen, assuming that Unsigned is large enough to hold the bits of - -- a mantissa for type Real. + -- values of type Real in the range [0 .. 1], using values from Gen, + -- assuming that Unsigned is large enough to hold the bits of a mantissa + -- for type Real. function Random_Float_Template (Gen : Generator) return Real is + + pragma Compile_Time_Error + (Unsigned'Last <= 2**(Real'Machine_Mantissa - 1), + "insufficiently large modular type used to hold mantissa"); + + begin -- This code generates random floating-point numbers from unsigned -- integers. Assuming that Real'Machine_Radix = 2, it can deliver all -- machine values of type Real (as implied by Real'Machine_Mantissa and @@ -210,69 +214,118 @@ package body System.Random_Numbers is -- integer>) / (+1). To do so, we first extract an -- (M-1)-bit significand (where M is Real'Machine_Mantissa), and then -- decide on a normalized exponent by repeated coin flips, decrementing - -- from 0 as long as we flip heads (1 bits). This yields the proper - -- geometric distribution for the exponent: in a uniformly distributed - -- set of floating-point numbers, 1/2 of them will be in [0.5, 1), 1/4 - -- will be in [0.25, 0.5), and so forth. If the process reaches - -- Machine_Emin (an extremely rare event), it uses the selected mantissa - -- bits as an unnormalized fraction with Machine_Emin as exponent. - -- Otherwise, it adds a leading bit to the selected mantissa bits (thus - -- giving a normalized fraction) and adjusts by the chosen exponent. The - -- algorithm attempts to be stingy with random integers. In the worst - -- case, it can consume roughly -Real'Machine_Emin/32 32-bit integers, - -- but this case occurs with probability 2**Machine_Emin, and the - -- expected number of calls to integer-valued Random is 1. + -- from 0 as long as we flip heads (1 bits). This process yields the + -- proper geometric distribution for the exponent: in a uniformly + -- distributed set of floating-point numbers, 1/2 of them will be in + -- (0.5, 1], 1/4 will be in (0.25, 0.5], and so forth. It makes a + -- further adjustment at binade boundaries (see comments below) to give + -- the effect of selecting a uniformly distributed real deviate in + -- [0..1] and then rounding to the nearest representable floating-point + -- number. The algorithm attempts to be stingy with random integers. In + -- the worst case, it can consume roughly -Real'Machine_Emin/32 32-bit + -- integers, but this case occurs with probability around + -- 2**Machine_Emin, and the expected number of calls to integer-valued + -- Random is 1. For another discussion of the issues addressed by this + -- process, see Allen Downey's unpublished paper at + -- http://allendowney.com/research/rand/downey07randfloat.pdf. - begin if Real'Machine_Radix /= 2 then - declare - Val : constant Real := - Real'Machine - (Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size)); - begin - if Val < 1.0 then - return Real'Base (Val); - else - return Real'Pred (1.0); - end if; - end; - + return Real'Machine + (Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size)); else declare - Mant_Bits : constant Integer := Real'Machine_Mantissa - 1; - Mant_Mask : constant Unsigned := 2**Mant_Bits - 1; - Adjust32 : constant Integer := Real'Size - Unsigned_32'Size; - Leftover : constant Integer := - Unsigned'Size - Real'Machine_Mantissa + 1; - V : constant Unsigned := Random (Gen); - Mant : constant Unsigned := V and Mant_Mask; - Rand_Bits : Unsigned_32; - Exp : Integer; - Bits_Left : Integer; - Result : Real; + type Bit_Count is range 0 .. 4; + subtype T is Real'Base; + + Trailing_Ones : constant array (Unsigned_32 range 0 .. 15) + of Bit_Count + := (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2, + 2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3, + 2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2, + 2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4); + + Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real + := (0 => 2.0**(0 - T'Machine_Mantissa), + 1 => 2.0**(-1 - T'Machine_Mantissa), + 2 => 2.0**(-2 - T'Machine_Mantissa), + 3 => 2.0**(-3 - T'Machine_Mantissa)); + + Extra_Bits : constant Natural := + (Unsigned'Size - T'Machine_Mantissa + 1); + -- Random bits left over after selecting mantissa + + Mantissa : Unsigned; + X : Real; -- Scaled mantissa + R : Unsigned_32; -- Supply of random bits + R_Bits : Natural; -- Number of bits left in R + + K : Bit_Count; -- Next decrement to exponent begin - Rand_Bits := Unsigned_32 (Shift_Right (V, Adjust32)); - Exp := 0; - Bits_Left := Leftover; - Result := Real (Mant + 2**Mant_Bits) * 2.0**(-Mant_Bits - 1); - while Rand_Bits >= 2**31 loop - if Exp = Real'Machine_Emin then - return Real (Mant) * 2.0**Real'Machine_Emin; - end if; - Result := Result * 0.5; - Exp := Exp - 1; - Rand_Bits := 2 * Rand_Bits; - Bits_Left := Bits_Left - 1; + Mantissa := Random (Gen) / 2**Extra_Bits; + R := Unsigned_32 (Mantissa mod 2**Extra_Bits); + R_Bits := Extra_Bits; + X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact - if Bits_Left = 0 then - Bits_Left := 32; - Rand_Bits := Random (Gen); - end if; - end loop; + if Extra_Bits < 4 and then R < 2**Extra_Bits - 1 then + -- We got lucky and got a zero in our few extra bits + K := Trailing_Ones (R); - return Result; + else + Find_Zero : loop + + -- R has R_Bits unprocessed random bits, a multiple of 4. + -- X needs to be halved for each trailing one bit. The + -- process stops as soon as a 0 bit is found. If R_Bits + -- becomes zero, reload R. + + -- Process 4 bits at a time for speed: the two iterations + -- on average with three tests each was still too slow, + -- probably because the branches are not predictable. + -- This loop now will only execute once 94% of the cases, + -- doing more bits at a time will not help. + + while R_Bits >= 4 loop + K := Trailing_Ones (R mod 16); + + exit Find_Zero when K < 4; -- Exits 94% of the time + + R_Bits := R_Bits - 4; + X := X / 16.0; + R := R / 16; + end loop; + + -- Do not allow us to loop endlessly even in the (very + -- unlikely) case that Random (Gen) keeps yielding all ones. + + exit Find_Zero when X = 0.0; + R := Random (Gen); + R_Bits := 32; + end loop Find_Zero; + end if; + + -- K has the count of trailing ones not reflected yet in X. + -- The following multiplication takes care of that, as well + -- as the correction to move the radix point to the left of + -- the mantissa. Doing it at the end avoids repeated rounding + -- errors in the exceedingly unlikely case of ever having + -- a subnormal result. + + X := X * Pow_Tab (K); + + -- The smallest value in each binade is rounded to by 0.75 of + -- the span of real numbers as its next larger neighbor, and + -- 1.0 is rounded to by half of the span of real numbers as its + -- next smaller neighbor. To account for this, when we encounter + -- the smallest number in a binade, we substitute the smallest + -- value in the next larger binade with probability 1/2. + + if Mantissa = 0 and then Unsigned_32'(Random (Gen)) mod 2 = 0 then + X := 2.0 * X; + end if; + + return X; end; end if; end Random_Float_Template;