diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 43 | ||||
| -rw-r--r-- | gcc/ada/Makefile.rtl | 5 | ||||
| -rw-r--r-- | gcc/ada/a-btgbso.adb | 605 | ||||
| -rw-r--r-- | gcc/ada/a-btgbso.ads | 103 | ||||
| -rw-r--r-- | gcc/ada/a-cborma.adb | 1348 | ||||
| -rw-r--r-- | gcc/ada/a-cborma.ads | 244 | ||||
| -rw-r--r-- | gcc/ada/a-cborse.adb | 1718 | ||||
| -rw-r--r-- | gcc/ada/a-cborse.ads | 294 | ||||
| -rw-r--r-- | gcc/ada/a-crbltr.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgbk.adb | 599 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgbk.ads | 193 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgbo.adb | 1118 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgbo.ads | 155 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 50 | ||||
| -rw-r--r-- | gcc/ada/exp_dist.adb | 580 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 127 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 53 | ||||
| -rw-r--r-- | gcc/ada/usage.adb | 4 |
20 files changed, 6942 insertions, 332 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 646811d..f772cf4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2010-10-25 Pascal Obry <obry@adacore.com> + + * adaint.c (__gnat_file_time_name_attr): Use GetFileAttributesEx to get + the timestamp. A bit faster than opening/closing the file. + (__gnat_stat_to_attr): Remove kludge for Windows. + (__gnat_file_exists_attr): Likewise. + The timestamp is now retreived using GetFileAttributesEx as faster. + +2010-10-25 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Derive_Interface_Subprogram): New subprogram. + (Derive_Subprograms): For abstract private types transfer to the full + view entities of uncovered interface primitives. Required because if + the interface primitives are left in the private part of the package + they will be decorated as hidden when the analysis of the enclosing + package completes (and hence the interface primitive is not visible + for dispatching calls). + +2010-10-25 Matthew Heaney <heaney@adacore.com> + + * Makefile.rtl, impunit.adb: Added bounded set and bounded map + containers. + * a-crbltr.ads: Added declaration of generic package for bounded tree + types. + * a-rbtgbo.ads, a-rbtgbo.adb, a-rbtgbk.ads, a-rbtgbk.adb, a-btgbso.ads, + a-btgbso.adb, a-cborse.ads, a-cborse.adb, a-cborma.ads, a-cborma.adb: + New. + +2010-10-25 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb: Minor reformatting. + * usage.adb: Fix usage line for -gnatwh. + +2010-10-25 Thomas Quinot <quinot@adacore.com> + + * sem_ch12.adb (Analyze_Package_Instantiation): For an + instantiation in an RCI spec, omit package body if instantiation comes + from source, even as a nested + package. + * exp_dist.adb (Add_Calling_Stubs_To_Declarations, + *_Support.Add_Receiving_Stubs_To_Declarations): Handle the case of + nested packages, package instantiations and subprogram instantiations. + 2010-10-25 Robert Dewar <dewar@adacore.com> * exp_ch5.adb (Expand_Predicated_Loop): Remove code for loop through diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index a444b17..d5a2d0d 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -79,12 +79,15 @@ GNATRTL_TASKING_OBJS= \ # Objects needed for non-tasking. GNATRTL_NONTASKING_OBJS= \ a-assert$(objext) \ + a-btgbso$(objext) \ a-calari$(objext) \ a-calcon$(objext) \ a-caldel$(objext) \ a-calend$(objext) \ a-calfor$(objext) \ a-catizo$(objext) \ + a-cborse$(objext) \ + a-cborma$(objext) \ a-cdlili$(objext) \ a-cgaaso$(objext) \ a-cgarso$(objext) \ @@ -180,6 +183,8 @@ GNATRTL_NONTASKING_OBJS= \ a-nuflra$(objext) \ a-numaux$(objext) \ a-numeri$(objext) \ + a-rbtgbo$(objext) \ + a-rbtgbk$(objext) \ a-rbtgso$(objext) \ a-scteio$(objext) \ a-secain$(objext) \ diff --git a/gcc/ada/a-btgbso.adb b/gcc/ada/a-btgbso.adb new file mode 100644 index 0000000..7d6ca3d --- /dev/null +++ b/gcc/ada/a-btgbso.adb @@ -0,0 +1,605 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS -- +-- -- +-- 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 System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy (Source : Set_Type) return Set_Type; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set_Type) return Set_Type is + begin + return Target : Set_Type (Source.Length) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + ---------------- + -- Difference -- + ---------------- + + procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is + Tgt, Src : Count_Type; + + TN : Nodes_Type renames Target.Nodes; + SN : Nodes_Type renames Source.Nodes; + + begin + if Target'Address = Source'Address then + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tree_Operations.Clear_Tree (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = 0 then + return; + end if; + + if Src = 0 then + return; + end if; + + if Is_Less (TN (Tgt), SN (Src)) then + Tgt := Tree_Operations.Next (Target, Tgt); + + elsif Is_Less (SN (Src), TN (Tgt)) then + Src := Tree_Operations.Next (Source, Src); + + else + declare + X : constant Count_Type := Tgt; + begin + Tgt := Tree_Operations.Next (Target, Tgt); + + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Tree_Operations.Free (Target, X); + end; + + Src := Tree_Operations.Next (Source, Src); + end if; + end loop; + end Set_Difference; + + function Set_Difference (Left, Right : Set_Type) return Set_Type is + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return S : Set_Type (0); -- Empty set + end if; + + if Left.Length = 0 then + return S : Set_Type (0); -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + return Result : Set_Type (Left.Length) do + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + return; + end if; + + if R_Node = 0 then + while L_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + end loop; + + return; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); + + else + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; + end return; + end Set_Difference; + + ------------------ + -- Intersection -- + ------------------ + + procedure Set_Intersection + (Target : in out Set_Type; + Source : Set_Type) + is + Tgt : Count_Type; + Src : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if Source.Length = 0 then + Tree_Operations.Clear_Tree (Target); + return; + end if; + + Tgt := Target.First; + Src := Source.First; + while Tgt /= 0 + and then Src /= 0 + loop + if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + declare + X : constant Count_Type := Tgt; + begin + Tgt := Tree_Operations.Next (Target, Tgt); + + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Tree_Operations.Free (Target, X); + end; + + elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + Src := Tree_Operations.Next (Source, Src); + + else + Tgt := Tree_Operations.Next (Target, Tgt); + Src := Tree_Operations.Next (Source, Src); + end if; + end loop; + + while Tgt /= 0 loop + declare + X : constant Count_Type := Tgt; + begin + Tgt := Tree_Operations.Next (Target, Tgt); + + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Tree_Operations.Free (Target, X); + end; + end loop; + end Set_Intersection; + + function Set_Intersection (Left, Right : Set_Type) return Set_Type is + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + return; + end if; + + if R_Node = 0 then + return; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); + + else + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; + end return; + end Set_Intersection; + + --------------- + -- Is_Subset -- + --------------- + + function Set_Subset + (Subset : Set_Type; + Of_Set : Set_Type) return Boolean + is + Subset_Node : Count_Type; + Set_Node : Count_Type; + + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + Subset_Node := Subset.First; + Set_Node := Of_Set.First; + loop + if Set_Node = 0 then + return Subset_Node = 0; + end if; + + if Subset_Node = 0 then + return True; + end if; + + if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then + return False; + end if; + + if Is_Less (Of_Set.Nodes (Set_Node), Subset.Nodes (Subset_Node)) then + Set_Node := Tree_Operations.Next (Of_Set, Set_Node); + else + Set_Node := Tree_Operations.Next (Of_Set, Set_Node); + Subset_Node := Tree_Operations.Next (Subset, Subset_Node); + end if; + end loop; + end Set_Subset; + + ------------- + -- Overlap -- + ------------- + + function Set_Overlap (Left, Right : Set_Type) return Boolean is + L_Node : Count_Type; + R_Node : Count_Type; + + begin + if Left'Address = Right'Address then + return Left.Length /= 0; + end if; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 + or else R_Node = 0 + then + return False; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); + + else + return True; + end if; + end loop; + end Set_Overlap; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Set_Symmetric_Difference + (Target : in out Set_Type; + Source : Set_Type) + is + Tgt : Count_Type; + Src : Count_Type; + + New_Tgt_Node : Count_Type; + pragma Warnings (Off, New_Tgt_Node); + + begin + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if Target'Address = Source'Address then + Tree_Operations.Clear_Tree (Target); + return; + end if; + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = 0 then + while Src /= 0 loop + Insert_With_Hint + (Dst_Set => Target, + Dst_Hint => 0, + Src_Node => Source.Nodes (Src), + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Source, Src); + end loop; + + return; + end if; + + if Src = 0 then + return; + end if; + + if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + Tgt := Tree_Operations.Next (Target, Tgt); + + elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + Insert_With_Hint + (Dst_Set => Target, + Dst_Hint => Tgt, + Src_Node => Source.Nodes (Src), + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Source, Src); + + else + declare + X : constant Count_Type := Tgt; + begin + Tgt := Tree_Operations.Next (Target, Tgt); + + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Tree_Operations.Free (Target, X); + end; + + Src := Tree_Operations.Next (Source, Src); + end if; + end loop; + end Set_Symmetric_Difference; + + function Set_Symmetric_Difference + (Left, Right : Set_Type) return Set_Type + is + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return S : Set_Type (0); -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + return Result : Set_Type (Left.Length + Right.Length) do + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + while R_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Right.Nodes (R_Node), + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (Right, R_Node); + end loop; + + return; + end if; + + if R_Node = 0 then + while L_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + end loop; + + return; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Right.Nodes (R_Node), + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (Right, R_Node); + + else + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; + end return; + end Set_Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Set_Union (Target : in out Set_Type; Source : Set_Type) is + Hint : Count_Type := 0; + + procedure Process (Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Count_Type) is + begin + Insert_With_Hint + (Dst_Set => Target, + Dst_Hint => Hint, + Src_Node => Source.Nodes (Node), + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + -- Note that there's no way to decide apriori whether the + -- target has enough capacity for the union with source. + -- We cannot simply compare the sum of the existing lengths + -- to the capacity of the target, because equivalent items + -- from source are not included in the union. + + Iterate (Source); + end Set_Union; + + function Set_Union (Left, Right : Set_Type) return Set_Type is + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + return Result : Set_Type (Left.Length + Right.Length) do + Assign (Target => Result, Source => Left); + + Insert_Right : declare + Hint : Count_Type := 0; + + procedure Process (Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Count_Type) is + begin + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => Hint, + Src_Node => Right.Nodes (Node), + Dst_Node => Hint); + end Process; + + -- Start of processing for Insert_Right + + begin + Iterate (Right); + end Insert_Right; + end return; + end Set_Union; + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; diff --git a/gcc/ada/a-btgbso.ads b/gcc/ada/a-btgbso.ads new file mode 100644 index 0000000..06b5829 --- /dev/null +++ b/gcc/ada/a-btgbso.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement ordered containers. This package declares +-- set-based tree operations. + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; + +generic + with package Tree_Operations is new Generic_Bounded_Operations (<>); + + type Set_Type is new Tree_Operations.Tree_Types.Tree_Type with private; + + use Tree_Operations.Tree_Types; + + with procedure Assign (Target : in out Set_Type; Source : Set_Type); + + with procedure Insert_With_Hint + (Dst_Set : in out Set_Type; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type); + + with function Is_Less (Left, Right : Node_Type) return Boolean; + +package Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is + pragma Pure; + + procedure Set_Union (Target : in out Set_Type; Source : Set_Type); + -- Attempts to insert each element of Source in Target. If Target is + -- busy then Program_Error is raised. We say "attempts" here because + -- if these are unique-element sets, then the insertion should fail + -- (not insert a new item) when the insertion item from Source is + -- equivalent to an item already in Target. If these are multisets + -- then of course the attempt should always succeed. + + function Set_Union (Left, Right : Set_Type) return Set_Type; + -- Makes a copy of Left, and attempts to insert each element of + -- Right into the copy, then returns the copy. + + procedure Set_Intersection (Target : in out Set_Type; Source : Set_Type); + -- Removes elements from Target that are not equivalent to items in + -- Source. If Target is busy then Program_Error is raised. + + function Set_Intersection (Left, Right : Set_Type) return Set_Type; + -- Returns a set comprising all the items in Left equivalent to items in + -- Right. + + procedure Set_Difference (Target : in out Set_Type; Source : Set_Type); + -- Removes elements from Target that are equivalent to items in Source. If + -- Target is busy then Program_Error is raised. + + function Set_Difference (Left, Right : Set_Type) return Set_Type; + -- Returns a set comprising all the items in Left not equivalent to items + -- in Right. + + procedure Set_Symmetric_Difference + (Target : in out Set_Type; + Source : Set_Type); + -- Removes from Target elements that are equivalent to items in Source, + -- and inserts into Target items from Source not equivalent elements in + -- Target. If Target is busy then Program_Error is raised. + + function Set_Symmetric_Difference (Left, Right : Set_Type) return Set_Type; + -- Returns a set comprising the union of the elements in Left not + -- equivalent to items in Right, and the elements in Right not equivalent + -- to items in Left. + + function Set_Subset (Subset : Set_Type; Of_Set : Set_Type) return Boolean; + -- Returns False if Subset contains at least one element not equivalent to + -- any item in Of_Set; returns True otherwise. + + function Set_Overlap (Left, Right : Set_Type) return Boolean; + -- Returns True if at least one element of Left is equivalent to an item in + -- Right; returns False otherwise. + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb new file mode 100644 index 0000000..64c248f --- /dev/null +++ b/gcc/ada/a-cborma.adb @@ -0,0 +1,1348 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P 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.Red_Black_Trees.Generic_Bounded_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Ordered_Maps is + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Type) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Type) return Count_Type; + pragma Inline (Left); + + function Parent (Node : Node_Type) return Count_Type; + pragma Inline (Parent); + + function Right (Node : Node_Type) return Count_Type; + pragma Inline (Right); + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type); + pragma Inline (Set_Left); + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type); + pragma Inline (Set_Right); + + procedure Set_Color (Node : in out Node_Type; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types); + + use Tree_Operations; + + package Key_Ops is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if Right.Node = 0 then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "Left cursor of ""<"" is bad"); + + pragma Assert (Vet (Right.Container.all, Right.Node), + "Right cursor of ""<"" is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return LN.Key < RN.Key; + end; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "Left cursor of ""<"" is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + + begin + return LN.Key < Right; + end; + end "<"; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Right.Node = 0 then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.all, Right.Node), + "Right cursor of ""<"" is bad"); + + declare + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return Left < RN.Key; + end; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + function Is_Equal_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node + (L, R : Node_Type) return Boolean is + begin + if L.Key < R.Key then + return False; + + elsif R.Key < L.Key then + return False; + + else + return L.Element = R.Element; + end if; + end Is_Equal_Node_Node; + + -- Start of processing for "=" + + begin + return Is_Equal (Left, Right); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if Right.Node = 0 then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "Left cursor of "">"" is bad"); + + pragma Assert (Vet (Right.Container.all, Right.Node), + "Right cursor of "">"" is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return RN.Key < LN.Key; + end; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "Left cursor of "">"" is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + + begin + return Right < LN.Key; + end; + end ">"; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Right.Node = 0 then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.all, Right.Node), + "Right cursor of "">"" is bad"); + + declare + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return RN.Key < Left; + end; + end ">"; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Append_Element (Source_Node : Count_Type); + + procedure Append_Elements is + new Tree_Operations.Generic_Iteration (Append_Element); + + -------------------- + -- Append_Element -- + -------------------- + + procedure Append_Element (Source_Node : Count_Type) is + SN : Node_Type renames Source.Nodes (Source_Node); + + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Key_Ops.Generic_Unconditional_Insert (Insert_Post); + + procedure Unconditional_Insert_Avec_Hint is + new Key_Ops.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Unconditional_Insert_Sans_Hint); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + + begin + Allocate (Target, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Key := SN.Key; + Node.Element := SN.Element; + end Set_Element; + + Target_Node : Count_Type; + + -- Start of processing for Append_Element + + begin + Unconditional_Insert_Avec_Hint + (Tree => Target, + Hint => 0, + Key => SN.Key, + Node => Target_Node); + end Append_Element; + + -- Start of processing for Assign + + 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; + + Tree_Operations.Clear_Tree (Target); + Append_Elements (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Ceiling (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + Tree_Operations.Clear_Tree (Container); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Type) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error with "Capacity value too small"; + end if; + + return Target : Map (Capacity => C) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Delete is bad"); + + Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); + Tree_Operations.Free (Container, Position.Node); + + Position := No_Element; + end Delete; + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if X = 0 then + raise Constraint_Error with "key not in map"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Map) is + X : constant Count_Type := Container.First; + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Map) is + X : constant Count_Type := Container.Last; + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of function Element is bad"); + + return Position.Container.Nodes (Position.Node).Element; + end Element; + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + begin + if Container.First = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + begin + if Container.First = 0 then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Container.First).Element; + end First_Element; + + --------------- + -- First_Key -- + --------------- + + function First_Key (Container : Map) return Key_Type is + begin + if Container.First = 0 then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Container.First).Key; + end First_Key; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Floor (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Floor; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + declare + N : Node_Type renames Container.Nodes (Position.Node); + + begin + N.Key := Key; + N.Element := New_Item; + end; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + procedure Assign (Node : in out Node_Type); + pragma Inline (Assign); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Assign); + + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : in out Node_Type) is + begin + Node.Key := Key; + Node.Element := New_Item; + end Assign; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with "key already in map"; + end if; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean) + is + procedure Assign (Node : in out Node_Type); + pragma Inline (Assign); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Assign); + + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : in out Node_Type) is + begin + Node.Key := Key; + -- Node.Element := New_Item; + end Assign; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + -- k > node same as node < k + + return Right.Key < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Key; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + B : Natural renames Container'Unrestricted_Access.all.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (Container); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of function Key is bad"); + + return Position.Container.Nodes (Position.Node).Key; + end Key; + + ---------- + -- Last -- + ---------- + + function Last (Container : Map) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + begin + if Container.Last = 0 then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Container.Last).Element; + end Last_Element; + + -------------- + -- Last_Key -- + -------------- + + function Last_Key (Container : Map) return Key_Type is + begin + if Container.Last = 0 then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Container.Last).Key; + end Last_Key; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Type) return Count_Type is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Map; Source : in out Map) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Assign (Target => Target, Source => Source); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of Next is bad"); + + declare + M : Map renames Position.Container.all; + + Node : constant Count_Type := + Tree_Operations.Next (M, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Type) return Count_Type is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of Previous is bad"); + + declare + M : Map renames Position.Container.all; + + Node : constant Count_Type := + Tree_Operations.Previous (M, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of Query_Element is bad"); + + declare + M : Map renames Position.Container.all; + N : Node_Type renames M.Nodes (Position.Node); + + B : Natural renames M.Busy; + L : Natural renames M.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (N.Key, N.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Read_Element); + + procedure Read_Elements is + new Tree_Operations.Generic_Read (Allocate); + + ------------------ + -- Read_Element -- + ------------------ + + procedure Read_Element (Node : in out Node_Type) is + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + end Read_Element; + + -- Start of processing for Read + + begin + Read_Elements (Stream, Container); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + + begin + N.Key := Key; + N.Element := New_Item; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Replace_Element is bad"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + B : Natural renames Container'Unrestricted_Access.all.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (Container); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Type) return Count_Type is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : in out Node_Type; + Color : Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is + begin + Node.Right := Right; + end Set_Right; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Update_Element is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (N.Key, N.Element); + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Node); + + procedure Write_Nodes is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write_Nodes (Stream, Container); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + +end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads new file mode 100644 index 0000000..74dac98 --- /dev/null +++ b/gcc/ada/a-cborma.ads @@ -0,0 +1,244 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P 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.Containers.Red_Black_Trees; +private with Ada.Streams; + +generic + type Key_Type is private; + type Element_Type is private; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Ordered_Maps is + pragma Pure; + pragma Remote_Types; + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + type Map (Capacity : Count_Type) is tagged private; + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + function Key (Position : Cursor) return Key_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map; + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); + + procedure Delete_First (Container : in out Map); + + procedure Delete_Last (Container : in out Map); + + function First (Container : Map) return Cursor; + + function First_Element (Container : Map) return Element_Type; + + function First_Key (Container : Map) return Key_Type; + + function Last (Container : Map) return Cursor; + + function Last_Element (Container : Map) return Element_Type; + + function Last_Key (Container : Map) return Key_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 (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Floor (Container : Map; Key : Key_Type) return Cursor; + + function Ceiling (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function Has_Element (Position : Cursor) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type is record + Parent : Count_Type; + Left : Count_Type; + Right : Count_Type; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Key : Key_Type; + Element : Element_Type; + end record; + + package Tree_Types is + new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); + + type Map (Capacity : Count_Type) is + new Tree_Types.Tree_Type (Capacity) with null record; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + use Red_Black_Trees; + use Tree_Types; + use Ada.Streams; + + type Cursor is record + Container : Map_Access; + Node : Count_Type; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, 0); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0); + +end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb new file mode 100644 index 0000000..12d253c --- /dev/null +++ b/gcc/ada/a-cborse.adb @@ -0,0 +1,1718 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T 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.Red_Black_Trees.Generic_Bounded_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Ordered_Sets is + + ------------------------------ + -- Access to Fields of Node -- + ------------------------------ + + -- These subprograms provide functional notation for access to fields + -- of a node, and procedural notation for modifying these fields. + + function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Type) return Count_Type; + pragma Inline (Left); + + function Parent (Node : Node_Type) return Count_Type; + pragma Inline (Parent); + + function Right (Node : Node_Type) return Count_Type; + pragma Inline (Right); + + procedure Set_Color + (Node : in out Node_Type; + Color : Red_Black_Trees.Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type); + pragma Inline (Set_Left); + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type); + pragma Inline (Set_Right); + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); + pragma Inline (Set_Parent); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Insert_Sans_Hint + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean); + + procedure Insert_With_Hint + (Dst_Set : in out Set; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Less_Node_Node); + + procedure Replace_Element + (Container : in out Set; + Index : Count_Type; + Item : Element_Type); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types); + + use Tree_Operations; + + package Element_Keys is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Red_Black_Trees.Generic_Bounded_Set_Operations + (Tree_Operations => Tree_Operations, + Set_Type => Set, + Assign => Assign, + Insert_With_Hint => Insert_With_Hint, + Is_Less => Is_Less_Node_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Right.Node = 0 then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.all, Right.Node), + "bad Right cursor in ""<"""); + + declare + LN : Nodes_Type renames Left.Container.Nodes; + RN : Nodes_Type renames Right.Container.Nodes; + begin + return LN (Left.Node).Element < RN (Right.Node).Element; + end; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "bad Left cursor in ""<"""); + + return Left.Container.Nodes (Left.Node).Element < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Right.Node = 0 then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.all, Right.Node), + "bad Right cursor in ""<"""); + + return Left < Right.Container.Nodes (Right.Node).Element; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + function Is_Equal_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Type) return Boolean is + begin + return L.Element = R.Element; + end Is_Equal_Node_Node; + + -- Start of processing for Is_Equal + + begin + return Is_Equal (Left, Right); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Right.Node = 0 then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.all, Right.Node), + "bad Right cursor in "">"""); + + -- L > R same as R < L + + declare + LN : Nodes_Type renames Left.Container.Nodes; + RN : Nodes_Type renames Right.Container.Nodes; + begin + return RN (Right.Node).Element < LN (Left.Node).Element; + end; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Right.Node = 0 then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.all, Right.Node), + "bad Right cursor in "">"""); + + return Right.Container.Nodes (Right.Node).Element < Left; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "bad Left cursor in "">"""); + + return Right < Left.Container.Nodes (Left.Node).Element; + end ">"; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + procedure Append_Element (Source_Node : Count_Type); + + procedure Append_Elements is + new Tree_Operations.Generic_Iteration (Append_Element); + + -------------------- + -- Append_Element -- + -------------------- + + procedure Append_Element (Source_Node : Count_Type) is + SN : Node_Type renames Source.Nodes (Source_Node); + + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + procedure Unconditional_Insert_Avec_Hint is + new Element_Keys.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Unconditional_Insert_Sans_Hint); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + + begin + Allocate (Target, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := SN.Element; + end Set_Element; + + Target_Node : Count_Type; + + -- Start of processing for Append_Element + + begin + Unconditional_Insert_Avec_Hint + (Tree => Target, + Hint => 0, + Key => SN.Element, + Node => Target_Node); + end Append_Element; + + -- Start of processing for Assign + + 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; + Append_Elements (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := + Element_Keys.Ceiling (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + begin + Tree_Operations.Clear_Tree (Container); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error with "Capacity value too small"; + end if; + + return Target : Set (Capacity => C) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Position.Node = 0 then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); + Tree_Operations.Free (Container, Position.Node); + + Position := No_Element; + end Delete; + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if X = 0 then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + X : constant Count_Type := Container.First; + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + X : constant Count_Type := Container.Last; + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Delete_Last; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) + renames Set_Ops.Set_Difference; + + function Difference (Left, Right : Set) return Set + renames Set_Ops.Set_Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = 0 then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Element"); + + return Position.Container.Nodes (Position.Node).Element; + end Element; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is + begin + if L.Element < R.Element then + return False; + elsif R.Element < L.Element then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left, Right); + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Container.First = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + if Container.First = 0 then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Nodes (Container.First).Element; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := Element_Keys.Floor (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Floor; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := + Key_Keys.Ceiling (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + X : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with "key not in set"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Keys.Floor (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Key (Right.Element) < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Key (Right.Element); + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Key"); + + return Key (Position.Container.Nodes (Position.Node).Element); + end Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container, Node, New_Item); + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + E : Element_Type renames N.Element; + K : constant Key_Type := Key (E); + + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if Equivalent_Keys (K, Key (E)) then + return; + end if; + end; + + Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); + Tree_Operations.Free (Container, Position.Node); + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Container.Nodes (Position.Node).Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert_Sans_Hint + (Container, + New_Item, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Conditional_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + + begin + Allocate (Container, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := New_Item; + end Set_Element; + + -- Start of processing for Insert_Sans_Hint + + begin + Conditional_Insert_Sans_Hint + (Container, + New_Item, + Node, + Inserted); + end Insert_Sans_Hint; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Set : in out Set; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type) + is + Success : Boolean; + pragma Unreferenced (Success); + + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + + begin + Allocate (Dst_Set, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := Src_Node.Element; + end Set_Element; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Set, + Dst_Hint, + Src_Node.Element, + Dst_Node, + Success); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) + renames Set_Ops.Set_Intersection; + + function Intersection (Left, Right : Set) return Set + renames Set_Ops.Set_Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean + is + begin + -- Compute e > node same as node < e + + return Right.Element < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Type) return Boolean is + begin + return L.Element < R.Element; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean + renames Set_Ops.Set_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + S : Set renames Container'Unrestricted_Access.all; + B : Natural renames S.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (S); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + if Container.Last = 0 then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Nodes (Container.Last).Element; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Type) return Count_Type is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Assign (Target => Target, Source => Source); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Next"); + + declare + Node : constant Count_Type := + Tree_Operations.Next (Position.Container.all, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean + renames Set_Ops.Set_Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Type) return Count_Type is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Previous"); + + declare + Node : constant Count_Type := + Tree_Operations.Previous + (Position.Container.all, + Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Position.Node = 0 then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Query_Element"); + + declare + S : Set renames Position.Container.all; + + B : Natural renames S.Busy; + L : Natural renames S.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (S.Nodes (Position.Node).Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Read_Element); + + procedure Read_Elements is + new Tree_Operations.Generic_Read (Allocate); + + ------------------ + -- Read_Element -- + ------------------ + + procedure Read_Element (Node : in out Node_Type) is + begin + Element_Type'Read (Stream, Node.Element); + end Read_Element; + + -- Start of processing for Read + + begin + Read_Elements (Stream, Container); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Count_Type := Element_Keys.Find (Container, New_Item); + + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Container.Nodes (Node).Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Set; + Index : Count_Type; + Item : Element_Type) + is + pragma Assert (Index /= 0); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Local_Insert_Post, + Local_Insert_Sans_Hint); + + Nodes : Nodes_Type renames Container.Nodes; + Node : Node_Type renames Nodes (Index); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + begin + Node.Element := Item; + Node.Color := Red_Black_Trees.Red; + Node.Parent := 0; + Node.Right := 0; + Node.Left := 0; + + return Index; + end New_Node; + + Hint : Count_Type; + Result : Count_Type; + Inserted : Boolean; + + -- Start of processing for Replace_Element + + begin + if Item < Node.Element + or else Node.Element < Item + then + null; + + else + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := Item; + return; + end if; + + Hint := Element_Keys.Ceiling (Container, Item); + + if Hint = 0 then + null; + + elsif Item < Nodes (Hint).Element then + if Hint = Index then + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := Item; + return; + end if; + + else + pragma Assert (not (Nodes (Hint).Element < Item)); + raise Program_Error with "attempt to replace existing element"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, Index); + + Local_Insert_With_Hint + (Tree => Container, + Position => Hint, + Key => Item, + Node => Result, + Inserted => Inserted); + + pragma Assert (Inserted); + pragma Assert (Result = Index); + end Replace_Element; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container, Position.Node, New_Item); + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + S : Set renames Container'Unrestricted_Access.all; + B : Natural renames S.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (S); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Type) return Count_Type is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : in out Node_Type; + Color : Red_Black_Trees.Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) + renames Set_Ops.Set_Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set + renames Set_Ops.Set_Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Node : Count_Type; + Inserted : Boolean; + begin + return S : Set (1) do + Insert_Sans_Hint (S, New_Item, Node, Inserted); + pragma Assert (Inserted); + end return; + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) + renames Set_Ops.Set_Union; + + function Union (Left, Right : Set) return Set + renames Set_Ops.Set_Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Element + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Element); + + procedure Write_Elements is + new Tree_Operations.Generic_Write (Write_Element); + + ------------------- + -- Write_Element -- + ------------------- + + procedure Write_Element + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Element; + + -- Start of processing for Write + + begin + Write_Elements (Stream, Container); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + +end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads new file mode 100644 index 0000000..f9719dc --- /dev/null +++ b/gcc/ada/a-cborse.ads @@ -0,0 +1,294 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T 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.Containers.Red_Black_Trees; +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Ordered_Sets is + pragma Pure; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + + type Set (Capacity : Count_Type) is tagged private; + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Equivalent_Sets (Left, Right : Set) return Boolean; + + function To_Set (New_Item : Element_Type) return Set; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set; + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + + procedure Include + (Container : in out Set; + New_Item : Element_Type); + + procedure Replace + (Container : in out Set; + New_Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) 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 (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Has_Element (Position : Cursor) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + package Generic_Keys is + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Floor (Container : Set; Key : Key_Type) return Cursor; + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + end Generic_Keys; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type is record + Parent : Count_Type; + Left : Count_Type; + Right : Count_Type; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : Element_Type; + end record; + + package Tree_Types is + new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); + + type Set (Capacity : Count_Type) is + new Tree_Types.Tree_Type (Capacity) with null record; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Count_Type; + end record; + + use Tree_Types; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, 0); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := Set'(Tree_Type with Capacity => 0); + +end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads index c3ce433..30ceff7 100644 --- a/gcc/ada/a-crbltr.ads +++ b/gcc/ada/a-crbltr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -48,4 +48,21 @@ package Ada.Containers.Red_Black_Trees is end record; end Generic_Tree_Types; + generic + type Node_Type is private; + package Generic_Bounded_Tree_Types is + type Nodes_Type is array (Count_Type range <>) of Node_Type; + + type Tree_Type (Capacity : Count_Type) is tagged record + First : Count_Type := 0; + Last : Count_Type := 0; + Root : Count_Type := 0; + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; + Free : Count_Type'Base := -1; + Nodes : Nodes_Type (1 .. Capacity); + end record; + end Generic_Bounded_Tree_Types; + end Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/a-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb new file mode 100644 index 0000000..b12ae84 --- /dev/null +++ b/gcc/ada/a-rbtgbk.adb @@ -0,0 +1,599 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is + + package Ops renames Tree_Operations; + + ------------- + -- Ceiling -- + ------------- + + -- AKA Lower_Bound + + function Ceiling + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + while X /= 0 loop + if Is_Greater_Key_Node (Key, N (X)) then + X := Ops.Right (N (X)); + else + Y := X; + X := Ops.Left (N (X)); + end if; + end loop; + + return Y; + end Ceiling; + + ---------- + -- Find -- + ---------- + + function Find + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + while X /= 0 loop + if Is_Greater_Key_Node (Key, N (X)) then + X := Ops.Right (N (X)); + else + Y := X; + X := Ops.Left (N (X)); + end if; + end loop; + + if Y = 0 then + return 0; + end if; + + if Is_Less_Key_Node (Key, N (Y)) then + return 0; + end if; + + return Y; + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + while X /= 0 loop + if Is_Less_Key_Node (Key, N (X)) then + X := Ops.Left (N (X)); + else + Y := X; + X := Ops.Right (N (X)); + end if; + end loop; + + return Y; + end Floor; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + Inserted := True; + while X /= 0 loop + Y := X; + Inserted := Is_Less_Key_Node (Key, N (X)); + X := (if Inserted then Ops.Left (N (X)) else Ops.Right (N (X))); + end loop; + + -- If Inserted is True, then this means either that Tree is + -- empty, or there was a least one node (strictly) greater than + -- Key. Otherwise, it means that Key is equal to or greater than + -- every node. + + if Inserted then + if Y = Tree.First then + Insert_Post (Tree, Y, True, Node); + return; + end if; + + Node := Ops.Previous (Tree, Y); + + else + Node := Y; + end if; + + -- Here Node has a value that is less than or equal to Key. We + -- now have to resolve whether Key is equal to or greater than + -- Node, which determines whether the insertion succeeds. + + if Is_Greater_Key_Node (Key, N (Node)) then + Insert_Post (Tree, Y, Inserted, Node); + Inserted := True; + return; + end if; + + Inserted := False; + end Generic_Conditional_Insert; + + ------------------------------------------ + -- Generic_Conditional_Insert_With_Hint -- + ------------------------------------------ + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type'Class; + Position : Count_Type; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + N : Nodes_Type renames Tree.Nodes; + + begin + -- The purpose of a hint is to avoid a search from the root of + -- tree. If we have it hint it means we only need to traverse the + -- subtree rooted at the hint to find the nearest neighbor. Note + -- that finding the neighbor means merely walking the tree; this + -- is not a search and the only comparisons that occur are with + -- the hint and its neighbor. + + -- If Position is 0, this is interpreted to mean that Key is + -- large relative to the nodes in the tree. If the tree is empty, + -- or Key is greater than the last node in the tree, then we're + -- done; otherwise the hint was "wrong" and we must search. + + if Position = 0 then -- largest + if Tree.Last = 0 + or else Is_Greater_Key_Node (Key, N (Tree.Last)) + then + Insert_Post (Tree, Tree.Last, False, Node); + Inserted := True; + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + + return; + end if; + + pragma Assert (Tree.Length > 0); + + -- A hint can either name the node that immediately follows Key, + -- or immediately precedes Key. We first test whether Key is + -- less than the hint, and if so we compare Key to the node that + -- precedes the hint. If Key is both less than the hint and + -- greater than the hint's preceding neighbor, then we're done; + -- otherwise we must search. + + -- Note also that a hint can either be an anterior node or a leaf + -- node. A new node is always inserted at the bottom of the tree + -- (at least prior to rebalancing), becoming the new left or + -- right child of leaf node (which prior to the insertion must + -- necessarily be null, since this is a leaf). If the hint names + -- an anterior node then its neighbor must be a leaf, and so + -- (here) we insert after the neighbor. If the hint names a leaf + -- then its neighbor must be anterior and so we insert before the + -- hint. + + if Is_Less_Key_Node (Key, N (Position)) then + declare + Before : constant Count_Type := Ops.Previous (Tree, Position); + + begin + if Before = 0 then + Insert_Post (Tree, Tree.First, True, Node); + Inserted := True; + + elsif Is_Greater_Key_Node (Key, N (Before)) then + if Ops.Right (N (Before)) = 0 then + Insert_Post (Tree, Before, False, Node); + else + Insert_Post (Tree, Position, True, Node); + end if; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + end; + + return; + end if; + + -- We know that Key isn't less than the hint so we try again, + -- this time to see if it's greater than the hint. If so we + -- compare Key to the node that follows the hint. If Key is both + -- greater than the hint and less than the hint's next neighbor, + -- then we're done; otherwise we must search. + + if Is_Greater_Key_Node (Key, N (Position)) then + declare + After : constant Count_Type := Ops.Next (Tree, Position); + + begin + if After = 0 then + Insert_Post (Tree, Tree.Last, False, Node); + Inserted := True; + + elsif Is_Less_Key_Node (Key, N (After)) then + if Ops.Right (N (Position)) = 0 then + Insert_Post (Tree, Position, False, Node); + else + Insert_Post (Tree, After, True, Node); + end if; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + end; + + return; + end if; + + -- We know that Key is neither less than the hint nor greater + -- than the hint, and that's the definition of equivalence. + -- There's nothing else we need to do, since a search would just + -- reach the same conclusion. + + Node := Position; + Inserted := False; + end Generic_Conditional_Insert_With_Hint; + + ------------------------- + -- Generic_Insert_Post -- + ------------------------- + + procedure Generic_Insert_Post + (Tree : in out Tree_Type'Class; + Y : Count_Type; + Before : Boolean; + Z : out Count_Type) + is + N : Nodes_Type renames Tree.Nodes; + + begin + if Tree.Length >= Tree.Capacity then + raise Capacity_Error with "not enough capacity to insert new item"; + end if; + + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Z := New_Node; + pragma Assert (Z /= 0); + + if Y = 0 then + pragma Assert (Tree.Length = 0); + pragma Assert (Tree.Root = 0); + pragma Assert (Tree.First = 0); + pragma Assert (Tree.Last = 0); + + Tree.Root := Z; + Tree.First := Z; + Tree.Last := Z; + + elsif Before then + pragma Assert (Ops.Left (N (Y)) = 0); + + Ops.Set_Left (N (Y), Z); + + if Y = Tree.First then + Tree.First := Z; + end if; + + else + pragma Assert (Ops.Right (N (Y)) = 0); + + Ops.Set_Right (N (Y), Z); + + if Y = Tree.Last then + Tree.Last := Z; + end if; + end if; + + Ops.Set_Color (N (Z), Red); + Ops.Set_Parent (N (Z), Y); + Ops.Rebalance_For_Insert (Tree, Z); + Tree.Length := Tree.Length + 1; + end Generic_Insert_Post; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration + (Tree : Tree_Type'Class; + Key : Key_Type) + is + procedure Iterate (Index : Count_Type); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (Index : Count_Type) is + J : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + J := Index; + while J /= 0 loop + if Is_Less_Key_Node (Key, N (J)) then + J := Ops.Left (N (J)); + elsif Is_Greater_Key_Node (Key, N (J)) then + J := Ops.Right (N (J)); + else + Iterate (Ops.Left (N (J))); + Process (J); + J := Ops.Right (N (J)); + end if; + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration + (Tree : Tree_Type'Class; + Key : Key_Type) + is + procedure Iterate (Index : Count_Type); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (Index : Count_Type) is + J : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + J := Index; + while J /= 0 loop + if Is_Less_Key_Node (Key, N (J)) then + J := Ops.Left (N (J)); + elsif Is_Greater_Key_Node (Key, N (J)) then + J := Ops.Right (N (J)); + else + Iterate (Ops.Right (N (J))); + Process (J); + J := Ops.Left (N (J)); + end if; + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ---------------------------------- + -- Generic_Unconditional_Insert -- + ---------------------------------- + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type) + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + Before : Boolean; + + begin + Y := 0; + Before := False; + + X := Tree.Root; + while X /= 0 loop + Y := X; + Before := Is_Less_Key_Node (Key, N (X)); + X := (if Before then Ops.Left (N (X)) else Ops.Right (N (X))); + end loop; + + Insert_Post (Tree, Y, Before, Node); + end Generic_Unconditional_Insert; + + -------------------------------------------- + -- Generic_Unconditional_Insert_With_Hint -- + -------------------------------------------- + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type'Class; + Hint : Count_Type; + Key : Key_Type; + Node : out Count_Type) + is + N : Nodes_Type renames Tree.Nodes; + + begin + -- There are fewer constraints for an unconditional insertion + -- than for a conditional insertion, since we allow duplicate + -- keys. So instead of having to check (say) whether Key is + -- (strictly) greater than the hint's previous neighbor, here we + -- allow Key to be equal to or greater than the previous node. + + -- There is the issue of what to do if Key is equivalent to the + -- hint. Does the new node get inserted before or after the hint? + -- We decide that it gets inserted after the hint, reasoning that + -- this is consistent with behavior for non-hint insertion, which + -- inserts a new node after existing nodes with equivalent keys. + + -- First we check whether the hint is null, which is interpreted + -- to mean that Key is large relative to existing nodes. + -- Following our rule above, if Key is equal to or greater than + -- the last node, then we insert the new node immediately after + -- last. (We don't have an operation for testing whether a key is + -- "equal to or greater than" a node, so we must say instead "not + -- less than", which is equivalent.) + + if Hint = 0 then -- largest + if Tree.Last = 0 then + Insert_Post (Tree, 0, False, Node); + elsif Is_Less_Key_Node (Key, N (Tree.Last)) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + else + Insert_Post (Tree, Tree.Last, False, Node); + end if; + + return; + end if; + + pragma Assert (Tree.Length > 0); + + -- We decide here whether to insert the new node prior to the + -- hint. Key could be equivalent to the hint, so in theory we + -- could write the following test as "not greater than" (same as + -- "less than or equal to"). If Key were equivalent to the hint, + -- that would mean that the new node gets inserted before an + -- equivalent node. That wouldn't break any container invariants, + -- but our rule above says that new nodes always get inserted + -- after equivalent nodes. So here we test whether Key is both + -- less than the hint and equal to or greater than the hint's + -- previous neighbor, and if so insert it before the hint. + + if Is_Less_Key_Node (Key, N (Hint)) then + declare + Before : constant Count_Type := Ops.Previous (Tree, Hint); + begin + if Before = 0 then + Insert_Post (Tree, Hint, True, Node); + elsif Is_Less_Key_Node (Key, N (Before)) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + elsif Ops.Right (N (Before)) = 0 then + Insert_Post (Tree, Before, False, Node); + else + Insert_Post (Tree, Hint, True, Node); + end if; + end; + + return; + end if; + + -- We know that Key isn't less than the hint, so it must be equal + -- or greater. So we just test whether Key is less than or equal + -- to (same as "not greater than") the hint's next neighbor, and + -- if so insert it after the hint. + + declare + After : constant Count_Type := Ops.Next (Tree, Hint); + begin + if After = 0 then + Insert_Post (Tree, Hint, False, Node); + elsif Is_Greater_Key_Node (Key, N (After)) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + elsif Ops.Right (N (Hint)) = 0 then + Insert_Post (Tree, Hint, False, Node); + else + Insert_Post (Tree, After, True, Node); + end if; + end; + end Generic_Unconditional_Insert_With_Hint; + + ----------------- + -- Upper_Bound -- + ----------------- + + function Upper_Bound + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + while X /= 0 loop + if Is_Less_Key_Node (Key, N (X)) then + Y := X; + X := Ops.Left (N (X)); + else + X := Ops.Right (N (X)); + end if; + end loop; + + return Y; + end Upper_Bound; + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; diff --git a/gcc/ada/a-rbtgbk.ads b/gcc/ada/a-rbtgbk.ads new file mode 100644 index 0000000..a96ef28 --- /dev/null +++ b/gcc/ada/a-rbtgbk.ads @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement ordered containers. This package declares +-- the tree operations that depend on keys. + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; + +generic + with package Tree_Operations is new Generic_Bounded_Operations (<>); + + use Tree_Operations.Tree_Types; + + type Key_Type (<>) is limited private; + + with function Is_Less_Key_Node + (L : Key_Type; + R : Node_Type) return Boolean; + + with function Is_Greater_Key_Node + (L : Key_Type; + R : Node_Type) return Boolean; + +package Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is + pragma Pure; + + generic + with function New_Node return Count_Type; + + procedure Generic_Insert_Post + (Tree : in out Tree_Type'Class; + Y : Count_Type; + Before : Boolean; + Z : out Count_Type); + -- Completes an insertion after the insertion position has been + -- determined. On output Z contains the index of the newly inserted + -- node, allocated using Allocate. If Tree is busy then + -- Program_Error is raised. If Y is 0, then Tree must be empty. + -- Otherwise Y denotes the insertion position, and Before specifies + -- whether the new node is Y's left (True) or right (False) child. + + generic + with procedure Insert_Post + (T : in out Tree_Type'Class; + Y : Count_Type; + B : Boolean; + Z : out Count_Type); + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + -- Inserts a new node in Tree, but only if the tree does not already + -- contain Key. Generic_Conditional_Insert first searches for a key + -- equivalent to Key in Tree. If an equivalent key is found, then on + -- output Node designates the node with that key and Inserted is + -- False; there is no allocation and Tree is not modified. Otherwise + -- Node designates a new node allocated using Insert_Post, and + -- Inserted is True. + + generic + with procedure Insert_Post + (T : in out Tree_Type'Class; + Y : Count_Type; + B : Boolean; + Z : out Count_Type); + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type); + -- Inserts a new node in Tree. On output Node designates the new + -- node, which is allocated using Insert_Post. The node is inserted + -- immediately after already-existing equivalent keys. + + generic + with procedure Insert_Post + (T : in out Tree_Type'Class; + Y : Count_Type; + B : Boolean; + Z : out Count_Type); + + with procedure Unconditional_Insert_Sans_Hint + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type); + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type'Class; + Hint : Count_Type; + Key : Key_Type; + Node : out Count_Type); + -- Inserts a new node in Tree near position Hint, to avoid having to + -- search from the root for the insertion position. If Hint is 0 + -- then Generic_Unconditional_Insert_With_Hint attempts to insert + -- the new node after Tree.Last. If Hint is non-zero then if Key is + -- less than Hint, it attempts to insert the new node immediately + -- prior to Hint. Otherwise it attempts to insert the node + -- immediately following Hint. We say "attempts" above to emphasize + -- that insertions always preserve invariants with respect to key + -- order, even when there's a hint. So if Key can't be inserted + -- immediately near Hint, then the new node is inserted in the + -- normal way, by searching for the correct position starting from + -- the root. + + generic + with procedure Insert_Post + (T : in out Tree_Type'Class; + Y : Count_Type; + B : Boolean; + Z : out Count_Type); + + with procedure Conditional_Insert_Sans_Hint + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type'Class; + Position : Count_Type; -- the hint + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + -- Inserts a new node in Tree if the tree does not already contain + -- Key, using Position as a hint about where to insert the new node. + -- See Generic_Unconditional_Insert_With_Hint for more details about + -- hint semantics. + + function Find + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type; + -- Searches Tree for the smallest node equivalent to Key + + function Ceiling + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type; + -- Searches Tree for the smallest node equal to or greater than Key + + function Floor + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type; + -- Searches Tree for the largest node less than or equal to Key + + function Upper_Bound + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type; + -- Searches Tree for the smallest node greater than Key + + generic + with procedure Process (Index : Count_Type); + procedure Generic_Iteration + (Tree : Tree_Type'Class; + Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, in order + -- from earliest in range to latest. + + generic + with procedure Process (Index : Count_Type); + procedure Generic_Reverse_Iteration + (Tree : Tree_Type'Class; + Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, but in + -- order from largest in range to earliest. + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb new file mode 100644 index 0000000..88743b3 --- /dev/null +++ b/gcc/ada/a-rbtgbo.adb @@ -0,0 +1,1118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- The references below to "CLR" refer to the following book, from which +-- several of the algorithms here were adapted: +-- Introduction to Algorithms +-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest +-- Publisher: The MIT Press (June 18, 1990) +-- ISBN: 0262031418 + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type); + procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type); + + procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type); + procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type); + + ---------------- + -- Clear_Tree -- + ---------------- + + procedure Clear_Tree (Tree : in out Tree_Type'Class) is + begin + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tree.First := 0; + Tree.Last := 0; + Tree.Root := 0; + Tree.Length := 0; + -- Tree.Busy + -- Tree.Lock + Tree.Free := -1; + end Clear_Tree; + + ------------------ + -- Delete_Fixup -- + ------------------ + + procedure Delete_Fixup + (Tree : in out Tree_Type'Class; + Node : Count_Type) + is + + -- CLR p274 + + X : Count_Type; + W : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + X := Node; + while X /= Tree.Root + and then Color (N (X)) = Black + loop + if X = Left (N (Parent (N (X)))) then + W := Right (N (Parent (N (X)))); + + if Color (N (W)) = Red then + Set_Color (N (W), Black); + Set_Color (N (Parent (N (X))), Red); + Left_Rotate (Tree, Parent (N (X))); + W := Right (N (Parent (N (X)))); + end if; + + if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) + and then + (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) + then + Set_Color (N (W), Red); + X := Parent (N (X)); + + else + if Right (N (W)) = 0 + or else Color (N (Right (N (W)))) = Black + then + -- As a condition for setting the color of the left child to + -- black, the left child access value must be non-null. A + -- truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Left (N (W)) /= 0); + Set_Color (N (Left (N (W))), Black); + + Set_Color (N (W), Red); + Right_Rotate (Tree, W); + W := Right (N (Parent (N (X)))); + end if; + + Set_Color (N (W), Color (N (Parent (N (X))))); + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Right (N (W))), Black); + Left_Rotate (Tree, Parent (N (X))); + X := Tree.Root; + end if; + + else + pragma Assert (X = Right (N (Parent (N (X))))); + + W := Left (N (Parent (N (X)))); + + if Color (N (W)) = Red then + Set_Color (N (W), Black); + Set_Color (N (Parent (N (X))), Red); + Right_Rotate (Tree, Parent (N (X))); + W := Left (N (Parent (N (X)))); + end if; + + if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) + and then + (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) + then + Set_Color (N (W), Red); + X := Parent (N (X)); + + else + if Left (N (W)) = 0 + or else Color (N (Left (N (W)))) = Black + then + -- As a condition for setting the color of the right child + -- to black, the right child access value must be non-null. + -- A truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Right (N (W)) /= 0); + Set_Color (N (Right (N (W))), Black); + + Set_Color (N (W), Red); + Left_Rotate (Tree, W); + W := Left (N (Parent (N (X)))); + end if; + + Set_Color (N (W), Color (N (Parent (N (X))))); + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Left (N (W))), Black); + Right_Rotate (Tree, Parent (N (X))); + X := Tree.Root; + end if; + end if; + end loop; + + Set_Color (N (X), Black); + end Delete_Fixup; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type'Class; + Node : Count_Type) + is + -- CLR p273 + + X, Y : Count_Type; + + Z : constant Count_Type := Node; + pragma Assert (Z /= 0); + + N : Nodes_Type renames Tree.Nodes; + + begin + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + pragma Assert (Tree.Length > 0); + pragma Assert (Tree.Root /= 0); + pragma Assert (Tree.First /= 0); + pragma Assert (Tree.Last /= 0); + pragma Assert (Parent (N (Tree.Root)) = 0); + + pragma Assert ((Tree.Length > 1) + or else (Tree.First = Tree.Last + and then Tree.First = Tree.Root)); + + pragma Assert ((Left (N (Node)) = 0) + or else (Parent (N (Left (N (Node)))) = Node)); + + pragma Assert ((Right (N (Node)) = 0) + or else (Parent (N (Right (N (Node)))) = Node)); + + pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node)) + or else ((Parent (N (Node)) /= 0) and then + ((Left (N (Parent (N (Node)))) = Node) + or else + (Right (N (Parent (N (Node)))) = Node)))); + + if Left (N (Z)) = 0 then + if Right (N (Z)) = 0 then + if Z = Tree.First then + Tree.First := Parent (N (Z)); + end if; + + if Z = Tree.Last then + Tree.Last := Parent (N (Z)); + end if; + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (N (Z)) = 0); + pragma Assert (Right (N (Z)) = 0); + + if Z = Tree.Root then + pragma Assert (Tree.Length = 1); + pragma Assert (Parent (N (Z)) = 0); + Tree.Root := 0; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), 0); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), 0); + end if; + + else + pragma Assert (Z /= Tree.Last); + + X := Right (N (Z)); + + if Z = Tree.First then + Tree.First := Min (Tree, X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), X); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), X); + end if; + + Set_Parent (N (X), Parent (N (Z))); + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + + elsif Right (N (Z)) = 0 then + pragma Assert (Z /= Tree.First); + + X := Left (N (Z)); + + if Z = Tree.Last then + Tree.Last := Max (Tree, X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), X); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), X); + end if; + + Set_Parent (N (X), Parent (N (Z))); + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, X); + end if; + + else + pragma Assert (Z /= Tree.First); + pragma Assert (Z /= Tree.Last); + + Y := Next (Tree, Z); + pragma Assert (Left (N (Y)) = 0); + + X := Right (N (Y)); + + if X = 0 then + if Y = Left (N (Parent (N (Y)))) then + pragma Assert (Parent (N (Y)) /= Z); + Delete_Swap (Tree, Z, Y); + Set_Left (N (Parent (N (Z))), Z); + + else + pragma Assert (Y = Right (N (Parent (N (Y))))); + pragma Assert (Parent (N (Y)) = Z); + Set_Parent (N (Y), Parent (N (Z))); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), Y); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), Y); + end if; + + Set_Left (N (Y), Z); + Set_Parent (N (Left (N (Y))), Y); + Set_Right (N (Y), Z); + Set_Parent (N (Z), Y); + Set_Left (N (Z), 0); + Set_Right (N (Z), 0); + + declare + Y_Color : constant Color_Type := Color (N (Y)); + begin + Set_Color (N (Y), Color (N (Z))); + Set_Color (N (Z), Y_Color); + end; + end if; + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (N (Z)) = 0); + pragma Assert (Right (N (Z)) = 0); + + if Z = Right (N (Parent (N (Z)))) then + Set_Right (N (Parent (N (Z))), 0); + else + pragma Assert (Z = Left (N (Parent (N (Z))))); + Set_Left (N (Parent (N (Z))), 0); + end if; + + else + if Y = Left (N (Parent (N (Y)))) then + pragma Assert (Parent (N (Y)) /= Z); + + Delete_Swap (Tree, Z, Y); + + Set_Left (N (Parent (N (Z))), X); + Set_Parent (N (X), Parent (N (Z))); + + else + pragma Assert (Y = Right (N (Parent (N (Y))))); + pragma Assert (Parent (N (Y)) = Z); + + Set_Parent (N (Y), Parent (N (Z))); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), Y); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), Y); + end if; + + Set_Left (N (Y), Left (N (Z))); + Set_Parent (N (Left (N (Y))), Y); + + declare + Y_Color : constant Color_Type := Color (N (Y)); + begin + Set_Color (N (Y), Color (N (Z))); + Set_Color (N (Z), Y_Color); + end; + end if; + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + end if; + + Tree.Length := Tree.Length - 1; + end Delete_Node_Sans_Free; + + ----------------- + -- Delete_Swap -- + ----------------- + + procedure Delete_Swap + (Tree : in out Tree_Type'Class; + Z, Y : Count_Type) + is + N : Nodes_Type renames Tree.Nodes; + + pragma Assert (Z /= Y); + pragma Assert (Parent (N (Y)) /= Z); + + Y_Parent : constant Count_Type := Parent (N (Y)); + Y_Color : constant Color_Type := Color (N (Y)); + + begin + Set_Parent (N (Y), Parent (N (Z))); + Set_Left (N (Y), Left (N (Z))); + Set_Right (N (Y), Right (N (Z))); + Set_Color (N (Y), Color (N (Z))); + + if Tree.Root = Z then + Tree.Root := Y; + elsif Right (N (Parent (N (Y)))) = Z then + Set_Right (N (Parent (N (Y))), Y); + else + pragma Assert (Left (N (Parent (N (Y)))) = Z); + Set_Left (N (Parent (N (Y))), Y); + end if; + + if Right (N (Y)) /= 0 then + Set_Parent (N (Right (N (Y))), Y); + end if; + + if Left (N (Y)) /= 0 then + Set_Parent (N (Left (N (Y))), Y); + end if; + + Set_Parent (N (Z), Y_Parent); + Set_Color (N (Z), Y_Color); + Set_Left (N (Z), 0); + Set_Right (N (Z), 0); + end Delete_Swap; + + ---------- + -- Free -- + ---------- + + procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is + pragma Assert (X > 0); + pragma Assert (X <= Tree.Capacity); + + N : Nodes_Type renames Tree.Nodes; + -- pragma Assert (N (X).Prev >= 0); -- node is active + -- Find a way to mark a node as active vs. inactive; we could + -- use a special value in Color_Type for this. ??? + + begin + -- The set container actually contains two data structures: a list for + -- the "active" nodes that contain elements that have been inserted + -- onto the tree, and another for the "inactive" nodes of the free + -- store. + -- + -- We desire that merely declaring an object should have only minimal + -- cost; specially, we want to avoid having to initialize the free + -- store (to fill in the links), especially if the capacity is large. + -- + -- The head of the free list is indicated by Container.Free. If its + -- value is non-negative, then the free store has been initialized + -- in the "normal" way: Container.Free points to the head of the list + -- of free (inactive) nodes, and the value 0 means the free list is + -- empty. Each node on the free list has been initialized to point + -- to the next free node (via its Parent component), and the value 0 + -- means that this is the last free node. + -- + -- If Container.Free is negative, then the links on the free store + -- have not been initialized. In this case the link values are + -- implied: the free store comprises the components of the node array + -- started with the absolute value of Container.Free, and continuing + -- until the end of the array (Nodes'Last). + -- + -- ??? + -- It might be possible to perform an optimization here. Suppose that + -- the free store can be represented as having two parts: one + -- comprising the non-contiguous inactive nodes linked together + -- in the normal way, and the other comprising the contiguous + -- inactive nodes (that are not linked together, at the end of the + -- nodes array). This would allow us to never have to initialize + -- the free store, except in a lazy way as nodes become inactive. + + -- When an element is deleted from the list container, its node + -- becomes inactive, and so we set its Prev component to a negative + -- value, to indicate that it is now inactive. This provides a useful + -- way to detect a dangling cursor reference. + + -- The comment above is incorrect; we need some other way to + -- indicate a node is inactive, for example by using a special + -- Color_Type value. ??? + -- N (X).Prev := -1; -- Node is deallocated (not on active list) + + if Tree.Free >= 0 then + -- The free store has previously been initialized. All we need to + -- do here is link the newly-free'd node onto the free list. + + Set_Parent (N (X), Tree.Free); + Tree.Free := X; + + elsif X + 1 = abs Tree.Free then + -- The free store has not been initialized, and the node becoming + -- inactive immediately precedes the start of the free store. All + -- we need to do is move the start of the free store back by one. + + Tree.Free := Tree.Free + 1; + + else + -- The free store has not been initialized, and the node becoming + -- inactive does not immediately precede the free store. Here we + -- first initialize the free store (meaning the links are given + -- values in the traditional way), and then link the newly-free'd + -- node onto the head of the free store. + + -- ??? + -- See the comments above for an optimization opportunity. If + -- the next link for a node on the free store is negative, then + -- this means the remaining nodes on the free store are + -- physically contiguous, starting as the absolute value of + -- that index value. + + Tree.Free := abs Tree.Free; + + if Tree.Free > Tree.Capacity then + Tree.Free := 0; + + else + for I in Tree.Free .. Tree.Capacity - 1 loop + Set_Parent (N (I), I + 1); + end loop; + + Set_Parent (N (Tree.Capacity), 0); + end if; + + Set_Parent (N (X), Tree.Free); + Tree.Free := X; + end if; + end Free; + + ----------------------- + -- Generic_Allocate -- + ----------------------- + + procedure Generic_Allocate + (Tree : in out Tree_Type'Class; + Node : out Count_Type) + is + N : Nodes_Type renames Tree.Nodes; + + begin + if Tree.Free >= 0 then + Node := Tree.Free; + + -- We always perform the assignment first, before we + -- change container state, in order to defend against + -- exceptions duration assignment. + + Set_Element (N (Node)); + Tree.Free := Parent (N (Node)); + + else + -- A negative free store value means that the links of the nodes + -- in the free store have not been initialized. In this case, the + -- nodes are physically contiguous in the array, starting at the + -- index that is the absolute value of the Container.Free, and + -- continuing until the end of the array (Nodes'Last). + + Node := abs Tree.Free; + + -- As above, we perform this assignment first, before modifying + -- any container state. + + Set_Element (N (Node)); + Tree.Free := Tree.Free - 1; + end if; + end Generic_Allocate; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is + L_Node : Count_Type; + R_Node : Count_Type; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + L_Node := Left.First; + R_Node := Right.First; + while L_Node /= 0 loop + if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + return False; + end if; + + L_Node := Next (Left, L_Node); + R_Node := Next (Right, R_Node); + end loop; + + return True; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (Tree : Tree_Type'Class) is + procedure Iterate (P : Count_Type); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Count_Type) is + X : Count_Type := P; + begin + while X /= 0 loop + Iterate (Left (Tree.Nodes (X))); + Process (X); + X := Right (Tree.Nodes (X)); + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + Tree : in out Tree_Type'Class) + is + Len : Count_Type'Base; + + Node, Last_Node : Count_Type; + + N : Nodes_Type renames Tree.Nodes; + + begin + Clear_Tree (Tree); + Count_Type'Base'Read (Stream, Len); + + if Len < 0 then + raise Program_Error with "bad container length (corrupt stream)"; + end if; + + if Len = 0 then + return; + end if; + + if Len > Tree.Capacity then + raise Constraint_Error with "length exceeds capacity"; + end if; + + -- Use Unconditional_Insert_With_Hint here instead ??? + + Allocate (Tree, Node); + pragma Assert (Node /= 0); + + Set_Color (N (Node), Black); + + Tree.Root := Node; + Tree.First := Node; + Tree.Last := Node; + Tree.Length := 1; + + for J in Count_Type range 2 .. Len loop + Last_Node := Node; + pragma Assert (Last_Node = Tree.Last); + + Allocate (Tree, Node); + pragma Assert (Node /= 0); + + Set_Color (N (Node), Red); + Set_Right (N (Last_Node), Right => Node); + Tree.Last := Node; + Set_Parent (N (Node), Parent => Last_Node); + + Rebalance_For_Insert (Tree, Node); + Tree.Length := Tree.Length + 1; + end loop; + end Generic_Read; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is + procedure Iterate (P : Count_Type); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Count_Type) is + X : Count_Type := P; + begin + while X /= 0 loop + Iterate (Right (Tree.Nodes (X))); + Process (X); + X := Left (Tree.Nodes (X)); + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + Tree : Tree_Type'Class) + is + procedure Process (Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is + new Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Count_Type) is + begin + Write_Node (Stream, Tree.Nodes (Node)); + end Process; + + -- Start of processing for Generic_Write + + begin + Count_Type'Base'Write (Stream, Tree.Length); + Iterate (Tree); + end Generic_Write; + + ----------------- + -- Left_Rotate -- + ----------------- + + procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is + -- CLR p266 + + N : Nodes_Type renames Tree.Nodes; + + Y : constant Count_Type := Right (N (X)); + pragma Assert (Y /= 0); + + begin + Set_Right (N (X), Left (N (Y))); + + if Left (N (Y)) /= 0 then + Set_Parent (N (Left (N (Y))), X); + end if; + + Set_Parent (N (Y), Parent (N (X))); + + if X = Tree.Root then + Tree.Root := Y; + elsif X = Left (N (Parent (N (X)))) then + Set_Left (N (Parent (N (X))), Y); + else + pragma Assert (X = Right (N (Parent (N (X))))); + Set_Right (N (Parent (N (X))), Y); + end if; + + Set_Left (N (Y), X); + Set_Parent (N (X), Y); + end Left_Rotate; + + --------- + -- Max -- + --------- + + function Max + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type + is + -- CLR p248 + + X : Count_Type := Node; + Y : Count_Type; + + begin + loop + Y := Right (Tree.Nodes (X)); + + if Y = 0 then + return X; + end if; + + X := Y; + end loop; + end Max; + + --------- + -- Min -- + --------- + + function Min + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type + is + -- CLR p248 + + X : Count_Type := Node; + Y : Count_Type; + + begin + loop + Y := Left (Tree.Nodes (X)); + + if Y = 0 then + return X; + end if; + + X := Y; + end loop; + end Min; + + ---------- + -- Next -- + ---------- + + function Next + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type + is + begin + -- CLR p249 + + if Node = 0 then + return 0; + end if; + + if Right (Tree.Nodes (Node)) /= 0 then + return Min (Tree, Right (Tree.Nodes (Node))); + end if; + + declare + X : Count_Type := Node; + Y : Count_Type := Parent (Tree.Nodes (Node)); + + begin + while Y /= 0 + and then X = Right (Tree.Nodes (Y)) + loop + X := Y; + Y := Parent (Tree.Nodes (Y)); + end loop; + + return Y; + end; + end Next; + + -------------- + -- Previous -- + -------------- + + function Previous + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type + is + begin + if Node = 0 then + return 0; + end if; + + if Left (Tree.Nodes (Node)) /= 0 then + return Max (Tree, Left (Tree.Nodes (Node))); + end if; + + declare + X : Count_Type := Node; + Y : Count_Type := Parent (Tree.Nodes (Node)); + + begin + while Y /= 0 + and then X = Left (Tree.Nodes (Y)) + loop + X := Y; + Y := Parent (Tree.Nodes (Y)); + end loop; + + return Y; + end; + end Previous; + + -------------------------- + -- Rebalance_For_Insert -- + -------------------------- + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type'Class; + Node : Count_Type) + is + -- CLR p.268 + + N : Nodes_Type renames Tree.Nodes; + + X : Count_Type := Node; + pragma Assert (X /= 0); + pragma Assert (Color (N (X)) = Red); + + Y : Count_Type; + + begin + while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop + if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then + Y := Right (N (Parent (N (Parent (N (X)))))); + + if Y /= 0 and then Color (N (Y)) = Red then + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Y), Black); + Set_Color (N (Parent (N (Parent (N (X))))), Red); + X := Parent (N (Parent (N (X)))); + + else + if X = Right (N (Parent (N (X)))) then + X := Parent (N (X)); + Left_Rotate (Tree, X); + end if; + + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Parent (N (Parent (N (X))))), Red); + Right_Rotate (Tree, Parent (N (Parent (N (X))))); + end if; + + else + pragma Assert (Parent (N (X)) = + Right (N (Parent (N (Parent (N (X))))))); + + Y := Left (N (Parent (N (Parent (N (X)))))); + + if Y /= 0 and then Color (N (Y)) = Red then + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Y), Black); + Set_Color (N (Parent (N (Parent (N (X))))), Red); + X := Parent (N (Parent (N (X)))); + + else + if X = Left (N (Parent (N (X)))) then + X := Parent (N (X)); + Right_Rotate (Tree, X); + end if; + + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Parent (N (Parent (N (X))))), Red); + Left_Rotate (Tree, Parent (N (Parent (N (X))))); + end if; + end if; + end loop; + + Set_Color (N (Tree.Root), Black); + end Rebalance_For_Insert; + + ------------------ + -- Right_Rotate -- + ------------------ + + procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is + N : Nodes_Type renames Tree.Nodes; + + X : constant Count_Type := Left (N (Y)); + pragma Assert (X /= 0); + + begin + Set_Left (N (Y), Right (N (X))); + + if Right (N (X)) /= 0 then + Set_Parent (N (Right (N (X))), Y); + end if; + + Set_Parent (N (X), Parent (N (Y))); + + if Y = Tree.Root then + Tree.Root := X; + elsif Y = Left (N (Parent (N (Y)))) then + Set_Left (N (Parent (N (Y))), X); + else + pragma Assert (Y = Right (N (Parent (N (Y))))); + Set_Right (N (Parent (N (Y))), X); + end if; + + Set_Right (N (X), Y); + Set_Parent (N (Y), X); + end Right_Rotate; + + --------- + -- Vet -- + --------- + + function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is + Nodes : Nodes_Type renames Tree.Nodes; + Node : Node_Type renames Nodes (Index); + + begin + if Parent (Node) = Index + or else Left (Node) = Index + or else Right (Node) = Index + then + return False; + end if; + + if Tree.Length = 0 + or else Tree.Root = 0 + or else Tree.First = 0 + or else Tree.Last = 0 + then + return False; + end if; + + if Parent (Nodes (Tree.Root)) /= 0 then + return False; + end if; + + if Left (Nodes (Tree.First)) /= 0 then + return False; + end if; + + if Right (Nodes (Tree.Last)) /= 0 then + return False; + end if; + + if Tree.Length = 1 then + if Tree.First /= Tree.Last + or else Tree.First /= Tree.Root + then + return False; + end if; + + if Index /= Tree.First then + return False; + end if; + + if Parent (Node) /= 0 + or else Left (Node) /= 0 + or else Right (Node) /= 0 + then + return False; + end if; + + return True; + end if; + + if Tree.First = Tree.Last then + return False; + end if; + + if Tree.Length = 2 then + if Tree.First /= Tree.Root + and then Tree.Last /= Tree.Root + then + return False; + end if; + + if Tree.First /= Index + and then Tree.Last /= Index + then + return False; + end if; + end if; + + if Left (Node) /= 0 + and then Parent (Nodes (Left (Node))) /= Index + then + return False; + end if; + + if Right (Node) /= 0 + and then Parent (Nodes (Right (Node))) /= Index + then + return False; + end if; + + if Parent (Node) = 0 then + if Tree.Root /= Index then + return False; + end if; + + elsif Left (Nodes (Parent (Node))) /= Index + and then Right (Nodes (Parent (Node))) /= Index + then + return False; + end if; + + return True; + end Vet; + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; diff --git a/gcc/ada/a-rbtgbo.ads b/gcc/ada/a-rbtgbo.ads new file mode 100644 index 0000000..b6aae73 --- /dev/null +++ b/gcc/ada/a-rbtgbo.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement the ordered containers. This package +-- declares the tree operations that do not depend on keys. + +with Ada.Streams; use Ada.Streams; + +generic + with package Tree_Types is new Generic_Bounded_Tree_Types (<>); + use Tree_Types; + + with function Parent (Node : Node_Type) return Count_Type is <>; + + with procedure Set_Parent + (Node : in out Node_Type; + Parent : Count_Type) is <>; + + with function Left (Node : Node_Type) return Count_Type is <>; + + with procedure Set_Left + (Node : in out Node_Type; + Left : Count_Type) is <>; + + with function Right (Node : Node_Type) return Count_Type is <>; + + with procedure Set_Right + (Node : in out Node_Type; + Right : Count_Type) is <>; + + with function Color (Node : Node_Type) return Color_Type is <>; + + with procedure Set_Color + (Node : in out Node_Type; + Color : Color_Type) is <>; + +package Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is + pragma Pure; + + function Min (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type; + -- Returns the smallest-valued node of the subtree rooted at Node + + function Max (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type; + -- Returns the largest-valued node of the subtree rooted at Node + + function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean; + -- Inspects Node to determine (to the extent possible) whether + -- the node is valid; used to detect if the node is dangling. + + function Next + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type; + -- Returns the smallest node greater than Node + + function Previous + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type; + -- Returns the largest node less than Node + + generic + with function Is_Equal (L, R : Node_Type) return Boolean; + function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean; + -- Uses Is_Equal to perform a node-by-node comparison of the + -- Left and Right trees; processing stops as soon as the first + -- non-equal node is found. + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type'Class; Node : Count_Type); + -- Removes Node from Tree without deallocating the node. If Tree + -- is busy then Program_Error is raised. + + procedure Clear_Tree (Tree : in out Tree_Type'Class); + -- Clears Tree by deallocating all of its nodes. If Tree is busy then + -- Program_Error is raised. + + generic + with procedure Process (Node : Count_Type) is <>; + procedure Generic_Iteration (Tree : Tree_Type'Class); + -- Calls Process for each node in Tree, in order from smallest-valued + -- node to largest-valued node. + + generic + with procedure Process (Node : Count_Type) is <>; + procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class); + -- Calls Process for each node in Tree, in order from largest-valued + -- node to smallest-valued node. + + generic + with procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + Tree : Tree_Type'Class); + -- Used to implement stream attribute T'Write. Generic_Write + -- first writes the number of nodes into Stream, then calls + -- Write_Node for each node in Tree. + + generic + with procedure Allocate + (Tree : in out Tree_Type'Class; + Node : out Count_Type); + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + Tree : in out Tree_Type'Class); + -- Used to implement stream attribute T'Read. Generic_Read + -- first clears Tree. It then reads the number of nodes out of + -- Stream, and calls Read_Node for each node in Stream. + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type'Class; + Node : Count_Type); + -- This rebalances Tree to complete the insertion of Node (which + -- must already be linked in at its proper insertion position). + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (Tree : in out Tree_Type'Class; + Node : out Count_Type); + -- Claim a node from the free store. Generic_Allocate first + -- calls Set_Element on the potential node, and then returns + -- the node's index as the value of the Node parameter. + + procedure Free (Tree : in out Tree_Type'Class; X : Count_Type); + -- Return a node back to the free store, from where it had + -- been previously claimed via Generic_Allocate. + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index a251a4e..855ce34 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -1099,11 +1099,7 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr) either case. */ attr->file_length = statbuf.st_size; /* all systems */ -#ifndef __MINGW32__ - /* on Windows requires extra system call, see comment in - __gnat_file_exists_attr */ attr->exists = !ret; -#endif #if !defined (_WIN32) || defined (RTX) /* on Windows requires extra system call, see __gnat_is_readable_file_attr */ @@ -1343,7 +1339,8 @@ win32_filetime (HANDLE h) } /* As above but starting from a FILETIME. */ -static void f2t (const FILETIME *ft, time_t *t) +static void +f2t (const FILETIME *ft, time_t *t) { union { @@ -1363,18 +1360,14 @@ __gnat_file_time_name_attr (char* name, struct file_attributes* attr) { if (attr->timestamp == (OS_Time)-2) { #if defined (_WIN32) && !defined (RTX) + BOOL res; + WIN32_FILE_ATTRIBUTE_DATA fad; time_t ret = -1; TCHAR wname[GNAT_MAX_PATH_LEN]; S2WSC (wname, name, GNAT_MAX_PATH_LEN); - HANDLE h = CreateFile - (wname, GENERIC_READ, FILE_SHARE_READ, 0, - OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0); - - if (h != INVALID_HANDLE_VALUE) { - ret = win32_filetime (h); - CloseHandle (h); - } + if (res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad)) + f2t (&fad.ftLastWriteTime, &ret); attr->timestamp = (OS_Time) ret; #else __gnat_stat_to_attr (-1, name, attr); @@ -1713,17 +1706,17 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf) if (res == FALSE) switch (GetLastError()) { - case ERROR_ACCESS_DENIED: - case ERROR_SHARING_VIOLATION: - case ERROR_LOCK_VIOLATION: - case ERROR_SHARING_BUFFER_EXCEEDED: - return EACCES; - case ERROR_BUFFER_OVERFLOW: - return ENAMETOOLONG; - case ERROR_NOT_ENOUGH_MEMORY: - return ENOMEM; - default: - return ENOENT; + case ERROR_ACCESS_DENIED: + case ERROR_SHARING_VIOLATION: + case ERROR_LOCK_VIOLATION: + case ERROR_SHARING_BUFFER_EXCEEDED: + return EACCES; + case ERROR_BUFFER_OVERFLOW: + return ENAMETOOLONG; + case ERROR_NOT_ENOUGH_MEMORY: + return ENOMEM; + default: + return ENOENT; } f2t (&fad.ftCreationTime, &statbuf->st_ctime); @@ -1758,16 +1751,7 @@ int __gnat_file_exists_attr (char* name, struct file_attributes* attr) { if (attr->exists == ATTR_UNSET) { -#ifdef __MINGW32__ - /* On Windows do not use __gnat_stat() because of a bug in Microsoft - _stat() routine. When the system time-zone is set with a negative - offset the _stat() routine fails on specific files like CON: */ - TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); - attr->exists = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES; -#else __gnat_stat_to_attr (-1, name, attr); -#endif } return attr->exists; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index fb91ce7..3ad2060 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -41,6 +41,7 @@ with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; @@ -225,9 +226,7 @@ package body Exp_Dist is -- In either case, this means stubs cannot contain a default-initialized -- object declaration of such type. - procedure Add_Calling_Stubs_To_Declarations - (Pkg_Spec : Node_Id; - Decls : List_Id); + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id); -- Add calling stubs to the declarative part function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; @@ -915,27 +914,145 @@ package body Exp_Dist is -- since this require separate mechanisms ('Input is a function while -- 'Read is a procedure). + generic + with procedure Process_Subprogram_Declaration (Decl : Node_Id); + -- Generate calling or receiving stub for this subprogram declaration + + procedure Build_Package_Stubs (Pkg_Spec : Node_Id); + -- Recursively visit the given RCI Package_Specification, calling + -- Process_Subprogram_Declaration for each remote subprogram. + + ------------------------- + -- Build_Package_Stubs -- + ------------------------- + + procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is + Decls : constant List_Id := Visible_Declarations (Pkg_Spec); + Decl : Node_Id; + + procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id); + -- Recurse for the given nested package declaration + + ----------------------- + -- Visit_Nested_Spec -- + ----------------------- + + procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is + Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl); + begin + Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec)); + Build_Package_Stubs (Nested_Pkg_Spec); + Pop_Scope; + end Visit_Nested_Pkg; + + -- Start of processing for Build_Package_Stubs + + begin + Decl := First (Decls); + while Present (Decl) loop + case Nkind (Decl) is + when N_Subprogram_Declaration => + + -- Note: we test Comes_From_Source on Spec, not Decl, because + -- in the case of a subprogram instance, only the specification + -- (not the declaration) is marked as coming from source. + + if Comes_From_Source (Specification (Decl)) then + Process_Subprogram_Declaration (Decl); + end if; + + when N_Package_Declaration => + + -- Case of a nested package or package instantiation coming + -- from source. Note that the anonymous wrapper package for + -- subprogram instances is not flagged Is_Generic_Instance at + -- this point, so there is a distinct circuit to handle them + -- (see case N_Subprogram_Instantiation below). + + declare + Pkg_Ent : constant Entity_Id := + Defining_Unit_Name (Specification (Decl)); + begin + if Comes_From_Source (Decl) + or else + (Is_Generic_Instance (Pkg_Ent) + and then Comes_From_Source + (Get_Package_Instantiation_Node (Pkg_Ent))) + then + Visit_Nested_Pkg (Decl); + end if; + end; + + when N_Subprogram_Instantiation => + + -- The subprogram declaration for an instance of a generic + -- subprogram is wrapped in a package that does not come from + -- source, so we need to explicitly traverse it here. + + if Comes_From_Source (Decl) then + Visit_Nested_Pkg (Instance_Spec (Decl)); + end if; + + when others => + null; + end case; + Next (Decl); + end loop; + end Build_Package_Stubs; + --------------------------------------- -- Add_Calling_Stubs_To_Declarations -- --------------------------------------- - procedure Add_Calling_Stubs_To_Declarations - (Pkg_Spec : Node_Id; - Decls : List_Id) - is + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; -- Subprogram id 0 is reserved for calls received from -- remote access-to-subprogram dereferences. - Current_Declaration : Node_Id; - Loc : constant Source_Ptr := Sloc (Pkg_Spec); RCI_Instantiation : Node_Id; - Subp_Stubs : Node_Id; - Subp_Str : String_Id; - pragma Warnings (Off, Subp_Str); + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate calling stub for one remote subprogram + + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Stubs : Node_Id; + Subp_Str : String_Id; + pragma Warnings (Off, Subp_Str); + + begin + Assign_Subprogram_Identifier + (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str); + + Subp_Stubs := + Build_Subprogram_Calling_Stubs ( + Vis_Decl => Decl, + Subp_Id => + Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)), + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Defining_Unit_Name (Spec))); + + Append_To (List_Containing (Decl), Subp_Stubs); + Analyze (Subp_Stubs); + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + + -- Start of processing for Add_Calling_Stubs_To_Declarations begin + Push_Scope (Scope_Of_Spec (Pkg_Spec)); + -- The first thing added is an instantiation of the generic package -- System.Partition_Interface.RCI_Locator with the name of this remote -- package. This will act as an interface with the name server to @@ -945,51 +1062,21 @@ package body Exp_Dist is RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); RCI_Cache := Defining_Unit_Name (RCI_Instantiation); - Append_To (Decls, RCI_Instantiation); + Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation); Analyze (RCI_Instantiation); -- For each subprogram declaration visible in the spec, we do build a -- body. We also increment a counter to assign a different Subprogram_Id - -- to each subprograms. The receiving stubs processing do use the same + -- to each subprograms. The receiving stubs processing uses the same -- mechanism and will thus assign the same Id and do the correct -- dispatching. Overload_Counter_Table.Reset; PolyORB_Support.Reserve_NamingContext_Methods; - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - Assign_Subprogram_Identifier - (Defining_Unit_Name (Specification (Current_Declaration)), - Current_Subprogram_Number, - Subp_Str); - - Subp_Stubs := - Build_Subprogram_Calling_Stubs ( - Vis_Decl => Current_Declaration, - Subp_Id => - Build_Subprogram_Id (Loc, - Defining_Unit_Name (Specification (Current_Declaration))), - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then - Is_Asynchronous (Defining_Unit_Name (Specification - (Current_Declaration)))); - - Append_To (Decls, Subp_Stubs); - Analyze (Subp_Stubs); - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; + Visit_Spec (Pkg_Spec); - -- Need to handle the case of nested packages??? - - Next (Current_Declaration); - end loop; + Pop_Scope; end Add_Calling_Stubs_To_Declarations; ----------------------------- @@ -2819,12 +2906,8 @@ package body Exp_Dist is procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is Spec : constant Node_Id := Specification (Unit_Node); - Decls : constant List_Id := Visible_Declarations (Spec); begin - Push_Scope (Scope_Of_Spec (Spec)); - Add_Calling_Stubs_To_Declarations - (Specification (Unit_Node), Decls); - Pop_Scope; + Add_Calling_Stubs_To_Declarations (Spec); end Expand_Calling_Stubs_Bodies; ----------------------------------- @@ -3685,6 +3768,7 @@ package body Exp_Dist is Pkg_RPC_Receiver_Body : Node_Id; -- A Pkg_RPC_Receiver is built to decode the request + Lookup_RAS : Node_Id; Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); -- A remote subprogram is created to allow peers to look up RAS -- information using subprogram ids. @@ -3693,9 +3777,8 @@ package body Exp_Dist is Subp_Index : Entity_Id; -- Subprogram_Id as read from the incoming stream - Current_Declaration : Node_Id; - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - Current_Stubs : Node_Id; + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + Current_Stubs : Node_Id; Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); Subp_Info_List : constant List_Id := New_List; @@ -3713,6 +3796,9 @@ package body Exp_Dist is -- associating Subprogram_Number with the subprogram declared -- by Declaration, for which we have receiving stubs in Stubs. + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate receiving stub for one remote subprogram + --------------------- -- Append_Stubs_To -- --------------------- @@ -3736,6 +3822,76 @@ package body Exp_Dist is New_Occurrence_Of (Request_Parameter, Loc)))))); end Append_Stubs_To; + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); + + Subp_Val : String_Id; + pragma Warnings (Off, Subp_Val); + + begin + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Decl, + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => Decl, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Object_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier + (Subp_Def, Current_Subp_Number, Subp_Val); + + pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms + -- table for this receiver. This aggregate must be kept consistent + -- with the declaration of RCI_Subp_Info in + -- System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Current_Subp_Number)), + + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + + -- Addr => + + Make_Component_Association (Loc, + Choices => + New_List (Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Stubs => Current_Stubs, + Subprogram_Number => Current_Subp_Number); + + Current_Subp_Number := Current_Subp_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + -- Start of processing for Add_Receiving_Stubs_To_Declarations begin @@ -3800,7 +3956,7 @@ package body Exp_Dist is -- Build a subprogram for RAS information lookups - Current_Declaration := + Lookup_RAS := Make_Subprogram_Declaration (Loc, Specification => Make_Function_Specification (Loc, @@ -3816,19 +3972,17 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); - - Append_To (Decls, Current_Declaration); - Analyze (Current_Declaration); + Append_To (Decls, Lookup_RAS); + Analyze (Lookup_RAS); Current_Stubs := Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, + (Vis_Decl => Lookup_RAS, Asynchronous => False); Append_To (Decls, Current_Stubs); Analyze (Current_Stubs); Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Stubs => - Current_Stubs, + Stubs => Current_Stubs, Subprogram_Number => 1); -- For each subprogram, the receiving stub will be built and a @@ -3841,87 +3995,7 @@ package body Exp_Dist is Overload_Counter_Table.Reset; - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - declare - Loc : constant Source_Ptr := Sloc (Current_Declaration); - -- While specifically processing Current_Declaration, use - -- its Sloc as the location of all generated nodes. - - Subp_Def : constant Entity_Id := - Defining_Unit_Name - (Specification (Current_Declaration)); - - Subp_Val : String_Id; - pragma Warnings (Off, Subp_Val); - - begin - -- Build receiving stub - - Current_Stubs := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then Is_Asynchronous (Subp_Def)); - - Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); - - -- Build RAS proxy - - Add_RAS_Proxy_And_Analyze (Decls, - Vis_Decl => Current_Declaration, - All_Calls_Remote_E => All_Calls_Remote_E, - Proxy_Object_Addr => Proxy_Object_Addr); - - -- Compute distribution identifier - - Assign_Subprogram_Identifier - (Subp_Def, - Current_Subprogram_Number, - Subp_Val); - - pragma Assert - (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def)); - - -- Add subprogram descriptor (RCI_Subp_Info) to the - -- subprograms table for this receiver. The aggregate - -- below must be kept consistent with the declaration - -- of type RCI_Subp_Info in System.Partition_Interface. - - Append_To (Subp_Info_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, - Current_Subprogram_Number)), - - Expression => - Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - Make_Identifier (Loc, Name_Addr)), - Expression => - New_Occurrence_Of ( - Proxy_Object_Addr, Loc)))))); - - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Stubs => Current_Stubs, - Subprogram_Number => Current_Subprogram_Number); - end; - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; - - -- Need to handle case of a nested package??? - - Next (Current_Declaration); - end loop; + Visit_Spec (Pkg_Spec); -- If we receive an invalid Subprogram_Id, it is best to do nothing -- rather than raising an exception since we do not want someone @@ -6654,13 +6728,10 @@ package body Exp_Dist is Dispatch_On_Address : constant List_Id := New_List; Dispatch_On_Name : constant List_Id := New_List; - Current_Declaration : Node_Id; - Current_Stubs : Node_Id; - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; + Current_Subp_Number : Int := First_RCI_Subprogram_Id; Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); - - Subp_Info_List : constant List_Id := New_List; + Subp_Info_List : constant List_Id := New_List; Register_Pkg_Actuals : constant List_Id := New_List; @@ -6681,6 +6752,9 @@ package body Exp_Dist is -- object, used in the context of calls through remote -- access-to-subprogram types. + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate receiving stub for one remote subprogram + --------------------- -- Append_Stubs_To -- --------------------- @@ -6744,6 +6818,110 @@ package body Exp_Dist is Make_Integer_Literal (Loc, Subp_Number))))); end Append_Stubs_To; + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); + + Subp_Val : String_Id; + + Subp_Dist_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Chars (Subp_Def), + Suffix => 'D', + Suffix_Index => -1)); + + Current_Stubs : Node_Id; + Proxy_Obj_Addr : Entity_Id; + + begin + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Decl, + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => Decl, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Obj_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier + (Subp_Def, Current_Subp_Number, Subp_Val); + + pragma Assert + (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Dist_Name, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Subp_Val))); + Analyze (Last (Decls)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms + -- table for this receiver. The aggregate below must be kept + -- consistent with the declaration of RCI_Subp_Info in + -- System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => + New_List (Make_Integer_Literal (Loc, Current_Subp_Number)), + + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + + -- Name => + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), + Attribute_Name => Name_Address), + + -- Name_Length => + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), + Attribute_Name => Name_Length), + + -- Addr => + + New_Occurrence_Of (Proxy_Obj_Addr, Loc))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => Decl, + Stubs => Current_Stubs, + Subp_Number => Current_Subp_Number, + Subp_Dist_Name => Subp_Dist_Name, + Subp_Proxy_Addr => Proxy_Obj_Addr); + + Current_Subp_Number := Current_Subp_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + -- Start of processing for Add_Receiving_Stubs_To_Declarations begin @@ -6804,113 +6982,7 @@ package body Exp_Dist is Overload_Counter_Table.Reset; Reserve_NamingContext_Methods; - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - declare - Loc : constant Source_Ptr := Sloc (Current_Declaration); - -- While specifically processing Current_Declaration, use - -- its Sloc as the location of all generated nodes. - - Subp_Def : constant Entity_Id := - Defining_Unit_Name - (Specification (Current_Declaration)); - - Subp_Val : String_Id; - - Subp_Dist_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name - (Related_Id => Chars (Subp_Def), - Suffix => 'D', - Suffix_Index => -1)); - - Proxy_Object_Addr : Entity_Id; - - begin - -- Build receiving stub - - Current_Stubs := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then Is_Asynchronous (Subp_Def)); - - Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); - - -- Build RAS proxy - - Add_RAS_Proxy_And_Analyze (Decls, - Vis_Decl => Current_Declaration, - All_Calls_Remote_E => All_Calls_Remote_E, - Proxy_Object_Addr => Proxy_Object_Addr); - - -- Compute distribution identifier - - Assign_Subprogram_Identifier - (Subp_Def, - Current_Subprogram_Number, - Subp_Val); - - pragma Assert - (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def)); - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Subp_Dist_Name, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Standard_String, Loc), - Expression => - Make_String_Literal (Loc, Subp_Val))); - Analyze (Last (Decls)); - - -- Add subprogram descriptor (RCI_Subp_Info) to the - -- subprograms table for this receiver. The aggregate - -- below must be kept consistent with the declaration - -- of type RCI_Subp_Info in System.Partition_Interface. - - Append_To (Subp_Info_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Current_Subprogram_Number)), - - Expression => - Make_Aggregate (Loc, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Dist_Name, Loc), - Attribute_Name => Name_Address), - - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Dist_Name, Loc), - Attribute_Name => Name_Length), - - New_Occurrence_Of (Proxy_Object_Addr, Loc))))); - - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Declaration => Current_Declaration, - Stubs => Current_Stubs, - Subp_Number => Current_Subprogram_Number, - Subp_Dist_Name => Subp_Dist_Name, - Subp_Proxy_Addr => Proxy_Object_Addr); - end; - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; - - -- Need to handle case of a nested package??? - - Next (Current_Declaration); - end loop; + Visit_Spec (Pkg_Spec); Append_To (Decls, Make_Object_Declaration (Loc, diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 005a246..9e1f185 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -507,7 +507,9 @@ package body Impunit is Non_Imp_File_Names_12 : constant File_List := ( "s-multip", -- System.Multiprocessors "s-mudido", -- System.Multiprocessors.Dispatching_Domains - "a-cobove"); -- Ada.Containers.Bounded_Vectors + "a-cobove", -- Ada.Containers.Bounded_Vectors + "a-cborse", -- Ada.Containers.Bounded_Ordered_Sets + "a-cborma"); -- Ada.Containers.Bounded_Ordered_Maps ----------------------- -- Alternative Units -- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 0cec74f..32058f0 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3314,12 +3314,13 @@ package body Sem_Ch12 is end if; end; - -- If we are generating the calling stubs from the instantiation of - -- a generic RCI package, we will not use the body of the generic - -- package. + -- If we are generating calling stubs, we never need a body for an + -- instantiation from source. However normal processing occurs for + -- any generic instantiation appearing in generated code, since we + -- do not generate stubs in that case. if Distribution_Stub_Mode = Generate_Caller_Stub_Body - and then Is_Compilation_Unit (Defining_Entity (N)) + and then Comes_From_Source (N) then Needs_Body := False; end if; @@ -4000,6 +4001,9 @@ package body Sem_Ch12 is Check_Formal_Packages (Pack_Id); Set_Is_Generic_Instance (Pack_Id, False); + -- Why do we clear Is_Generic_Instance??? We set it 20 lines + -- above??? + -- Body of the enclosing package is supplied when instantiating the -- subprogram body, after semantic analysis is completed. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ddbb77f..c0410df 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -12949,9 +12949,18 @@ package body Sem_Ch3 is Collect_Primitive_Operations (Parent_Type); function Check_Derived_Type return Boolean; - -- Check that all primitive inherited from Parent_Type are found in + -- Check that all the entities derived from Parent_Type are found in -- the list of primitives of Derived_Type exactly in the same order. + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id); + -- Derive New_Subp from the ultimate alias of the parent subprogram Subp + -- (which is an interface primitive). If Generic_Actual is present then + -- Actual_Subp is the actual subprogram corresponding with the generic + -- subprogram Subp. + function Check_Derived_Type return Boolean is E : Entity_Id; Elmt : Elmt_Id; @@ -13027,6 +13036,45 @@ package body Sem_Ch3 is return True; end Check_Derived_Type; + --------------------------------- + -- Derive_Interface_Subprogram -- + --------------------------------- + + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id) + is + Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); + Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); + + begin + pragma Assert (Is_Interface (Iface_Type)); + + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Subp, + Derived_Type => Derived_Type, + Parent_Type => Iface_Type, + Actual_Subp => Actual_Subp); + + -- Given that this new interface entity corresponds with a primitive + -- of the parent that was not overridden we must leave it associated + -- with its parent primitive to ensure that it will share the same + -- dispatch table slot when overridden. + + if No (Actual_Subp) then + Set_Alias (New_Subp, Subp); + + -- For instantiations this is not needed since the previous call to + -- Derive_Subprogram leaves the entity well decorated. + + else + pragma Assert (Alias (New_Subp) = Actual_Subp); + null; + end if; + end Derive_Interface_Subprogram; + -- Local variables Alias_Subp : Entity_Id; @@ -13179,7 +13227,7 @@ package body Sem_Ch3 is Alias_Subp := Ultimate_Alias (Subp); -- Do not derive internal entities of the parent that link - -- interface primitives and its covering primitive. These + -- interface primitives with their covering primitive. These -- entities will be added to this type when frozen. if Present (Interface_Alias (Subp)) then @@ -13334,15 +13382,74 @@ package body Sem_Ch3 is (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification and then Null_Present (Parent (Alias_Subp))) then - Derive_Subprogram - (New_Subp => New_Subp, - Parent_Subp => Alias_Subp, - Derived_Type => Derived_Type, - Parent_Type => Find_Dispatching_Type (Alias_Subp), - Actual_Subp => Act_Subp); + -- If this is an abstract private type then we transfer the + -- derivation of the interface primitive from the partial view + -- to the full view. This is safe because all the interfaces + -- must be visible in the partial view. Done to avoid adding + -- a new interface derivation to the private part of the + -- enclosing package; otherwise this new derivation would be + -- decorated as hidden when the analysis of the enclosing + -- package completes. + + if Is_Abstract_Type (Derived_Type) + and then In_Private_Part (Current_Scope) + and then Has_Private_Declaration (Derived_Type) + then + declare + Partial_View : Entity_Id; + Elmt : Elmt_Id; + Ent : Entity_Id; + + begin + Partial_View := First_Entity (Current_Scope); + loop + exit when No (Partial_View) + or else (Has_Private_Declaration (Partial_View) + and then + Full_View (Partial_View) = Derived_Type); + + Next_Entity (Partial_View); + end loop; + + -- If the partial view was not found then the source code + -- has errors and the derivation is not needed. - if No (Generic_Actual) then - Set_Alias (New_Subp, Subp); + if Present (Partial_View) then + Elmt := + First_Elmt (Primitive_Operations (Partial_View)); + while Present (Elmt) loop + Ent := Node (Elmt); + + if Present (Alias (Ent)) + and then Ultimate_Alias (Ent) = Alias (Subp) + then + Append_Elmt + (Ent, Primitive_Operations (Derived_Type)); + exit; + end if; + + Next_Elmt (Elmt); + end loop; + + -- If the interface primitive was not found in the + -- partial view then this interface primitive was + -- overridden. We add a derivation to activate in + -- Derive_Progenitor_Subprograms the machinery to + -- search for it. + + if No (Elmt) then + Derive_Interface_Subprogram + (New_Subp => New_Subp, + Subp => Subp, + Actual_Subp => Act_Subp); + end if; + end if; + end; + else + Derive_Interface_Subprogram + (New_Subp => New_Subp, + Subp => Subp, + Actual_Subp => Act_Subp); end if; -- Case 3: Common derivation diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 322c168..2152407 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3045,9 +3045,9 @@ package body Sem_Util is Set_Scope (Def_Id, Current_Scope); return; - -- Analogous to privals, the discriminal generated for an entry - -- index parameter acts as a weak declaration. Perform minimal - -- decoration to avoid bogus errors. + -- Analogous to privals, the discriminal generated for an entry index + -- parameter acts as a weak declaration. Perform minimal decoration + -- to avoid bogus errors. elsif Is_Discriminal (Def_Id) and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter @@ -3055,11 +3055,10 @@ package body Sem_Util is Set_Scope (Def_Id, Current_Scope); return; - -- In the body or private part of an instance, a type extension - -- may introduce a component with the same name as that of an - -- actual. The legality rule is not enforced, but the semantics - -- of the full type with two components of the same name are not - -- clear at this point ??? + -- In the body or private part of an instance, a type extension may + -- introduce a component with the same name as that of an actual. The + -- legality rule is not enforced, but the semantics of the full type + -- with two components of same name are not clear at this point??? elsif In_Instance_Not_Visible then null; @@ -3073,9 +3072,9 @@ package body Sem_Util is then null; - -- Conversely, with front-end inlining we may compile the parent - -- body first, and a child unit subsequently. The context is now - -- the parent spec, and body entities are not visible. + -- Conversely, with front-end inlining we may compile the parent body + -- first, and a child unit subsequently. The context is now the + -- parent spec, and body entities are not visible. elsif Is_Child_Unit (Def_Id) and then Is_Package_Body_Entity (E) @@ -3089,8 +3088,8 @@ package body Sem_Util is Error_Msg_Sloc := Sloc (E); -- If the previous declaration is an incomplete type declaration - -- this may be an attempt to complete it with a private type. - -- The following avoids confusing cascaded errors. + -- this may be an attempt to complete it with a private type. The + -- following avoids confusing cascaded errors. if Nkind (Parent (E)) = N_Incomplete_Type_Declaration and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration @@ -3113,9 +3112,9 @@ package body Sem_Util is Error_Msg_N ("& conflicts with declaration#", E); return; - -- If the name of the unit appears in its own context clause, - -- a dummy package with the name has already been created, and - -- the error emitted. Try to continue quietly. + -- If the name of the unit appears in its own context clause, a + -- dummy package with the name has already been created, and the + -- error emitted. Try to continue quietly. elsif Error_Posted (E) and then Sloc (E) = No_Location @@ -3144,9 +3143,9 @@ package body Sem_Util is Error_Msg_N ("\generic units cannot be overloaded", Def_Id); end if; - -- If entity is in standard, then we are in trouble, because - -- it means that we have a library package with a duplicated - -- name. That's hard to recover from, so abort! + -- If entity is in standard, then we are in trouble, because it + -- means that we have a library package with a duplicated name. + -- That's hard to recover from, so abort! if S = Standard_Standard then raise Unrecoverable_Error; @@ -3160,17 +3159,17 @@ package body Sem_Util is end if; end if; - -- If we fall through, declaration is OK , or OK enough to continue + -- If we fall through, declaration is OK, at least OK enough to continue - -- If Def_Id is a discriminant or a record component we are in the - -- midst of inheriting components in a derived record definition. - -- Preserve their Ekind and Etype. + -- If Def_Id is a discriminant or a record component we are in the midst + -- of inheriting components in a derived record definition. Preserve + -- their Ekind and Etype. if Ekind_In (Def_Id, E_Discriminant, E_Component) then null; - -- If a type is already set, leave it alone (happens whey a type - -- declaration is reanalyzed following a call to the optimizer) + -- If a type is already set, leave it alone (happens when a type + -- declaration is reanalyzed following a call to the optimizer). elsif Present (Etype (Def_Id)) then null; @@ -3227,8 +3226,8 @@ package body Sem_Util is and then In_Extended_Main_Source_Unit (Def_Id) - -- Finally, the hidden entity must be either immediately visible - -- or use visible (from a used package) + -- Finally, the hidden entity must be either immediately visible or + -- use visible (i.e. from a used package). and then (Is_Immediately_Visible (C) diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 0d7183d..57d8ee9 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -425,8 +425,8 @@ begin Write_Line (" F* turn off warnings for unreferenced formal"); Write_Line (" g*+ turn on warnings for unrecognized pragma"); Write_Line (" G turn off warnings for unrecognized pragma"); - Write_Line (" h turn on warnings for hiding variable"); - Write_Line (" H* turn off warnings for hiding variable"); + Write_Line (" h turn on warnings for hiding declarations"); + Write_Line (" H* turn off warnings for hiding declarations"); Write_Line (" .h turn on warnings for holes in records"); Write_Line (" .H* turn off warnings for holes in records"); Write_Line (" i*+ turn on warnings for implementation unit"); |