diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 35 | ||||
| -rw-r--r-- | gcc/ada/Makefile.rtl | 1 | ||||
| -rw-r--r-- | gcc/ada/a-cobove.adb | 2439 | ||||
| -rw-r--r-- | gcc/ada/a-cobove.ads | 369 | ||||
| -rw-r--r-- | gcc/ada/a-contai.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/scos.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 1111 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 131 | ||||
| -rw-r--r-- | gcc/ada/sem_warn.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/uname.adb | 4 |
14 files changed, 3765 insertions, 385 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7d3f1600a7a..8e07f6d20ee 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2010-10-25 Matthew Heaney <heaney@adacore.com> + + * Makefile.rtl, impunit.adb: Added a-cobove (bounded vector container) + to lists. + * a-contai.ads: Added declaration of Capacity_Error exception. + * a-cobove.ads, a-cobove.adb: New files. + +2010-10-25 Thomas Quinot <quinot@adacore.com> + + * uname.adb: Revert previous change, no longer needed after change + in par-ch10.adb. + +2010-10-25 Thomas Quinot <quinot@adacore.com> + + * scos.ads: Minor comment fix. + +2010-10-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Assignment_Statement): Check dangerous order + dependence. + * sem_ch6.adb (Analyze_Procedure_Call_Statement): Ditto. + * sem_res.adb (Analyze_Actuals): Add actual to list of actuals for + current construct, for subsequent order dependence checking. + (Resolve): Check order dependence on expressions that are not + subexpressions. + * sem_util.adb (Check_Order_Dependence): Code cleanup, to correspond + to latest version of AI05-144-2. + * sem_warn.adb (Warn_On_Overlapping_Actuals): Code cleanup. + +2010-10-25 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb (Build_Static_Predicate): Moved out of + Build_Predicate_Function. + (Build_Static_Predicate): Complet rewrite for more general predicates + 2010-10-25 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> Eric Botcazou <ebotcazou@adacore.com> diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 229724c2b1c..a444b1770bf 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -114,6 +114,7 @@ GNATRTL_NONTASKING_OBJS= \ a-comlin$(objext) \ a-contai$(objext) \ a-convec$(objext) \ + a-cobove$(objext) \ a-coorma$(objext) \ a-coormu$(objext) \ a-coorse$(objext) \ diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb new file mode 100644 index 00000000000..8a71a0cd52b --- /dev/null +++ b/gcc/ada/a-cobove.adb @@ -0,0 +1,2439 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- +-- -- +-- B o d y -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with System; use type System.Address; + +package body Ada.Containers.Bounded_Vectors is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; + + --------- + -- "&" -- + --------- + + function "&" (Left, Right : Vector) return Vector is + 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; + end if; + + return Vector'(Capacity => RN, + Elements => Right.Elements (1 .. RN), + Last => Right.Last, + others => <>); + end if; + + if RN = 0 then + return Vector'(Capacity => LN, + Elements => Left.Elements (1 .. LN), + Last => Left.Last, + others => <>); + end if; + + -- 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.) + + -- 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 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 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 (N); + + -- 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 "new 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. + + J := Count_Type'Base (No_Index) + N; -- Last + + if J > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "new 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 (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 (1 .. LN); + RE : Elements_Array renames Right.Elements (1 .. RN); + + begin + return Vector'(Capacity => N, + Elements => LE & RE, + Last => Last, + others => <>); + end; + end "&"; + + function "&" (Left : Vector; Right : Element_Type) return Vector is + LN : constant Count_Type := Length (Left); + + 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, and the + -- new Last index cannot exceed Index_Type'Last. + + if LN = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if Left.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + return Vector'(Capacity => LN + 1, + Elements => Left.Elements (1 .. LN) & Right, + Last => Left.Last + 1, + others => <>); + end "&"; + + function "&" (Left : Element_Type; Right : Vector) return Vector is + RN : constant Count_Type := Length (Right); + + 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 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 RN = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if Right.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + return Vector'(Capacity => 1 + RN, + Elements => Left & Right.Elements (1 .. RN), + Last => Right.Last + 1, + others => <>); + end "&"; + + 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; + + return Vector'(Capacity => 2, + Elements => (Left, Right), + Last => Index_Type'First + 1, + others => <>); + end "&"; + + --------- + -- "=" -- + --------- + + overriding function "=" (Left, Right : Vector) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Last /= Right.Last then + return False; + end if; + + for J in Count_Type range 1 .. Left.Length loop + if Left.Elements (J) /= Right.Elements (J) then + return False; + end if; + end loop; + + return True; + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Capacity_Error -- ??? + with "Target capacity is less than Source length"; + end if; + + Target.Clear; + + Target.Elements (1 .. Source.Length) := + Source.Elements (1 .. Source.Length); + + Target.Last := Source.Last; + end Assign; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if New_Item.Is_Empty then + return; + end if; + + if Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Container.Insert (Container.Last + 1, New_Item); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; + + if Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Container.Insert (Container.Last + 1, New_Item, Count); + end Append; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Count_Type is + begin + return Container.Elements'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + Container.Last := No_Index; + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Count_Type := 0) return Vector + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + return Target : Vector (C) do + Target.Elements (1 .. Source.Length) := + Source.Elements (1 .. Source.Length); + + Target.Last := Source.Last; + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1) + is + Old_Last : constant Index_Type'Base := Container.Last; + Old_Len : constant Count_Type := Container.Length; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + Off : Count_Type'Base; -- Index expressed as offset from IT'First + + 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; + + -- 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 cursors (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. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Off := Count_Type'Base (Index - Index_Type'First); + New_Last := Old_Last - Index_Type'Base (Count); + + else + Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + end if; + + -- 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 + EA : Elements_Array renames Container.Elements; + Idx : constant Count_Type := EA'First + Off; + + begin + EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); + Container.Last := New_Last; + end; + end Delete; + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1) + is + pragma Warnings (Off, Position); + + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; + + if Count >= Length (Container) then + Clear (Container); + return; + end if; + + Delete (Container, Index_Type'First, Count); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1) + is + 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 cursors (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 + Container.Last := + Index_Type'Base (Count_Type'Base (Container.Last) - Count); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + return Container.Elements (To_Array_Index (Index)); + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Position.Container.Element (Position.Index); + end Element; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + begin + if Position.Container /= null then + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; + end if; + + for J in Position.Index .. Container.Last loop + if Container.Elements (To_Array_Index (J)) = Item then + return (Container'Unrestricted_Access, J); + end if; + end loop; + + return No_Element; + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + begin + for Indx in Index .. Container.Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Find_Index; + + ----------- + -- First -- + ----------- + + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unrestricted_Access, Index_Type'First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + end if; + + return Container.Elements (To_Array_Index (Index_Type'First)); + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : Vector) return Boolean is + begin + if Container.Last <= Index_Type'First then + return True; + end if; + + declare + EA : Elements_Array renames Container.Elements; + begin + for J in 1 .. Container.Length - 1 loop + if EA (J + 1) < EA (J) then + return False; + end if; + end loop; + end; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I, J : Count_Type; + + begin + if Target.Is_Empty then + Target.Assign (Source); + return; + end if; + + if Target'Address = Source'Address then + return; + end if; + + if Source.Is_Empty then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + I := Target.Length; + Target.Set_Length (I + Source.Length); + + declare + TA : Elements_Array renames Target.Elements; + SA : Elements_Array renames Source.Elements; + + begin + J := Target.Length; + while not Source.Is_Empty loop + pragma Assert (Source.Length <= 1 + or else not (SA (Source.Length) < + SA (Source.Length - 1))); + + if I = 0 then + TA (1 .. J) := SA (1 .. Source.Length); + Source.Last := No_Index; + return; + end if; + + pragma Assert (I <= 1 + or else not (TA (I) < TA (I - 1))); + + if SA (Source.Length) < TA (I) then + TA (J) := TA (I); + I := I - 1; + + else + TA (J) := SA (Source.Length); + Source.Last := Source.Last - 1; + end if; + + J := J - 1; + end loop; + end; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) + is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Count_Type, + Element_Type => Element_Type, + Array_Type => Elements_Array, + "<" => "<"); + + begin + if Container.Last <= Index_Type'First then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + Sort (Container.Elements (1 .. Container.Length)); + end Sort; + + end Generic_Sorting; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; + + return Position.Index <= Position.Container.Last; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1) + is + EA : Elements_Array renames Container.Elements; + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + 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 + raise Constraint_Error with + "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; + + -- 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. + + 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; + + 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. + + 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; + + 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) - Count_Type'Base (No_Index); + end if; + + -- 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; + + -- 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 cursors (vector is busy)"; + end if; + + if New_Length > Container.Capacity then + raise Capacity_Error with "New length is larger than capacity"; + end if; + + J := To_Array_Index (Before); + + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. + + EA (J .. New_Length) := (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. + + EA (J + Count .. New_Length) := EA (J .. Old_Length); + EA (J .. J + Count - 1) := (others => New_Item); + end if; + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := No_Index + Index_Type'Base (New_Length); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); + B : Count_Type; -- index Before converted to Count_Type + + begin + -- 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; + + B := To_Array_Index (Before); + + 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 (B .. B + N - 1) := New_Item.Elements (1 .. N); + return; + end if; + + -- We refer to array index value Before + N - 1 as J. This is the last + -- index value of the destination slice. + + -- 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 + subtype Src_Index_Subtype is Count_Type'Base range 1 .. B - 1; + + Src : Elements_Array renames Container.Elements (Src_Index_Subtype); + + begin + -- 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.) + + Container.Elements (B .. B + Src'Length - 1) := Src; + end; + + declare + subtype Src_Index_Subtype is Count_Type'Base range + B + N .. Container.Length; + + Src : Elements_Array renames Container.Elements (Src_Index_Subtype); + + begin + -- We next copy the source items that follow the space we inserted. + + Container.Elements (B + N - Src'Length .. B + N - 1) := Src; + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Is_Empty (New_Item) then + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Is_Empty (New_Item) then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + ------------------ + -- Insert_Space -- + ------------------ + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + EA : Elements_Array renames Container.Elements; + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + 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 + raise Constraint_Error with + "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; + + -- 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. + + 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; + + 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. + + 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; + + 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) - Count_Type'Base (No_Index); + end if; + + -- 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; + + -- 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 cursors (vector is busy)"; + end if; + + -- An internal array has already been allocated, so we need to check + -- whether there is enough unused storage for the new items. + + if New_Length > Container.Capacity then + raise Capacity_Error with "New length is larger than capacity"; + end if; + + -- 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. + + if Before <= Container.Last then + -- The space is being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. + + J := To_Array_Index (Before); + EA (J + Count .. New_Length) := EA (J .. Old_Length); + 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 + Container.Last := No_Index + Index_Type'Base (New_Length); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + end Insert_Space; + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert_Space (Container, Index, Count => Count); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert_Space; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Vector) return Boolean is + begin + return Container.Last < Index_Type'First; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + + begin + B := B + 1; + + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unrestricted_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + end if; + + return Container.Elements (Container.Length); + end Last_Element; + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + + ------------ + -- Length -- + ------------ + + function Length (Container : Vector) return Count_Type is + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; + + begin + -- 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; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Vector; + Source : in out Vector) + is + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Capacity_Error -- ??? + with "Target capacity is less than Source length"; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (Target is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (Source is busy)"; + end if; + + -- Clear Target now, in case element assignment fails. + Target.Last := No_Index; + + Target.Elements (1 .. Source.Length) := + Source.Elements (1 .. Source.Length); + + Target.Last := Source.Last; + Source.Last := No_Index; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Index < Position.Container.Last then + return (Position.Container, Position.Index + 1); + end if; + + return No_Element; + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + if Position.Container = null then + return; + end if; + + if Position.Index < Position.Container.Last then + Position.Index := Position.Index + 1; + else + Position := No_Element; + end if; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out Vector; New_Item : Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, + Index_Type'First, + New_Item, + Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + if Position.Container = null then + return; + end if; + + if Position.Index > Index_Type'First then + Position.Index := Position.Index - 1; + else + Position := No_Element; + end if; + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Index > Index_Type'First then + return (Position.Container, Position.Index - 1); + end if; + + return No_Element; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; + + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (V.Elements (To_Array_Index (Index))); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end Query_Element; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + Query_Element (Position.Container.all, Position.Index, Process); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector) + is + Length : Count_Type'Base; + Last : Index_Type'Base := No_Index; + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, Length); + + Reserve_Capacity (Container, Capacity => Length); + + for Idx in Count_Type range 1 .. Length loop + Last := Last + 1; + Element_Type'Read (Stream, Container.Elements (Idx)); + Container.Last := Last; + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Read; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + Container.Elements (To_Array_Index (Index)) := New_Item; + end Replace_Element; + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + Container.Elements (To_Array_Index (Position.Index)) := New_Item; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type) + is + begin + if Capacity > Container.Capacity then + raise Constraint_Error with "Capacity is out of range"; + end if; + end Reserve_Capacity; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out Vector) is + E : Elements_Array renames Container.Elements; + Idx, Jdx : Count_Type; + + begin + if Container.Length <= 1 then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + Idx := 1; + Jdx := Container.Length; + while Idx < Jdx loop + declare + EI : constant Element_Type := E (Idx); + + begin + E (Idx) := E (Jdx); + E (Jdx) := EI; + end; + + Idx := Idx + 1; + Jdx := Jdx - 1; + end loop; + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Last : Index_Type'Base; + + begin + if Position.Container /= null + and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + Last := + (if Position.Container = null or else Position.Index > Container.Last + then Container.Last + else Position.Index); + + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + return (Container'Unrestricted_Access, Indx); + end if; + end loop; + + return No_Element; + end Reverse_Find; + + ------------------------ + -- Reverse_Find_Index -- + ------------------------ + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + Last : constant Index_Type'Base := + Index_Type'Min (Container.Last, Index); + + begin + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Reverse_Find_Index; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + + begin + B := B + 1; + + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length (Container : in out Vector; Length : Count_Type) is + Count : constant Count_Type'Base := Container.Length - Length; + + begin + -- 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 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; + end Set_Length; + + ---------- + -- Swap -- + ---------- + + procedure Swap (Container : in out Vector; I, J : Index_Type) is + E : Elements_Array renames Container.Elements; + + begin + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + + if I = J then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + declare + EI_Copy : constant Element_Type := E (To_Array_Index (I)); + begin + E (To_Array_Index (I)) := E (To_Array_Index (J)); + E (To_Array_Index (J)) := EI_Copy; + end; + end Swap; + + procedure Swap (Container : in out Vector; I, J : Cursor) is + begin + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Container = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; + end if; + + if J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; + end if; + + Swap (Container, I.Index, J.Index); + end Swap; + + -------------------- + -- To_Array_Index -- + -------------------- + + function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is + Offset : Count_Type'Base; + + begin + -- We know that + -- Index >= Index_Type'First + -- hence we also know that + -- Index - Index_Type'First >= 0 + -- + -- The issue is that even though 0 is guaranteed to be a value + -- in the type Index_Type'Base, there's no guarantee that the + -- difference is a value in that type. To prevent overflow we + -- use the wider of Count_Type'Base and Index_Type'Base to + -- perform intermediate calculations. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Offset := Count_Type'Base (Index - Index_Type'First); + + else + Offset := Count_Type'Base (Index) - + Count_Type'Base (Index_Type'First); + end if; + + -- The array index subtype for all container element arrays + -- always starts with 1. + + return 1 + Offset; + end To_Array_Index; + + --------------- + -- To_Cursor -- + --------------- + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor + is + begin + if Index not in Index_Type'First .. Container.Last then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Index); + end To_Cursor; + + -------------- + -- To_Index -- + -------------- + + function To_Index (Position : Cursor) return Extended_Index is + begin + if Position.Container = null then + return No_Index; + end if; + + if Position.Index <= Position.Container.Last then + return Position.Index; + end if; + + return No_Index; + end To_Index; + + --------------- + -- To_Vector -- + --------------- + + function To_Vector (Length : Count_Type) return Vector is + Index : Count_Type'Base; + Last : Index_Type'Base; + + begin + if Length = 0 then + return Empty_Vector; + end if; + + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + 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 (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 + -- 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) - 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 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; + + return V : Vector (Capacity => Length) do + V.Last := Last; + end return; + end To_Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector + is + Index : Count_Type'Base; + Last : Index_Type'Base; + + begin + if Length = 0 then + return Empty_Vector; + end if; + + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + 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 (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 + -- 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) - 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 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; + + return V : Vector (Capacity => Length) do + V.Elements := (others => New_Item); + V.Last := Last; + end return; + end To_Vector; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)) + is + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (Container.Elements (To_Array_Index (Index))); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end Update_Element; + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + Update_Element (Container, Position.Index, Process); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector) + is + N : Count_Type; + + begin + N := Container.Length; + Count_Type'Base'Write (Stream, N); + + for J in 1 .. N loop + Element_Type'Write (Stream, Container.Elements (J)); + end loop; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Write; + +end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads new file mode 100644 index 00000000000..30dc9aabfba --- /dev/null +++ b/gcc/ada/a-cobove.ads @@ -0,0 +1,369 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Streams; + +generic + type Index_Type is range <>; + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Vectors is + pragma Pure; + pragma Remote_Types; + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + + No_Index : constant Extended_Index := Extended_Index'First; + + type Vector (Capacity : Count_Type) is tagged private; + pragma Preelaborable_Initialization (Vector); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + overriding function "=" (Left, Right : Vector) return Boolean; + + function To_Vector (Length : Count_Type) return Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector; + + function "&" (Left, Right : Vector) return Vector; + + function "&" (Left : Vector; Right : Element_Type) return Vector; + + function "&" (Left : Element_Type; Right : Vector) return Vector; + + function "&" (Left, Right : Element_Type) return Vector; + + function Capacity (Container : Vector) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type); + + function Length (Container : Vector) return Count_Type; + + procedure Set_Length + (Container : in out Vector; + Length : Count_Type); + + function Is_Empty (Container : Vector) return Boolean; + + procedure Clear (Container : in out Vector); + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor; + + function To_Index (Position : Cursor) return Extended_Index; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type); + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Assign (Target : in out Vector; Source : Vector); + + function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; + + procedure Move (Target : in out Vector; Source : in out Vector); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Vector); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out Vector; + New_Item : Vector); + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out Vector); + + procedure Swap (Container : in out Vector; I, J : Index_Type); + + procedure Swap (Container : in out Vector; I, J : Cursor); + + function First_Index (Container : Vector) return Index_Type; + + function First (Container : Vector) return Cursor; + + function First_Element (Container : Vector) return Element_Type; + + function Last_Index (Container : Vector) return Extended_Index; + + function Last (Container : Vector) return Cursor; + + function Last_Element (Container : Vector) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index; + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index; + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean; + + function Has_Element (Position : Cursor) return Boolean; + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target : in out Vector; Source : in out Vector); + + end Generic_Sorting; + +private + + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Query_Element); + pragma Inline (Update_Element); + pragma Inline (Replace_Element); + pragma Inline (Is_Empty); + pragma Inline (Contains); + pragma Inline (Next); + pragma Inline (Previous); + + type Elements_Array is array (Count_Type range <>) of Element_Type; + function "=" (L, R : Elements_Array) return Boolean is abstract; + + type Vector (Capacity : Count_Type) is tagged record + Elements : Elements_Array (1 .. Capacity); + Last : Extended_Index := No_Index; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector); + + for Vector'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector); + + for Vector'Read use Read; + + type Vector_Access is access all Vector; + for Vector_Access'Storage_Size use 0; + + type Cursor is record + Container : Vector_Access; + Index : Index_Type := Index_Type'First; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + + Empty_Vector : constant Vector := (Capacity => 0, others => <>); + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + +end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/a-contai.ads b/gcc/ada/a-contai.ads index a453d6bacad..be8a808747b 100644 --- a/gcc/ada/a-contai.ads +++ b/gcc/ada/a-contai.ads @@ -19,4 +19,6 @@ package Ada.Containers is type Hash_Type is mod 2**32; type Count_Type is range 0 .. 2**31 - 1; + Capacity_Error : exception; + end Ada.Containers; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index e2111953859..005a246b93f 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -506,7 +506,8 @@ package body Impunit is Non_Imp_File_Names_12 : constant File_List := ( "s-multip", -- System.Multiprocessors - "s-mudido"); -- System.Multiprocessors.Dispatching_Domains + "s-mudido", -- System.Multiprocessors.Dispatching_Domains + "a-cobove"); -- Ada.Containers.Bounded_Vectors ----------------------- -- Alternative Units -- diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 8163e62300d..ca5ffb4e694 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -240,7 +240,7 @@ package SCOs is -- expression ::= |sloc term term (if expr is OR or OR ELSE) -- expression ::= !sloc term (if expr is NOT) - -- In the last four cases, sloc is the source location of the AND, OR, + -- In the last three cases, sloc is the source location of the AND, OR, -- or NOT token, respectively. -- term ::= element diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 37f9a3e7d48..ed01ac8f387 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -77,10 +77,6 @@ package body Sem_Ch13 is -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. - ----------------------- - -- Local Subprograms -- - ----------------------- - procedure Build_Predicate_Function (Typ : Entity_Id; FDecl : out Node_Id; @@ -94,6 +90,21 @@ package body Sem_Ch13 is -- and setting Predicate_Procedure for Typ. In some error situations no -- procedure is built, in which case PDecl/PBody are empty on return. + procedure Build_Static_Predicate + (Typ : Entity_Id; + Expr : Node_Id; + Nam : Name_Id); + -- Given a predicated type Typ, whose predicate expression is Expr, tests + -- if Expr is a static predicate, and if so, builds the predicate range + -- list. Nam is the name of the argument to the predicate function. + -- Occurrences of the type name in the predicate expression have been + -- replaced by identifer references to this name, which is unique, so any + -- identifier with Chars matching Nam must be a reference to the type. If + -- the predicate is non-static, this procedure returns doing nothing. If + -- the predicate is static, then the corresponding predicate list is stored + -- in Static_Predicate (Typ), and the Expr is rewritten as a canonicalized + -- membership operation. + function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding -- Uint value. If the value is inappropriate, then error messages are @@ -3851,10 +3862,6 @@ package body Sem_Ch13 is -- Inheritance of predicates for the parent type is done by calling the -- Predicate_Function of the parent type, using Add_Call above. - procedure Build_Static_Predicate; - -- This function is called to process a static predicate, and put it in - -- canonical form and store it in Static_Predicate (Typ). - Object_Name : constant Name_Id := New_Internal_Name ('I'); -- Name for argument of Predicate procedure @@ -4001,455 +4008,895 @@ package body Sem_Ch13 is end loop; end Add_Predicates; - ---------------------------- - -- Build_Static_Predicate -- - ---------------------------- + -- Start of processing for Build_Predicate_Function - procedure Build_Static_Predicate is - Exp : Node_Id; - Alt : Node_Id; + begin + -- Initialize for construction of statement list + + Expr := Empty; + FDecl := Empty; + FBody := Empty; + + -- Return if already built or if type does not have predicates + + if not Has_Predicates (Typ) + or else Present (Predicate_Function (Typ)) + then + return; + end if; + + -- Add Predicates for the current type + + Add_Predicates; + + -- Add predicates for ancestor if present + + declare + Atyp : constant Entity_Id := Nearest_Ancestor (Typ); + begin + if Present (Atyp) then + Add_Call (Atyp); + end if; + end; + + -- If we have predicates, build the function + + if Present (Expr) then + + -- Deal with static predicate case + + Build_Static_Predicate (Typ, Expr, Object_Name); + + -- Build function declaration + + pragma Assert (Has_Predicates (Typ)); + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + Set_Has_Predicates (SId); + Set_Predicate_Function (Typ, SId); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars => Object_Name), + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body + + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars => Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); - Non_Static : Boolean := False; - -- Set True if something non-static is found + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); + end if; + end Build_Predicate_Function; - Plist : List_Id := No_List; - -- The entries in Plist are either static expressions which represent - -- a possible value, or ranges of values. Subtype marks don't appear, - -- since we expand them out. + ---------------------------- + -- Build_Static_Predicate -- + ---------------------------- + + procedure Build_Static_Predicate + (Typ : Entity_Id; + Expr : Node_Id; + Nam : Name_Id) + is + Loc : constant Source_Ptr := Sloc (Expr); + Non_Static : exception; + -- Raised if something non-static is found + + TLo, THi : Uint; + -- Low bound and high bound values of static subtype of Typ + + type REnt is record Lo, Hi : Uint; - -- Low bound and high bound values of static subtype of Typ + end record; + -- One entry in a Rlist value, a single REnt (range entry) value + -- denotes one range from Lo to Hi. To represent a single value + -- range Lo = Hi = value. + + type RList is array (Nat range <>) of REnt; + -- A list of ranges. The ranges are sorted in increasing order, + -- and are disjoint (there is a gap of at least one value between + -- each range in the table). + + Null_Range : constant RList := RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); + True_Range : RList renames Null_Range; + -- Constant representing null list of ranges, used to represent a + -- predicate of True, since there are no ranges to be satisfied. + + False_Range : constant RList := RList'(1 => REnt'(Uint_1, Uint_0)); + -- Range representing false + + function "and" (Left, Right : RList) return RList; + -- And's together two range lists, returning a range list. This is + -- a set intersection operation. + + function "or" (Left, Right : RList) return RList; + -- Or's together two range lists, returning a range list. This is a + -- set union operation. + + function "not" (Right : RList) return RList; + -- Returns complement of a given range list, i.e. a range list + -- representing all the values in TLo .. THi that are not in the + -- input operand Right. + + function Build_Val (V : Uint) return Node_Id; + -- Return an analyzed N_Identifier node referencing this value, suitable + -- for use as an entry in the Static_Predicate list. + + function Build_Range (Lo, Hi : Uint) return Node_Id; + -- Return an analyzed N_Range node referencing this range, suitable + -- for use as an entry in the Static_Predicate list. + + function Get_RList (Exp : Node_Id) return RList; + -- This is a recursive routine that converts the given expression into + -- a list of ranges, suitable for use in building the static predicate. + + function Is_Type_Ref (N : Node_Id) return Boolean; + pragma Inline (Is_Type_Ref); + -- Returns if True if N is a reference to the type for the predicate in + -- the expression (i.e. if it is an identifier whose Chars field matches + -- the Nam given in the call). + + function Lo_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value or low bound of range. + + function Hi_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value of high bound of range. + + function Membership_Entry (N : Node_Id) return RList; + -- Given a single membership entry (range, value, or subtype), returns + -- the corresponding range list. Raises Static_Error if not static. + + function Membership_Entries (N : Node_Id) return RList; + -- Given an element on an alternatives list of a membership operation, + -- returns the range list corresponding to this entry and all following + -- entries (i.e. returns the "or" of this list of values). + + function Stat_Pred (Typ : Entity_Id) return RList; + -- Given a type, if it has a static predicate, then return the predicate + -- as a range list, otherwise raise Non_Static. + + ----------- + -- "and" -- + ----------- + + function "and" (Left, Right : RList) return RList is + FEnt : REnt; + -- First range of result + + SLeft : Nat := Left'First; + -- Start of rest of left entries + + SRight : Nat := Right'First; + -- Start of rest of right entries - procedure Process_Entry (N : Node_Id); - -- Process one entry (range or value or subtype mark) + begin + -- If either range is True, return the other - ------------------- - -- Process_Entry -- - ------------------- + if Left = True_Range then + return Right; + elsif Right = True_Range then + return Left; + end if; - procedure Process_Entry (N : Node_Id) is - SLo, SHi : Uint; - -- Low and high bounds of range in list + -- If either range is False, return False - P : Node_Id; + if Left = False_Range or else Right = False_Range then + return False_Range; + end if; - function Build_Val (V : Uint) return Node_Id; - -- Return an analyzed N_Identifier node referencing this value + -- If either range is empty, return False - function Build_Range (Lo, Hi : Uint) return Node_Id; - -- Return an analyzed N_Range node referencing this range + if Left'Length = 0 or else Right'Length = 0 then + return False_Range; + end if; - function Lo_Val (N : Node_Id) return Uint; - -- Given static expression or static range, gets expression value - -- or low bound of range. + -- Loop to remove entries at start that are disjoint, and thus + -- just get discarded from the result entirely. - function Hi_Val (N : Node_Id) return Uint; - -- Given static expression or static range, gets expression value - -- of high bound of range. + loop + -- If no operands left in either operand, result is false - ----------------- - -- Build_Range -- - ----------------- + if SLeft > Left'Last or else SRight > Right'Last then + return False_Range; - function Build_Range (Lo, Hi : Uint) return Node_Id is - Result : Node_Id; - begin - if Lo = Hi then - return Build_Val (Hi); - else - Result := - Make_Range (Sloc (N), - Low_Bound => Build_Val (Lo), - High_Bound => Build_Val (Hi)); - Set_Etype (Result, Typ); - Set_Analyzed (Result); - return Result; - end if; - end Build_Range; + -- Discard first left operand entry if disjoint with right - --------------- - -- Build_Val -- - --------------- + elsif Left (SLeft).Hi < Right (SRight).Lo then + SLeft := SLeft + 1; - function Build_Val (V : Uint) return Node_Id is - Result : Node_Id; + -- Discard first right operand entry if disjoint with left - begin - if Is_Enumeration_Type (Typ) then - Result := Get_Enum_Lit_From_Pos (Typ, V, Sloc (N)); - else - Result := Make_Integer_Literal (Sloc (N), Intval => V); - end if; + elsif Right (SRight).Hi < Left (SLeft).Lo then + SRight := SRight + 1; - Set_Etype (Result, Typ); - Set_Is_Static_Expression (Result); - Set_Analyzed (Result); - return Result; - end Build_Val; + -- Otherwise we have an overlapping entry - ------------ - -- Hi_Val -- - ------------ + else + exit; + end if; + end loop; - function Hi_Val (N : Node_Id) return Uint is - begin - if Is_Static_Expression (N) then - return Expr_Value (N); - else - pragma Assert (Nkind (N) = N_Range); - return Expr_Value (High_Bound (N)); - end if; - end Hi_Val; + -- Now we have two non-null operands, and first entries overlap. + -- The first entry in the result will be the overlapping part of + -- these two entries. - ------------ - -- Lo_Val -- - ------------ + FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), + Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); - function Lo_Val (N : Node_Id) return Uint is - begin - if Is_Static_Expression (N) then - return Expr_Value (N); - else - pragma Assert (Nkind (N) = N_Range); - return Expr_Value (Low_Bound (N)); - end if; - end Lo_Val; + -- Now we can remove the entry that ended at a lower value, since + -- its contribution is entirely contained in Fent. + + if Left (SLeft).Hi <= Right (SRight).Hi then + SLeft := SLeft + 1; + else + SRight := SRight + 1; + end if; + + -- If either operand is empty, that's the only entry + + if SLeft > Left'Last or else SRight > Right'Last then + return RList'(1 => FEnt); + + -- Else compute and of remaining entries and concatenate + + else + return + FEnt & + (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); + end if; + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" (Right : RList) return RList is + begin + -- Return True if False range + + if Right = False_Range then + return True_Range; + end if; + + -- Return False if True range - -- Start of processing for Process_Entry + if Right'Length = 0 then + return False_Range; + end if; + + -- Here if not trivial case + + declare + Result : RList (1 .. Right'Length + 1); + -- May need one more entry for gap at beginning and end + + Count : Nat := 0; + -- Number of entries stored in Result begin - -- Range case + -- Gap at start - if Nkind (N) = N_Range then - if not Is_Static_Expression (Low_Bound (N)) - or else - not Is_Static_Expression (High_Bound (N)) + if Right (Right'First).Lo > TLo then + Count := Count + 1; + Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); + end if; + + -- Gaps between ranges + + for J in Right'First .. Right'Last - 1 loop + Count := Count + 1; + Result (Count) := + REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); + end loop; + + -- Gap at end + + if Right (Right'Last).Hi < THi then + Count := Count + 1; + Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); + end if; + + return Result (1 .. Count); + end; + end "not"; + + ---------- + -- "or" -- + ---------- + + function "or" (Left, Right : RList) return RList is + begin + -- If either range is True, return True + + if Left = True_Range or else Right = True_Range then + return True_Range; + end if; + + -- If either range is False, return the other + + if Left = False_Range then + return Right; + elsif Right = False_Range then + return Left; + end if; + + -- If either operand is null, return the other one + + if Left'Length = 0 then + return Right; + elsif Right'Length = 0 then + return Left; + end if; + + -- Now we have two non-null ranges + + declare + FEnt : REnt; + -- First range of result + + SLeft : Nat := Left'First; + -- Start of rest of left entries + + SRight : Nat := Right'First; + -- Start of rest of right entries + + begin + -- Initialize result first entry from left or right operand + -- depending on which starts with the lower range. + + if Left (SLeft).Lo < Right (SRight).Lo then + FEnt := Left (SLeft); + SLeft := SLeft + 1; + else + FEnt := Right (SRight); + SRight := SRight + 1; + end if; + + -- This loop eats ranges from left and right operands that + -- are contiguous with the first range we are gathering. + + loop + -- Eat first entry in left operand if contiguous or + -- overlapped by gathered first operand of result. + + if SLeft <= Left'Last + and then Left (SLeft).Lo <= FEnt.Hi + 1 then - Non_Static := True; - return; + FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); + SLeft := SLeft + 1; + + -- Eat first entry in right operand if contiguous or + -- overlapped by gathered right operand of result. + + elsif SRight <= Right'Last + and then Right (SRight).Lo <= FEnt.Hi + 1 + then + FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); + SRight := SRight + 1; + + -- All done if no more entries to eat! + else - SLo := Lo_Val (N); - SHi := Hi_Val (N); + exit; end if; + end loop; - -- Static expression case + -- If left operand now empty, concatenate our new entry to right - elsif Is_Static_Expression (N) then - SLo := Lo_Val (N); - SHi := Hi_Val (N); + if SLeft > Left'Last then + return FEnt & Right (SRight .. Right'Last); - -- Identifier (other than static expression) case + -- If right operand now empty, concatenate our new entry to left - else pragma Assert (Nkind (N) = N_Identifier); + elsif SRight > Right'Last then + return FEnt & Left (SLeft .. Left'Last); - -- Type case + -- Otherwise, compute or of what is left and concatenate - if Is_Type (Entity (N)) then + else + return + FEnt & + (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); + end if; + end; + end "or"; - -- If type has static predicates, process them recursively + ----------------- + -- Build_Range -- + ----------------- - if Present (Static_Predicate (Entity (N))) then - P := First (Static_Predicate (Entity (N))); - while Present (P) loop - Process_Entry (P); + function Build_Range (Lo, Hi : Uint) return Node_Id is + Result : Node_Id; + begin + if Lo = Hi then + return Build_Val (Hi); + else + Result := + Make_Range (Loc, + Low_Bound => Build_Val (Lo), + High_Bound => Build_Val (Hi)); + Set_Etype (Result, Typ); + Set_Analyzed (Result); + return Result; + end if; + end Build_Range; - if Non_Static then - return; - else - Next (P); - end if; - end loop; + --------------- + -- Build_Val -- + --------------- - return; + function Build_Val (V : Uint) return Node_Id is + Result : Node_Id; - -- For static subtype without predicates, get range + begin + if Is_Enumeration_Type (Typ) then + Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); + else + Result := Make_Integer_Literal (Loc, Intval => V); + end if; - elsif Is_Static_Subtype (Entity (N)) - and then not Has_Predicates (Entity (N)) - then - SLo := Expr_Value (Type_Low_Bound (Entity (N))); - SHi := Expr_Value (Type_High_Bound (Entity (N))); + Set_Etype (Result, Typ); + Set_Is_Static_Expression (Result); + Set_Analyzed (Result); + return Result; + end Build_Val; - -- Any other type makes us non-static + --------------- + -- Get_RList -- + --------------- - else - Non_Static := True; - return; - end if; + function Get_RList (Exp : Node_Id) return RList is + Op : Node_Kind; + Val : Uint; + + begin + -- Static expression can only be true or false + + if Is_OK_Static_Expression (Exp) then + + -- For False, return impossible range, which will always fail + + if Expr_Value (Exp) = 0 then + return False_Range; + + -- For True, null range + + else + return Null_Range; + end if; + end if; + + -- Otherwise test node type + + Op := Nkind (Exp); + + case Op is + + -- And + + when N_Op_And | N_And_Then => + return Get_RList (Left_Opnd (Exp)) + and + Get_RList (Right_Opnd (Exp)); + + -- Or + + when N_Op_Or | N_Or_Else => + return Get_RList (Left_Opnd (Exp)) + or + Get_RList (Right_Opnd (Exp)); + + -- Not + + when N_Op_Not => + return not Get_RList (Right_Opnd (Exp)); + + -- Comparisons of type with static value + + when N_Op_Compare => + -- Type is left operand + + if Is_Type_Ref (Left_Opnd (Exp)) + and then Is_OK_Static_Expression (Right_Opnd (Exp)) + then + Val := Expr_Value (Right_Opnd (Exp)); - -- Any other kind of identifier in predicate (e.g. a non-static - -- expression value) means this is not a static predicate. + -- Typ is right operand + + elsif Is_Type_Ref (Right_Opnd (Exp)) + and then Is_OK_Static_Expression (Left_Opnd (Exp)) + then + Val := Expr_Value (Left_Opnd (Exp)); + + -- Invert sense of comparison + + case Op is + when N_Op_Gt => Op := N_Op_Lt; + when N_Op_Lt => Op := N_Op_Gt; + when N_Op_Ge => Op := N_Op_Le; + when N_Op_Le => Op := N_Op_Ge; + when others => null; + end case; + + -- Other cases are non-static else - Non_Static := True; - return; + raise Non_Static; end if; - end if; - -- Here with SLo and SHi set for (possibly single element) range - -- of entry to insert in Plist. Non-static if out of range. + -- Construct range according to comparison operation - if SLo < Lo or else SHi > Hi then - Non_Static := True; - return; - end if; + case Op is + when N_Op_Eq => + return RList'(1 => REnt'(Val, Val)); - -- If no Plist currently, create it + when N_Op_Ge => + return RList'(1 => REnt'(Val, THi)); - if No (Plist) then - Plist := New_List (Build_Range (SLo, SHi)); - return; + when N_Op_Gt => + return RList'(1 => REnt'(Val + 1, THi)); - -- Otherwise search Plist for insertion point + when N_Op_Le => + return RList'(1 => REnt'(TLo, Val)); - else - P := First (Plist); - loop - -- Case of inserting before current entry + when N_Op_Lt => + return RList'(1 => REnt'(TLo, Val - 1)); - if SHi < Lo_Val (P) - 1 then - Insert_Before (P, Build_Range (SLo, SHi)); - exit; + when N_Op_Ne => + return RList'(REnt'(TLo, Val - 1), + REnt'(Val + 1, THi)); - -- Case of belongs past current entry + when others => + raise Program_Error; + end case; - elsif SLo > Hi_Val (P) + 1 then + -- Membership (IN) - -- End of list case + when N_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; - if No (Next (P)) then - Append_To (Plist, Build_Range (SLo, SHi)); - exit; + if Present (Right_Opnd (Exp)) then + return Membership_Entry (Right_Opnd (Exp)); + else + return Membership_Entries (First (Alternatives (Exp))); + end if; - -- Else just move to next item on list + -- Negative membership (NOT IN) - else - Next (P); + when N_Not_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; + + if Present (Right_Opnd (Exp)) then + return not Membership_Entry (Right_Opnd (Exp)); + else + return not Membership_Entries (First (Alternatives (Exp))); + end if; + + -- Function call, may be call to static predicate + + when N_Function_Call => + if Is_Entity_Name (Name (Exp)) then + declare + Ent : constant Entity_Id := Entity (Name (Exp)); + begin + if Has_Predicates (Ent) then + return Stat_Pred (Etype (First_Formal (Ent))); end if; + end; + end if; - -- Case of extending current entyr, and in overlap cases - -- may also eat up entries past this one. + -- Other function call cases are non-static - else - declare - New_Lo : constant Uint := UI_Min (Lo_Val (P), SLo); - New_Hi : Uint := UI_Max (Hi_Val (P), SHi); + raise Non_Static; - begin - -- See if there are entries past us that we eat up + -- Qualified expression, dig out the expression - while Present (Next (P)) - and then Lo_Val (Next (P)) <= New_Hi + 1 - loop - New_Hi := Hi_Val (Next (P)); - Remove (Next (P)); - end loop; + when N_Qualified_Expression => + return Get_RList (Expression (Exp)); - -- We now need to replace the current node P with - -- a new entry New_Lo .. New_Hi. + -- Any other node type is non-static - Insert_After (P, Build_Range (New_Lo, New_Hi)); - Remove (P); - exit; - end; - end if; - end loop; - end if; - end Process_Entry; + when others => + raise Non_Static; + end case; + end Get_RList; - -- Start of processing for Build_Static_Predicate + ------------ + -- Hi_Val -- + ------------ + function Hi_Val (N : Node_Id) return Uint is begin - -- Immediately non-static if our subtype is non static, or we - -- do not have an appropriate discrete subtype in the first place. - - if not Ekind_In (Typ, E_Enumeration_Subtype, - E_Modular_Integer_Subtype, - E_Signed_Integer_Subtype) - or else not Is_Static_Subtype (Typ) - then - return; + if Is_Static_Expression (N) then + return Expr_Value (N); + else + pragma Assert (Nkind (N) = N_Range); + return Expr_Value (High_Bound (N)); end if; + end Hi_Val; - Lo := Expr_Value (Type_Low_Bound (Typ)); - Hi := Expr_Value (Type_High_Bound (Typ)); - - -- Check if we have membership predicate + ----------------- + -- Is_Type_Ref -- + ----------------- - if Nkind (Expr) = N_In then - Exp := Expr; + function Is_Type_Ref (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Identifier and then Chars (N) = Nam; + end Is_Type_Ref; - -- Allow qualified expression with membership predicate inside + ------------ + -- Lo_Val -- + ------------ - elsif Nkind (Expr) = N_Qualified_Expression - and then Nkind (Expression (Expr)) = N_In - then - Exp := Expression (Expr); + function Lo_Val (N : Node_Id) return Uint is + begin + if Is_Static_Expression (N) then + return Expr_Value (N); + else + pragma Assert (Nkind (N) = N_Range); + return Expr_Value (Low_Bound (N)); + end if; + end Lo_Val; - -- Anything else cannot be a static predicate + ------------------------ + -- Membership_Entries -- + ------------------------ + function Membership_Entries (N : Node_Id) return RList is + begin + if No (Next (N)) then + return Membership_Entry (N); else - return; + return Membership_Entry (N) or Membership_Entries (Next (N)); end if; + end Membership_Entries; - -- We have a membership operation, so we have a potentially static - -- predicate, collect and canonicalize the entries in the list. + ---------------------- + -- Membership_Entry -- + ---------------------- - if Present (Right_Opnd (Exp)) then - Process_Entry (Right_Opnd (Exp)); + function Membership_Entry (N : Node_Id) return RList is + Val : Uint; + SLo : Uint; + SHi : Uint; - if Non_Static then - return; + begin + -- Range case + + if Nkind (N) = N_Range then + if not Is_Static_Expression (Low_Bound (N)) + or else + not Is_Static_Expression (High_Bound (N)) + then + raise Non_Static; + else + SLo := Expr_Value (Low_Bound (N)); + SHi := Expr_Value (High_Bound (N)); + return RList'(1 => REnt'(SLo, SHi)); end if; - else - Alt := First (Alternatives (Exp)); - while Present (Alt) loop - Process_Entry (Alt); + -- Static expression case - if Non_Static then - return; - end if; + elsif Is_Static_Expression (N) then + Val := Expr_Value (N); + return RList'(1 => REnt'(Val, Val)); - Next (Alt); - end loop; - end if; + -- Identifier (other than static expression) case - -- Processing was successful and all entries were static, so - -- now we can store the result as the predicate list. + else pragma Assert (Nkind (N) = N_Identifier); - Set_Static_Predicate (Typ, Plist); + -- Type case - -- The processing for static predicates coalesced ranges and also - -- eliminated duplicates. We might as well replace the alternatives - -- list of the right operand of the membership test with the static - -- predicate list, which will be more efficient. + if Is_Type (Entity (N)) then - declare - New_Alts : constant List_Id := New_List; - Old_Node : Node_Id; - New_Node : Node_Id; + -- If type has predicates, process them - begin - Old_Node := First (Plist); - while Present (Old_Node) loop - New_Node := New_Copy (Old_Node); + if Has_Predicates (Entity (N)) then + return Stat_Pred (Entity (N)); - if Nkind (New_Node) = N_Range then - Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); - Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); - end if; + -- For static subtype without predicates, get range - Append_To (New_Alts, New_Node); - Next (Old_Node); - end loop; + elsif Is_Static_Subtype (Entity (N)) then + SLo := Expr_Value (Type_Low_Bound (Entity (N))); + SHi := Expr_Value (Type_High_Bound (Entity (N))); + return RList'(1 => REnt'(SLo, SHi)); + + -- Any other type makes us non-static - -- Now update the membership test node + else + raise Non_Static; + end if; - pragma Assert (Nkind (Expr) = N_In); + -- Any other kind of identifier in predicate (e.g. a non-static + -- expression value) means this is not a static predicate. - if List_Length (New_Alts) = 1 then - Set_Right_Opnd (Expr, First (New_Alts)); - Set_Alternatives (Expr, No_List); else - Set_Alternatives (Expr, New_Alts); - Set_Right_Opnd (Expr, Empty); + raise Non_Static; end if; - end; - end Build_Static_Predicate; + end if; + end Membership_Entry; - -- Start of processing for Build_Predicate_Function + --------------- + -- Stat_Pred -- + --------------- - begin - -- Initialize for construction of statement list + function Stat_Pred (Typ : Entity_Id) return RList is + begin + -- Not static if type does not have static predicates - Expr := Empty; - FDecl := Empty; - FBody := Empty; + if not Has_Predicates (Typ) + or else No (Static_Predicate (Typ)) + then + raise Non_Static; + end if; - -- Return if already built or if type does not have predicates + -- Otherwise we convert the predicate list to a range list - if not Has_Predicates (Typ) - or else Present (Predicate_Function (Typ)) + declare + Result : RList (1 .. List_Length (Static_Predicate (Typ))); + P : Node_Id; + + begin + P := First (Static_Predicate (Typ)); + for J in Result'Range loop + Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); + Next (P); + end loop; + + return Result; + end; + end Stat_Pred; + + -- Start of processing for Build_Static_Predicate + + begin + -- Immediately non-static if our subtype is non static, or we + -- do not have an appropriate discrete subtype in the first place. + + if not Ekind_In (Typ, E_Enumeration_Subtype, + E_Modular_Integer_Subtype, + E_Signed_Integer_Subtype) + or else not Is_Static_Subtype (Typ) then return; end if; - -- Add Predicates for the current type + -- Get bounds of the type - Add_Predicates; + TLo := Expr_Value (Type_Low_Bound (Typ)); + THi := Expr_Value (Type_High_Bound (Typ)); - -- Add predicates for ancestor if present + -- Now analyze the expression to see if it is a static predicate declare - Atyp : constant Entity_Id := Nearest_Ancestor (Typ); + Ranges : constant RList := Get_RList (Expr); + -- Range list from expression if it is static + + Plist : List_Id; + begin - if Present (Atyp) then - Add_Call (Atyp); - end if; - end; + -- Convert range list into a form for the static predicate. In the + -- Ranges array, we just have raw ranges, these must be converted + -- to properly typed and analyzed static expressions or range nodes. - -- If we have predicates, build the function + Plist := New_List; - if Present (Expr) then + for J in Ranges'Range loop + declare + Lo : constant Uint := Ranges (J).Lo; + Hi : constant Uint := Ranges (J).Hi; - -- Deal with static predicate case + begin + if Lo = Hi then + Append_To (Plist, Build_Val (Lo)); + else + Append_To (Plist, Build_Range (Lo, Hi)); + end if; + end; + end loop; - Build_Static_Predicate; + -- Processing was successful and all entries were static, so now we + -- can store the result as the predicate list. - -- Build function declaration + Set_Static_Predicate (Typ, Plist); - pragma Assert (Has_Predicates (Typ)); - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - Set_Has_Predicates (SId); - Set_Predicate_Function (Typ, SId); + -- The processing for static predicates put the expression into + -- canonical form as a series of ranges. It also eliminated + -- duplicates and collapsed and combined ranges. We might as well + -- replace the alternatives list of the right operand of the + -- membership test with the static predicate list, which will + -- usually be more efficient. - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars => Object_Name), - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + declare + New_Alts : constant List_Id := New_List; + Old_Node : Node_Id; + New_Node : Node_Id; - FDecl := - Make_Subprogram_Declaration (Loc, - Specification => Spec); + begin + Old_Node := First (Plist); + while Present (Old_Node) loop + New_Node := New_Copy (Old_Node); - -- Build function body + if Nkind (New_Node) = N_Range then + Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); + Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); + end if; - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); + Append_To (New_Alts, New_Node); + Next (Old_Node); + end loop; - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars => Object_Name), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + -- If empty list, replace by True - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Expr)))); - end if; - end Build_Predicate_Function; + if Is_Empty_List (New_Alts) then + Rewrite (Expr, New_Occurrence_Of (Standard_True, Loc)); + + -- If singleton list, replace by simple membership test + + elsif List_Length (New_Alts) = 1 then + Rewrite (Expr, + Make_In (Loc, + Left_Opnd => Make_Identifier (Loc, Nam), + Right_Opnd => Relocate_Node (First (New_Alts)), + Alternatives => No_List)); + + -- If more than one range, replace by set membership test + + else + Rewrite (Expr, + Make_In (Loc, + Left_Opnd => Make_Identifier (Loc, Nam), + Right_Opnd => Empty, + Alternatives => New_Alts)); + end if; + end; + end; + + -- If non-static, return doing nothing + + exception + when Non_Static => + return; + end Build_Static_Predicate; ----------------------------------- -- Check_Constant_Address_Clause -- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 9265257a9ef..b009852bc05 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -662,6 +662,7 @@ package body Sem_Ch5 is -- checks have been applied. Note_Possible_Modification (Lhs, Sure => True); + Check_Order_Dependence; -- ??? a real accessibility check is needed when ??? diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a4d65d8b7d9..f6a0db97e38 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -811,9 +811,8 @@ package body Sem_Ch6 is end if; -- Apply checks suggested by AI05-0144 (dangerous order dependence) - -- (Disabled for now) - -- Check_Order_Dependence; + Check_Order_Dependence; end if; end Analyze_Function_Return; @@ -1116,9 +1115,9 @@ package body Sem_Ch6 is Analyze_Call (N); Resolve (N, Standard_Void_Type); - -- Apply checks suggested by AI05-0144 (Disabled for now) + -- Apply checks suggested by AI05-0144 - -- Check_Order_Dependence; + Check_Order_Dependence; else Analyze (N); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index de83fa24d52..e92477ea30b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2744,6 +2744,18 @@ package body Sem_Res is return; end if; + -- AI05-144-2: Check dangerous order dependence within an expression + -- that is not a subexpression. Exclude RHS of an assignment, because + -- both sides may have side-effects and the check must be performed + -- over the statement. + + if Nkind (Parent (N)) not in N_Subexpr + and then Nkind (Parent (N)) /= N_Assignment_Statement + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement + then + Check_Order_Dependence; + end if; + -- The expression is definitely NOT overloaded at this point, so -- we reset the Is_Overloaded flag to avoid any confusion when -- reanalyzing the node. @@ -3529,12 +3541,10 @@ package body Sem_Res is A_Typ := Etype (A); F_Typ := Etype (F); - -- Save actual for subsequent check on order dependence, - -- and indicate whether actual is modifiable. For AI05-0144 + -- Save actual for subsequent check on order dependence, and + -- indicate whether actual is modifiable. For AI05-0144-2. - -- Save_Actual (A, - -- Ekind (F) /= E_In_Parameter or else Is_Access_Type (F_Typ)); - -- Why is this code commented out ??? + Save_Actual (A, Ekind (F) /= E_In_Parameter); -- For mode IN, if actual is an entity, and the type of the formal -- has warnings suppressed, then we reset Never_Set_In_Source for @@ -8228,11 +8238,8 @@ package body Sem_Res is R : constant Node_Id := Right_Opnd (N); begin - -- Why are the calls to Check_Order_Dependence commented out ??? Resolve (L, B_Typ); - -- Check_Order_Dependence; -- For AI05-0144 Resolve (R, B_Typ); - -- Check_Order_Dependence; -- For AI05-0144 -- Check for issuing warning for always False assert/check, this happens -- when assertions are turned off, in which case the pragma Assert/Check diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f3a0b13c10d..7aca6259033 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -101,12 +101,12 @@ package body Sem_Util is -- whether the corresponding formal is OUT or IN OUT. Each top-level call -- (procedure call, condition, assignment) examines all the actuals for a -- possible order dependence. The table is reset after each such check. + -- The actuals to be checked in a call to Check_Order_Dependence are at + -- positions 1 .. Last. type Actual_Name is record Act : Node_Id; Is_Writable : Boolean; - -- Comments needed??? - end record; package Actuals_In_Call is new Table.Table ( @@ -1222,9 +1222,17 @@ package body Sem_Util is Act2 : Node_Id; begin - -- This could use comments ??? + if Ada_Version < Ada_2012 then + return; + end if; - for J in 0 .. Actuals_In_Call.Last loop + -- Ada2012 AI04-0144-2 : dangerous order dependence. + -- Actuals in nested calls within a construct have been collected. + -- If one of them is writeable and overlaps with another one, evaluation + -- of the enclosing construct is non-deterministic. + -- This is illegal in Ada2012, but is treated as a warning for now. + + for J in 1 .. Actuals_In_Call.Last loop if Actuals_In_Call.Table (J).Is_Writable then Act1 := Actuals_In_Call.Table (J).Act; @@ -1232,7 +1240,7 @@ package body Sem_Util is Act1 := Prefix (Act1); end if; - for K in 0 .. Actuals_In_Call.Last loop + for K in 1 .. Actuals_In_Call.Last loop if K /= J then Act2 := Actuals_In_Call.Table (K).Act; @@ -1248,15 +1256,19 @@ package body Sem_Util is null; elsif Denotes_Same_Object (Act1, Act2) - and then False + and then Parent (Act1) /= Parent (Act2) then - Error_Msg_N ("?,mighty suspicious!!!", Act1); + Error_Msg_N ( + "result may differ if evaluated " + & " after other actual in expression?", Act1); end if; end if; end loop; end if; end loop; + -- Remove checked actuals from table. + Actuals_In_Call.Set_Last (0); end Check_Order_Dependence; @@ -2350,49 +2362,105 @@ package body Sem_Util is ------------------------- function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is + Obj1 : Node_Id := A1; + Obj2 : Node_Id := A2; + + procedure Check_Renaming (Obj : in out Node_Id); + -- If an object is a renaming, examine renamed object. If is is a + -- dereference of a variable, or an indexed expression with non- + -- constant indices, no overlap check can be reported. + + procedure Check_Renaming (Obj : in out Node_Id) is + begin + if Is_Entity_Name (Obj) + and then Present (Renamed_Entity (Entity (Obj))) + then + Obj := Renamed_Entity (Entity (Obj)); + if Nkind (Obj) = N_Explicit_Dereference + and then Is_Variable (Prefix (Obj)) + then + Obj := Empty; + + elsif Nkind (Obj) = N_Indexed_Component then + declare + Indx : Node_Id; + + begin + Indx := First (Expressions (Obj)); + while Present (Indx) loop + if not Is_OK_Static_Expression (Indx) then + Obj := Empty; + exit; + end if; + + Next_Index (Indx); + end loop; + end; + end if; + end if; + end Check_Renaming; + begin + Check_Renaming (Obj1); + Check_Renaming (Obj2); + + if No (Obj1) + or else No (Obj2) + then + return False; + end if; + -- If we have entity names, then must be same entity - if Is_Entity_Name (A1) then - if Is_Entity_Name (A2) then - return Entity (A1) = Entity (A2); + if Is_Entity_Name (Obj1) then + if Is_Entity_Name (Obj2) then + return Entity (Obj1) = Entity (Obj2); else return False; end if; -- No match if not same node kind - elsif Nkind (A1) /= Nkind (A2) then + elsif Nkind (Obj1) /= Nkind (Obj2) then return False; -- For selected components, must have same prefix and selector - elsif Nkind (A1) = N_Selected_Component then - return Denotes_Same_Object (Prefix (A1), Prefix (A2)) + elsif Nkind (Obj1) = N_Selected_Component then + return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) and then - Entity (Selector_Name (A1)) = Entity (Selector_Name (A2)); + Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); -- For explicit dereferences, prefixes must be same - elsif Nkind (A1) = N_Explicit_Dereference then - return Denotes_Same_Object (Prefix (A1), Prefix (A2)); + elsif Nkind (Obj1) = N_Explicit_Dereference then + return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); -- For indexed components, prefixes and all subscripts must be the same - elsif Nkind (A1) = N_Indexed_Component then - if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then + elsif Nkind (Obj1) = N_Indexed_Component then + if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then declare Indx1 : Node_Id; Indx2 : Node_Id; begin - Indx1 := First (Expressions (A1)); - Indx2 := First (Expressions (A2)); + Indx1 := First (Expressions (Obj1)); + Indx2 := First (Expressions (Obj2)); while Present (Indx1) loop - -- Shouldn't we be checking that values are the same??? + -- Indices must denote the same static value or the same + -- object. + + if Is_OK_Static_Expression (Indx1) then + if not Is_OK_Static_Expression (Indx2) then + return False; - if not Denotes_Same_Object (Indx1, Indx2) then + elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then + return False; + end if; + + elsif not Denotes_Same_Object (Indx1, Indx2) then return False; end if; @@ -2408,21 +2476,19 @@ package body Sem_Util is -- For slices, prefixes must match and bounds must match - elsif Nkind (A1) = N_Slice - and then Denotes_Same_Object (Prefix (A1), Prefix (A2)) + elsif Nkind (Obj1) = N_Slice + and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then declare Lo1, Lo2, Hi1, Hi2 : Node_Id; begin - Get_Index_Bounds (Etype (A1), Lo1, Hi1); - Get_Index_Bounds (Etype (A2), Lo2, Hi2); + Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); + Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); -- Check whether bounds are statically identical. There is no -- attempt to detect partial overlap of slices. - -- What about an array and a slice of an array??? - return Denotes_Same_Object (Lo1, Lo2) and then Denotes_Same_Object (Hi1, Hi2); end; @@ -2430,8 +2496,8 @@ package body Sem_Util is -- Literals will appear as indexes. Isn't this where we should check -- Known_At_Compile_Time at least if we are generating warnings ??? - elsif Nkind (A1) = N_Integer_Literal then - return Intval (A1) = Intval (A2); + elsif Nkind (Obj1) = N_Integer_Literal then + return Intval (Obj1) = Intval (Obj2); else return False; @@ -10696,7 +10762,10 @@ package body Sem_Util is procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is begin - if Is_Entity_Name (N) + if Ada_Version < Ada_2012 then + return; + + elsif Is_Entity_Name (N) or else Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice) or else diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 0bd8b424261..da24d8919dc 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3708,7 +3708,7 @@ package body Sem_Warn is Form1 := First_Formal (Subp); Act1 := First_Actual (N); while Present (Form1) and then Present (Act1) loop - if Ekind (Form1) = E_In_Out_Parameter then + if Ekind (Form1) /= E_In_Parameter then Form2 := First_Formal (Subp); Act2 := First_Actual (N); while Present (Form2) and then Present (Act2) loop @@ -3739,11 +3739,11 @@ package body Sem_Warn is elsif Nkind (Act2) = N_Function_Call then null; - -- If either type is elementary the aliasing is harmless. + -- If type is not by-copy we can assume that the aliasing + -- is intended. - elsif Is_Elementary_Type (Underlying_Type (Etype (Form1))) - or else - Is_Elementary_Type (Underlying_Type (Etype (Form2))) + elsif + Is_By_Reference_Type (Underlying_Type (Etype (Form1))) then null; @@ -3762,11 +3762,21 @@ package body Sem_Warn is Next_Actual (Act); end loop; + if Is_Elementary_Type (Etype (Act1)) + and then Ekind (Form2) = E_In_Parameter + then + null; -- no real aliasing. + + elsif Is_Elementary_Type (Etype (Act2)) + and then Ekind (Form2) = E_In_Parameter + then + null; -- ditto + -- If the call was written in prefix notation, and -- thus its prefix before rewriting was a selected -- component, count only visible actuals in the call. - if Is_Entity_Name (First_Actual (N)) + elsif Is_Entity_Name (First_Actual (N)) and then Nkind (Original_Node (N)) = Nkind (N) and then Nkind (Name (Original_Node (N))) = N_Selected_Component diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb index 8ddc5a6c01d..9628867ae0c 100644 --- a/gcc/ada/uname.adb +++ b/gcc/ada/uname.adb @@ -225,10 +225,10 @@ package body Uname is Kind : constant Node_Kind := Nkind (Node); begin - -- Bail out on error node (guard against parse error) + -- Just ignore an error node (someone else will give a message) if Node = Error then - raise Program_Error; + return; -- Otherwise see what kind of node we have |