diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-01-10 11:06:44 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-01-10 11:06:44 +0000 |
commit | ae8e99a36859a079b40a4693302062976a537f05 (patch) | |
tree | 294b7686614c59eae2c0a4ac8ed8cd7342de0f82 /gcc | |
parent | 43537c9651f05e0ad6ba2c752dcfdfb762ef8376 (diff) | |
download | gcc-ae8e99a36859a079b40a4693302062976a537f05.tar.gz |
2012-01-10 Pascal Obry <obry@adacore.com>
* prj-nmsc.adb (Check_Library_Attributes): Kill check for object/source
directories for aggregate libraries.
2012-01-10 Matthew Heaney <heaney@adacore.com>
* a-cdlili.adb, a-cdlili.ads, a-cihama.adb, a-cihama.ads, a-coinve.adb,
a-coinve.ads, a-ciorse.adb, a-ciorse.ads, a-coorma.adb, a-coorma.ads,
a-cborma.adb, a-cborma.ads, a-cidlli.adb, a-cidlli.ads, a-cimutr.adb,
a-cimutr.ads, a-cihase.adb, a-cihase.ads, a-cohama.adb, a-cohama.ads,
a-coorse.adb, a-coorse.ads, a-cbhama.adb, a-cbhama.ads, a-cborse.adb,
a-cborse.ads, a-comutr.adb, a-comutr.ads, a-ciorma.adb, a-cobove.adb,
a-ciorma.ads, a-cobove.ads, a-convec.adb, a-convec.ads, a-cohase.adb,
a-cohase.ads, a-cbdlli.adb, a-cbdlli.ads, a-cbmutr.adb, a-cbmutr.ads,
a-cbhase.adb, a-cbhase.ads (Reference, Constant_Reference): Declare
container parameter as aliased in/in out.
Code clean ups.
2012-01-10 Bob Duff <duff@adacore.com>
* s-os_lib.ads: Improve comment.
2012-01-10 Geert Bosch <bosch@adacore.com>
* s-gearop.adb (Forward_Eliminate): Avoid improper aliasing
for complex Scalar.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183060 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
46 files changed, 2248 insertions, 1027 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 89a8830b4a5..07670749690 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2012-01-10 Pascal Obry <obry@adacore.com> + + * prj-nmsc.adb (Check_Library_Attributes): + Kill check for object/source directories for aggregate libraries. + +2012-01-10 Matthew Heaney <heaney@adacore.com> + + * a-cdlili.adb, a-cdlili.ads, a-cihama.adb, a-cihama.ads, a-coinve.adb, + a-coinve.ads, a-ciorse.adb, a-ciorse.ads, a-coorma.adb, a-coorma.ads, + a-cborma.adb, a-cborma.ads, a-cidlli.adb, a-cidlli.ads, a-cimutr.adb, + a-cimutr.ads, a-cihase.adb, a-cihase.ads, a-cohama.adb, a-cohama.ads, + a-coorse.adb, a-coorse.ads, a-cbhama.adb, a-cbhama.ads, a-cborse.adb, + a-cborse.ads, a-comutr.adb, a-comutr.ads, a-ciorma.adb, a-cobove.adb, + a-ciorma.ads, a-cobove.ads, a-convec.adb, a-convec.ads, a-cohase.adb, + a-cohase.ads, a-cbdlli.adb, a-cbdlli.ads, a-cbmutr.adb, a-cbmutr.ads, + a-cbhase.adb, a-cbhase.ads (Reference, Constant_Reference): Declare + container parameter as aliased in/in out. + Code clean ups. + +2012-01-10 Bob Duff <duff@adacore.com> + + * s-os_lib.ads: Improve comment. + +2012-01-10 Geert Bosch <bosch@adacore.com> + + * s-gearop.adb (Forward_Eliminate): Avoid improper aliasing + for complex Scalar. + 2012-01-10 Bob Duff <duff@adacore.com> * sem_intr.adb (Check_Shift): Use RM_Size instead of Esize, when diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index 25113d00c28..40f5d8f2ead 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -296,6 +296,33 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Free (Container, X); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1537,34 +1564,27 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- Reference -- --------------- - function Constant_Reference - (Container : List; - Position : Cursor) return Constant_Reference_Type - is - begin - pragma Unreferenced (Container); - - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => - Position.Container.Nodes (Position.Node).Element'Unrestricted_Access); - end Constant_Reference; - function Reference - (Container : List; + (Container : aliased in out List; Position : Cursor) return Reference_Type is begin - pragma Unreferenced (Container); - if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - return (Element => - Position.Container.Nodes (Position.Node).Element'Unrestricted_Access); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Reference"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; end Reference; --------------------- diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads index df0633f4c69..6612ea1e533 100644 --- a/gcc/ada/a-cbdlli.ads +++ b/gcc/ada/a-cbdlli.ads @@ -88,6 +88,48 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type; + procedure Assign (Target : in out List; Source : List); function Copy (Source : List; Capacity : Count_Type := 0) return List; @@ -223,48 +265,6 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is end Generic_Sorting; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is - private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - function Constant_Reference - (Container : List; -- SHOULD BE ALIASED ??? - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : List; -- SHOULD BE ALIASED ??? - Position : Cursor) return Reference_Type; - private pragma Inline (Next); @@ -273,7 +273,7 @@ private type Node_Type is record Prev : Count_Type'Base; Next : Count_Type; - Element : Element_Type; + Element : aliased Element_Type; end record; type Node_Array is array (Count_Type range <>) of Node_Type; diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index d52aea05376..b14383e321c 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -190,6 +190,53 @@ package body Ada.Containers.Bounded_Hashed_Maps is HT_Ops.Clear (Container); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Position), + "Position cursor in Constant_Reference is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + + function Constant_Reference + (Container : Map; + Key : Key_Type) return Constant_Reference_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; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -916,16 +963,47 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- Reference -- --------------- - function Constant_Reference (Container : Map; Key : Key_Type) - return Constant_Reference_Type is + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type + is begin - return (Element => Container.Element (Key)'Unrestricted_Access); - end Constant_Reference; + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Position), + "Position cursor in function Reference is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); - function Reference (Container : Map; Key : Key_Type) - return Reference_Type is begin - return (Element => Container.Element (Key)'Unrestricted_Access); + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return (Element => N.Element'Access); + end; end Reference; ------------- diff --git a/gcc/ada/a-cbhama.ads b/gcc/ada/a-cbhama.ads index 4d7cfa2225b..78347c5473d 100644 --- a/gcc/ada/a-cbhama.ads +++ b/gcc/ada/a-cbhama.ads @@ -134,6 +134,56 @@ package Ada.Containers.Bounded_Hashed_Maps is -- Calls Process with the key (with only a constant view) and element (with -- a variable view) of the node designed by the cursor. + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + procedure Assign (Target : in out Map; Source : Map); -- If Target denotes the same object as Source, then the operation has no -- effect. If the Target capacity is less then the Source length, then @@ -286,47 +336,6 @@ package Ada.Containers.Bounded_Hashed_Maps is function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - function Constant_Reference - (Container : Map; - Key : Key_Type) -- SHOULD BE ALIASED??? - return Constant_Reference_Type; - - function Reference (Container : Map; Key : Key_Type) return Reference_Type; - private pragma Inline (Length); pragma Inline (Is_Empty); @@ -342,7 +351,7 @@ private type Node_Type is record Key : Key_Type; - Element : Element_Type; + Element : aliased Element_Type; Next : Count_Type; end record; diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index b52d7fffa7e..7e294d3fb75 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -210,6 +210,33 @@ package body Ada.Containers.Bounded_Hashed_Sets is HT_Ops.Clear (Container); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1145,21 +1172,6 @@ package body Ada.Containers.Bounded_Hashed_Sets is raise Program_Error with "attempt to stream reference"; end Read; - --------------- - -- Reference -- - --------------- - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - pragma Unreferenced (Container); - S : Set renames Position.Container.all; - N : Node_Type renames S.Nodes (Position.Node); - begin - return (Element => N.Element'Unrestricted_Access); - end Constant_Reference; - ------------- -- Replace -- ------------- @@ -1581,6 +1593,28 @@ package body Ada.Containers.Bounded_Hashed_Sets is Hash => Hash, Equivalent_Keys => Equivalent_Key_Node); + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_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; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1686,6 +1720,69 @@ package body Ada.Containers.Bounded_Hashed_Sets is return Key (Position.Container.Nodes (Position.Node).Element); end Key; + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Position), + "bad cursor in function Reference_Preserving_Key"); + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Position has + -- not changed. ??? + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_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; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return (Element => N.Element'Access); + end; + end Reference_Preserving_Key; + ------------- -- Replace -- ------------- @@ -1806,28 +1903,17 @@ package body Ada.Containers.Bounded_Hashed_Sets is raise Program_Error with "key was modified"; end Update_Element_Preserving_Key; - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - N : Node_Type renames Container.Nodes (Position.Node); - begin - return (Element => N.Element'Unrestricted_Access); - end Reference_Preserving_Key; + ----------- + -- Write -- + ----------- - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) is - Position : constant Cursor := Find (Container, Key); - N : Node_Type renames Container.Nodes (Position.Node); begin - return (Element => N.Element'Unrestricted_Access); - end Reference_Preserving_Key; + raise Program_Error with "attempt to stream reference"; + end Write; end Generic_Keys; diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads index 3f6b6696871..ceb358204bb 100644 --- a/gcc/ada/a-cbhase.ads +++ b/gcc/ada/a-cbhase.ads @@ -433,6 +433,10 @@ package Ada.Containers.Bounded_Hashed_Sets is (Container : aliased in out Set; Position : Cursor) return Reference_Type; + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + function Reference_Preserving_Key (Container : aliased in out Set; Key : Key_Type) return Reference_Type; @@ -441,13 +445,27 @@ package Ada.Containers.Bounded_Hashed_Sets is type Reference_Type (Element : not null access Element_Type) is null record; + use Ada.Streams; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + end Generic_Keys; private pragma Inline (Next); type Node_Type is record - Element : Element_Type; + Element : aliased Element_Type; Next : Count_Type; end record; diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index 0e05e8b5f74..e40c7bfc82d 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -588,6 +588,36 @@ package body Ada.Containers.Bounded_Multiway_Trees is pragma Assert (Count = Container_Count); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + return (Element => Container.Elements (Position.Node)'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -2464,26 +2494,30 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- Reference -- --------------- - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type - is - pragma Unreferenced (Container); - begin - return - (Element => - Position.Container.Elements (Position.Node)'Unchecked_Access); - end Constant_Reference; - function Reference - (Container : aliased Tree; + (Container : aliased in out Tree; Position : Cursor) return Reference_Type is - pragma Unreferenced (Container); begin - return - (Element => - Position.Container.Elements (Position.Node)'Unchecked_Access); + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + return (Element => Container.Elements (Position.Node)'Access); end Reference; -------------------- diff --git a/gcc/ada/a-cbmutr.ads b/gcc/ada/a-cbmutr.ads index b114ffc3db8..46263088cd3 100644 --- a/gcc/ada/a-cbmutr.ads +++ b/gcc/ada/a-cbmutr.ads @@ -107,6 +107,14 @@ package Ada.Containers.Bounded_Multiway_Trees is (Element : not null access Element_Type) is private with Implicit_Dereference => Element; + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type; + procedure Assign (Target : in out Tree; Source : Tree); function Copy (Source : Tree; Capacity : Count_Type := 0) return Tree; @@ -375,6 +383,7 @@ private type Reference_Type (Element : not null access Element_Type) is null record; + procedure Write (Stream : not null access Root_Stream_Type'Class; Item : Reference_Type); @@ -385,14 +394,6 @@ private Item : out Reference_Type); for Reference_Type'Read use Read; - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased Tree; - Position : Cursor) return Reference_Type; - Empty_Tree : constant Tree := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(others => <>); diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb index b39d9ae3a55..9dec108219b 100644 --- a/gcc/ada/a-cborma.adb +++ b/gcc/ada/a-cborma.adb @@ -402,6 +402,53 @@ package body Ada.Containers.Bounded_Ordered_Maps is return Node.Color; end Color; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor in Constant_Reference is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + + function Constant_Reference + (Container : Map; + Key : Key_Type) return Constant_Reference_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; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1318,20 +1365,47 @@ package body Ada.Containers.Bounded_Ordered_Maps is -- Reference -- --------------- - function Constant_Reference - (Container : Map; - Key : Key_Type) return Constant_Reference_Type + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type is begin - return (Element => Container.Element (Key)'Unrestricted_Access); - end Constant_Reference; + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor in function Reference is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Reference; function Reference - (Container : Map; + (Container : aliased in out Map; Key : Key_Type) return Reference_Type is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + begin - return (Element => Container.Element (Key)'Unrestricted_Access); + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return (Element => N.Element'Access); + end; end Reference; ------------- diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads index 05c55730f10..bfb6f016028 100644 --- a/gcc/ada/a-cborma.ads +++ b/gcc/ada/a-cborma.ads @@ -50,7 +50,7 @@ package Ada.Containers.Bounded_Ordered_Maps is function Equivalent_Keys (Left, Right : Key_Type) return Boolean; type Map (Capacity : Count_Type) is tagged private with - constant_Indexing => Constant_Reference, + Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, Iterator_Element => Element_Type; @@ -97,6 +97,55 @@ package Ada.Containers.Bounded_Ordered_Maps is Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + procedure Assign (Target : in out Map; Source : Map); function Copy (Source : Map; Capacity : Count_Type := 0) return Map; @@ -183,46 +232,6 @@ package Ada.Containers.Bounded_Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - function Constant_Reference - (Container : Map; - Key : Key_Type) -- SHOULD BE ALIASED ??? - return Constant_Reference_Type; - - function Reference (Container : Map; Key : Key_Type) return Reference_Type; - procedure Iterate (Container : Map; Process : not null access procedure (Position : Cursor)); @@ -251,7 +260,7 @@ private Right : Count_Type; Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; Key : Key_Type; - Element : Element_Type; + Element : aliased Element_Type; end record; package Tree_Types is diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index 557983d04c2..62417f36b11 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -402,6 +402,35 @@ package body Ada.Containers.Bounded_Ordered_Sets is return Node.Color; end Color; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Container, Position.Node), + "bad cursor in Constant_Reference"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -697,6 +726,28 @@ package body Ada.Containers.Bounded_Ordered_Sets is else Cursor'(Container'Unrestricted_Access, Node)); end Ceiling; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_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; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return (Element => N.Element'Access); + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -822,6 +873,69 @@ package body Ada.Containers.Bounded_Ordered_Sets is return Key (Position.Container.Nodes (Position.Node).Element); end Key; + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Container, Position.Node), + "bad cursor in function Reference_Preserving_Key"); + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Position has + -- not changed. ??? + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_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; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return (Element => N.Element'Access); + end; + end Reference_Preserving_Key; + ------------- -- Replace -- ------------- @@ -900,45 +1014,9 @@ package body Ada.Containers.Bounded_Ordered_Sets is raise Program_Error with "key was modified"; end Update_Element_Preserving_Key; - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Constant_Reference_Type - is - Position : constant Cursor := Find (Container, Key); - - begin - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return - (Element => - Container.Nodes (Position.Node).Element'Unrestricted_Access); - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Position : constant Cursor := Find (Container, Key); - - begin - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return - (Element => - Container.Nodes (Position.Node).Element'Unrestricted_Access); - end Reference_Preserving_Key; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; + ----------- + -- Write -- + ----------- procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -1585,22 +1663,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is raise Program_Error with "attempt to stream reference"; end Read; - --------------- - -- Reference -- - --------------- - - function Constant_Reference (Container : Set; Position : Cursor) - return Constant_Reference_Type - is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => - Container.Nodes (Position.Node).Element'Unrestricted_Access); - end Constant_Reference; - ------------- -- Replace -- ------------- diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads index 9c4fdb4f31d..6a8bff96a0d 100644 --- a/gcc/ada/a-cborse.ads +++ b/gcc/ada/a-cborse.ads @@ -65,16 +65,6 @@ package Ada.Containers.Bounded_Ordered_Sets is package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : Set; Position : Cursor) - return Constant_Reference_Type; - function "=" (Left, Right : Set) return Boolean; function Equivalent_Sets (Left, Right : Set) return Boolean; @@ -98,6 +88,16 @@ package Ada.Containers.Bounded_Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + procedure Assign (Target : in out Set; Source : Set); function Copy (Source : Set; Capacity : Count_Type := 0) return Set; @@ -263,6 +263,10 @@ package Ada.Containers.Bounded_Ordered_Sets is function Reference_Preserving_Key (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; Key : Key_Type) return Constant_Reference_Type; function Reference_Preserving_Key @@ -297,7 +301,7 @@ private Left : Count_Type; Right : Count_Type; Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Element : Element_Type; + Element : aliased Element_Type; end record; package Tree_Types is diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index f56578c0364..55defaec254 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -219,6 +219,29 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Warnings (On); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + return (Element => Position.Node.Element'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1277,31 +1300,22 @@ package body Ada.Containers.Doubly_Linked_Lists is -- Reference -- --------------- - function Constant_Reference - (Container : List; - Position : Cursor) return Constant_Reference_Type - is - begin - pragma Unreferenced (Container); - - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => Position.Node.Element'Access); - end Constant_Reference; - function Reference - (Container : List; + (Container : aliased in out List; Position : Cursor) return Reference_Type is begin - pragma Unreferenced (Container); - if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; + if Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Reference"); + return (Element => Position.Node.Element'Access); end Reference; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 6662ff161e6..4799198a39a 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -90,6 +90,48 @@ package Ada.Containers.Doubly_Linked_Lists is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type; + procedure Assign (Target : in out List; Source : List); function Copy (Source : List) return List; @@ -222,48 +264,6 @@ package Ada.Containers.Doubly_Linked_Lists is end Generic_Sorting; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is - private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - function Constant_Reference - (Container : List; Position : Cursor) -- SHOULD BE ALIASED - return Constant_Reference_Type; - - function Reference - (Container : List; Position : Cursor) -- SHOULD BE ALIASED - return Reference_Type; - private pragma Inline (Next); diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index bad5a896455..183f6a8614a 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -242,6 +242,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Free (X); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + return (Element => Position.Node.Element.all'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1303,27 +1330,26 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -- Reference -- --------------- - function Constant_Reference (Container : List; Position : Cursor) - return Constant_Reference_Type is + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type + is begin - pragma Unreferenced (Container); - if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - return (Element => Position.Node.Element.all'Access); - end Constant_Reference; - - function Reference (Container : List; Position : Cursor) - return Reference_Type is - begin - pragma Unreferenced (Container); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; end if; + pragma Assert (Vet (Position), "bad cursor in function Reference"); + return (Element => Position.Node.Element.all'Access); end Reference; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index be1b4344a8a..762693c7b9d 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -90,6 +90,48 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type; + procedure Assign (Target : in out List; Source : List); function Copy (Source : List) return List; @@ -203,50 +245,6 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'class; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is - private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - function Constant_Reference - (Container : List; - Position : Cursor) -- SHOULD BE ALIASED ??? - return Constant_Reference_Type; - - function Reference - (Container : List; - Position : Cursor) -- SHOULD BE ALIASED ??? - return Reference_Type; - generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 51e8c0c2424..35419020c10 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -189,6 +189,55 @@ package body Ada.Containers.Indefinite_Hashed_Maps is HT_Ops.Clear (Container.HT); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + if Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Position), + "Position cursor in Constant_Reference is bad"); + + return (Element => Position.Node.Element.all'Access); + end Constant_Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Node.Element = null then + raise Program_Error with "key has no element"; + end if; + + return (Element => Node.Element.all'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -955,31 +1004,49 @@ package body Ada.Containers.Indefinite_Hashed_Maps is -- Reference -- --------------- - function Constant_Reference - (Container : Map; - Key : Key_Type) return Constant_Reference_Type - is - begin - return (Element => - Container.Find (Key).Node.Element.all'Unrestricted_Access); - end Constant_Reference; - function Reference - (Container : Map; - Key : Key_Type) return Reference_Type + (Container : aliased in out Map; + Position : Cursor) return Reference_Type is begin - return (Element => - Container.Find (Key).Node.Element.all'Unrestricted_Access); + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + if Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Position), + "Position cursor in function Reference is bad"); + + return (Element => Position.Node.Element.all'Access); end Reference; function Reference (Container : aliased in out Map; - Position : Cursor) return Reference_Type + Key : Key_Type) return Reference_Type is - pragma Unreferenced (Container); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + begin - return (Element => Element (Position)'Unrestricted_Access); + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Node.Element = null then + raise Program_Error with "key has no element"; + end if; + + return (Element => Node.Element.all'Access); end Reference; ------------- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 567fe4ed6f6..2cd41eb0b46 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -134,6 +134,55 @@ package Ada.Containers.Indefinite_Hashed_Maps is -- Calls Process with the key (with only a constant view) and element (with -- a variable view) of the node designed by the cursor. + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + procedure Assign (Target : in out Map; Source : Map); function Copy (Source : Map; Capacity : Count_Type := 0) return Map; @@ -255,52 +304,6 @@ package Ada.Containers.Indefinite_Hashed_Maps is -- Returns the result of calling Equivalent_Keys with key Left and the node -- designated by Right. - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - function Constant_Reference - (Container : Map; - Key : Key_Type) -- SHOULD BE ALIASED ??? - return Constant_Reference_Type; - - function Reference - (Container : Map; - Key : Key_Type) return Reference_Type; - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type; - procedure Iterate (Container : Map; Process : not null access procedure (Position : Cursor)); diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index e6899e8622e..6255675550e 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -204,6 +204,33 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Clear (Container.HT); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + return (Element => Position.Node.Element.all'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1220,19 +1247,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end Read_Node; - --------------- - -- Reference -- - --------------- - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - pragma Unreferenced (Container); - begin - return (Element => Position.Node.Element.all'Access); - end Constant_Reference; - ------------- -- Replace -- ------------- @@ -1892,6 +1906,29 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Hash => Hash, Equivalent_Keys => Equivalent_Key_Node); + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := + Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + if Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + return (Element => Node.Element.all'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -2001,6 +2038,74 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return Key (Position.Node.Element.all); end Key; + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert + (Vet (Position), + "bad cursor in function Reference_Preserving_Key"); + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Position has + -- not changed. ??? + + return (Element => Position.Node.Element.all'Access); + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := + Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + if Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Key has not + -- changed. ??? + + return (Element => Node.Element.all'Access); + end Reference_Preserving_Key; + ------------- -- Replace -- ------------- @@ -2022,6 +2127,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Replace_Element (Container.HT, Node, New_Item); end Replace; + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + procedure Update_Element_Preserving_Key (Container : in out Set; Position : Cursor; @@ -2123,27 +2232,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise Program_Error with "key was modified"; end Update_Element_Preserving_Key; - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - pragma Unreferenced (Container); - begin - return (Element => Position.Node.Element.all'Access); - end Reference_Preserving_Key; + ----------- + -- Write -- + ----------- - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) is - Position : constant Cursor := Find (Container, Key); begin - return (Element => Position.Node.Element.all'Access); - end Reference_Preserving_Key; + raise Program_Error with "attempt to stream reference"; + end Write; end Generic_Keys; diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index 33994cdeffa..db59bdb7a00 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -150,8 +150,7 @@ package Ada.Containers.Indefinite_Hashed_Sets is function Constant_Reference (Container : aliased Set; - Position : Cursor) - return Constant_Reference_Type; + Position : Cursor) return Constant_Reference_Type; procedure Assign (Target : in out Set; Source : Set); @@ -420,6 +419,10 @@ package Ada.Containers.Indefinite_Hashed_Sets is (Container : aliased in out Set; Position : Cursor) return Reference_Type; + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + function Reference_Preserving_Key (Container : aliased in out Set; Key : Key_Type) return Reference_Type; @@ -427,6 +430,20 @@ package Ada.Containers.Indefinite_Hashed_Sets is private type Reference_Type (Element : not null access Element_Type) is null record; + + use Ada.Streams; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; end Generic_Keys; private diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index daac18feb04..c3887a57769 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -441,6 +441,40 @@ package body Ada.Containers.Indefinite_Multiway_Trees is pragma Assert (Children_Count = Container_Count); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + return (Element => Position.Node.Element.all'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1980,24 +2014,34 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- Reference -- --------------- - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type - is - begin - pragma Unreferenced (Container); - - return (Element => Position.Node.Element.all'Unchecked_Access); - end Constant_Reference; - function Reference - (Container : aliased Tree; + (Container : aliased in out Tree; Position : Cursor) return Reference_Type is begin - pragma Unreferenced (Container); + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element.all'Unchecked_Access); + return (Element => Position.Node.Element.all'Access); end Reference; -------------------- diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads index 6d5684d1b35..87c0e41f1d5 100644 --- a/gcc/ada/a-cimutr.ads +++ b/gcc/ada/a-cimutr.ads @@ -109,6 +109,14 @@ package Ada.Containers.Indefinite_Multiway_Trees is (Element : not null access Element_Type) is private with Implicit_Dereference => Element; + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type; + procedure Assign (Target : in out Tree; Source : Tree); function Copy (Source : Tree) return Tree; @@ -400,14 +408,6 @@ private for Reference_Type'Write use Write; - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased Tree; - Position : Cursor) return Reference_Type; - Empty_Tree : constant Tree := (Controlled with others => <>); No_Element : constant Cursor := (others => <>); diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index d775b27fc1f..15efbc7243d 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -358,12 +358,46 @@ package body Ada.Containers.Indefinite_Ordered_Maps is ------------------------ function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor in Constant_Reference is bad"); + + return (Element => Position.Node.Element.all'Access); + end Constant_Reference; + + function Constant_Reference (Container : Map; Key : Key_Type) return Constant_Reference_Type is - Node : aliased Element_Type := Element (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin - return (Element => Node'Access); + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + return (Element => Node.Element.all'Access); end Constant_Reference; -------------- @@ -1305,13 +1339,46 @@ package body Ada.Containers.Indefinite_Ordered_Maps is --------------- function Reference - (Container : Map; - Key : Key_Type) - return Reference_Type + (Container : aliased in out Map; + Position : Cursor) return Reference_Type is - Node : aliased Element_Type := Element (Container, Key); begin - return (Element => Node'Access); + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor in function Reference is bad"); + + return (Element => Position.Node.Element.all'Access); + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + return (Element => Node.Element.all'Access); end Reference; ------------- diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index f4c1321835e..814f062537e 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -50,7 +50,7 @@ package Ada.Containers.Indefinite_Ordered_Maps is function Equivalent_Keys (Left, Right : Key_Type) return Boolean; type Map is tagged private - with constant_Indexing => Constant_Reference, + with Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, Iterator_Element => Element_Type; @@ -96,6 +96,31 @@ package Ada.Containers.Indefinite_Ordered_Maps is Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + procedure Assign (Target : in out Map; Source : Map); function Copy (Source : Map) return Map; @@ -176,23 +201,6 @@ package Ada.Containers.Indefinite_Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : Map; - Key : Key_Type) return Constant_Reference_Type; - - function Reference - (Container : Map; - Key : Key_Type) return Reference_Type; - procedure Iterate (Container : Map; Process : not null access procedure (Position : Cursor)); diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 0a99a82a7a9..ff929067237 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -372,6 +372,35 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Node.Color; end Color; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert + (Vet (Container.Tree, Position.Node), + "bad cursor in Constant_Reference"); + + return (Element => Position.Node.Element.all'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -733,6 +762,29 @@ package body Ada.Containers.Indefinite_Ordered_Sets is else Cursor'(Container'Unrestricted_Access, Node)); end Ceiling; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + if Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + return (Element => Node.Element.all'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -889,6 +941,74 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Replace_Element (Container.Tree, Node, New_Item); end Replace; + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert + (Vet (Container.Tree, Position.Node), + "bad cursor in function Reference_Preserving_Key"); + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Position has + -- not changed. ??? + + return (Element => Position.Node.Element.all'Access); + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + if Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Key has not + -- changed. ??? + + return (Element => Node.Element.all'Access); + end Reference_Preserving_Key; + ----------------------------------- -- Update_Element_Preserving_Key -- ----------------------------------- @@ -955,41 +1075,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error with "key was modified"; end Update_Element_Preserving_Key; - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Constant_Reference_Type - is - Position : constant Cursor := Find (Container, Key); - - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => Position.Node.Element); - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Position : constant Cursor := Find (Container, Key); - - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => Position.Node.Element); - end Reference_Preserving_Key; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; + ----------- + -- Write -- + ----------- procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -1653,22 +1741,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error with "attempt to stream reference"; end Read; - --------------- - -- Reference -- - --------------- - - function Constant_Reference (Container : Set; Position : Cursor) - return Constant_Reference_Type - is - pragma Unreferenced (Container); - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => Position.Node.Element.all'Access); - end Constant_Reference; - ------------- -- Replace -- ------------- diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index ac711246542..5e2f84d2490 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -67,27 +67,6 @@ package Ada.Containers.Indefinite_Ordered_Sets is package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : Set; - Position : Cursor) return Constant_Reference_Type; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - function "=" (Left, Right : Set) return Boolean; function Equivalent_Sets (Left, Right : Set) return Boolean; @@ -111,6 +90,27 @@ package Ada.Containers.Indefinite_Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + procedure Assign (Target : in out Set; Source : Set); function Copy (Source : Set) return Set; @@ -292,6 +292,10 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Reference_Preserving_Key (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; Key : Key_Type) return Constant_Reference_Type; function Reference_Preserving_Key diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index 71f65dfea6b..99659abc795 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -378,6 +378,52 @@ package body Ada.Containers.Bounded_Vectors is Container.Last := No_Index; end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + + declare + A : Elements_Array renames Container.Elements; + I : constant Count_Type := To_Array_Index (Position.Index); + begin + return (Element => A (I)'Access); + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + A : Elements_Array renames Container.Elements; + I : constant Count_Type := To_Array_Index (Index); + begin + return (Element => A (I)'Access); + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -2071,76 +2117,46 @@ package body Ada.Containers.Bounded_Vectors is -- Reference -- --------------- - function Constant_Reference - (Container : Vector; - Position : Cursor) -- SHOULD BE ALIASED - return Constant_Reference_Type + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type is begin - pragma Unreferenced (Container); - if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - return - (Element => - Position.Container.Elements - (To_Array_Index (Position.Index))'Access); - end Constant_Reference; - - function Constant_Reference - (Container : Vector; - Position : Index_Type) - return Constant_Reference_Type - is - begin - if (Position) > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - return (Element => - Container.Elements (To_Array_Index (Position))'Access); - end Constant_Reference; - - function Reference - (Container : Vector; - Position : Cursor) - return Reference_Type - is - begin - pragma Unreferenced (Container); - - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; end if; if Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; - return - (Element => - Position.Container.Elements - (To_Array_Index (Position.Index))'Access); + declare + A : Elements_Array renames Container.Elements; + I : constant Count_Type := To_Array_Index (Position.Index); + begin + return (Element => A (I)'Access); + end; end Reference; function Reference - (Container : Vector; - Position : Index_Type) - return Reference_Type + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type is begin - if Position > Container.Last then + if Index > Container.Last then raise Constraint_Error with "Index is out of range"; - else - return (Element => - Container.Elements (To_Array_Index (Position))'Unrestricted_Access); end if; + + declare + A : Elements_Array renames Container.Elements; + I : constant Count_Type := To_Array_Index (Index); + begin + return (Element => A (I)'Access); + end; end Reference; --------------------- diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads index 7c009c0352c..6bcb0a40715 100644 --- a/gcc/ada/a-cobove.ads +++ b/gcc/ada/a-cobove.ads @@ -142,6 +142,56 @@ package Ada.Containers.Bounded_Vectors is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type; + procedure Assign (Target : in out Vector; Source : Vector); function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; @@ -308,54 +358,6 @@ package Ada.Containers.Bounded_Vectors is Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - function Constant_Reference - (Container : Vector; Position : Cursor) -- SHOULD BE ALIASED - return Constant_Reference_Type; - - function Constant_Reference - (Container : Vector; Position : Index_Type) - return Constant_Reference_Type; - - function Reference (Container : Vector; Position : Cursor) - return Reference_Type; - - function Reference (Container : Vector; Position : Index_Type) - return Reference_Type; - generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 2bc2ca956f9..8adcb1af35a 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -188,6 +188,46 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Clear (Container.HT); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert + (Vet (Position), + "Position cursor in Constant_Reference is bad"); + + return (Element => Position.Node.Element'Access); + end Constant_Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + return (Element => Node.Element'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -861,38 +901,40 @@ package body Ada.Containers.Hashed_Maps is -- Reference -- --------------- - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type - is - pragma Unreferenced (Container); - begin - return (Element => Element (Position)'Unrestricted_Access); - end Constant_Reference; - function Reference (Container : aliased in out Map; Position : Cursor) return Reference_Type is - pragma Unreferenced (Container); begin - return (Element => Element (Position)'Unrestricted_Access); - end Reference; + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type - is - begin - return (Element => Container.Element (Key)'Unrestricted_Access); - end Constant_Reference; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert + (Vet (Position), + "Position cursor in function Reference is bad"); + + return (Element => Position.Node.Element'Access); + end Reference; function Reference (Container : aliased in out Map; Key : Key_Type) return Reference_Type is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + begin - return (Element => Container.Element (Key)'Unrestricted_Access); + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + return (Element => Node.Element'Access); end Reference; --------------- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 93c3504e8d5..a5b2ff3e1d7 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -148,6 +148,55 @@ package Ada.Containers.Hashed_Maps is -- Calls Process with the key (with only a constant view) and element (with -- a variable view) of the node designed by the cursor. + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + procedure Assign (Target : in out Map; Source : Map); function Copy (Source : Map; Capacity : Count_Type := 0) return Map; @@ -277,55 +326,6 @@ package Ada.Containers.Hashed_Maps is -- Returns the result of calling Equivalent_Keys with key Left and the node -- designated by Right. - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type; - procedure Iterate (Container : Map; Process : not null access procedure (Position : Cursor)); @@ -354,7 +354,7 @@ private type Node_Type is limited record Key : Key_Type; - Element : Element_Type; + Element : aliased Element_Type; Next : Node_Access; end record; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index cf3354270d7..dd09da5a17c 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -198,6 +198,29 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Clear (Container.HT); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + return (Element => Position.Node.Element'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1126,19 +1149,6 @@ package body Ada.Containers.Hashed_Sets is raise; end Read_Node; - --------------- - -- Reference -- - --------------- - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - pragma Unreferenced (Container); - begin - return (Element => Position.Node.Element'Unrestricted_Access); - end Constant_Reference; - ------------- -- Replace -- ------------- @@ -1720,6 +1730,25 @@ package body Ada.Containers.Hashed_Sets is Hash => Hash, Equivalent_Keys => Equivalent_Key_Node); + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := + Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + return (Element => Node.Element'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1831,6 +1860,66 @@ package body Ada.Containers.Hashed_Sets is return Key (Position.Node.Element); end Key; + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Position), + "bad cursor in function Reference_Preserving_Key"); + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Position has + -- not changed. ??? + + return (Element => Position.Node.Element'Access); + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := + Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Key has not + -- changed. ??? + + return (Element => Node.Element'Access); + end Reference_Preserving_Key; + ------------- -- Replace -- ------------- @@ -1952,27 +2041,18 @@ package body Ada.Containers.Hashed_Sets is raise Program_Error with "key was modified"; end Update_Element_Preserving_Key; - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ + ----------- + -- Write -- + ----------- - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) is - pragma Unreferenced (Container); begin - return (Element => Position.Node.Element'Unrestricted_Access); - end Reference_Preserving_Key; + raise Program_Error with "attempt to stream reference"; + end Write; - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Position : constant Cursor := Find (Container, Key); - begin - return (Element => Position.Node.Element'Unrestricted_Access); - end Reference_Preserving_Key; end Generic_Keys; end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index b31001c90f3..97b209d280d 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -52,7 +52,7 @@ package Ada.Containers.Hashed_Sets is type Set is tagged private with - constant_Indexing => Constant_Reference, + Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, Iterator_Element => Element_Type; @@ -145,10 +145,6 @@ package Ada.Containers.Hashed_Sets is -- Calls Process with the element (having only a constant view) of the node -- designed by the cursor. - procedure Assign (Target : in out Set; Source : Set); - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set; - type Constant_Reference_Type (Element : not null access constant Element_Type) is private with Implicit_Dereference => Element; @@ -157,6 +153,10 @@ package Ada.Containers.Hashed_Sets is (Container : aliased Set; Position : Cursor) return Constant_Reference_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); -- Clears Target (if it's not empty), and then moves (not copies) the -- buckets array and nodes from Source to Target. @@ -422,14 +422,32 @@ package Ada.Containers.Hashed_Sets is (Container : aliased in out Set; Position : Cursor) return Reference_Type; + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + function Reference_Preserving_Key (Container : aliased in out Set; - Key : Key_Type) return Reference_Type; + Key : Key_Type) return Reference_Type; private type Reference_Type (Element : not null access Element_Type) is null record; + use Ada.Streams; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + end Generic_Keys; private @@ -439,7 +457,7 @@ private type Node_Access is access Node_Type; type Node_Type is limited record - Element : Element_Type; + Element : aliased Element_Type; Next : Node_Access; end record; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index b845e6fc7ff..92c08749d9a 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -673,34 +673,51 @@ package body Ada.Containers.Indefinite_Vectors is ------------------------ function Constant_Reference - (Container : Vector; + (Container : aliased Vector; Position : Cursor) return Constant_Reference_Type is - begin - pragma Unreferenced (Container); + E : Element_Access; + begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + if Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; - return - (Element => Position.Container.Elements.EA (Position.Index).all'Access); + E := Container.Elements.EA (Position.Index); + + if E = null then + raise Constraint_Error with "element at Position is empty"; + end if; + + return (Element => E.all'Access); end Constant_Reference; function Constant_Reference - (Container : Vector; - Position : Index_Type) return Constant_Reference_Type + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type is + E : Element_Access; + begin - if (Position) > Container.Last then + if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - return (Element => Container.Elements.EA (Position).all'Access); + E := Container.Elements.EA (Index); + + if E = null then + raise Constraint_Error with "element at Index is empty"; + end if; + + return (Element => E.all'Access); end Constant_Reference; -------------- @@ -2998,35 +3015,51 @@ package body Ada.Containers.Indefinite_Vectors is --------------- function Reference - (Container : Vector; + (Container : aliased in out Vector; Position : Cursor) return Reference_Type is - begin - pragma Unreferenced (Container); + E : Element_Access; + begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + if Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; - return - (Element => - Position.Container.Elements.EA (Position.Index).all'Access); + E := Container.Elements.EA (Position.Index); + + if E = null then + raise Constraint_Error with "element at Position is empty"; + end if; + + return (Element => E.all'Access); end Reference; function Reference - (Container : Vector; - Position : Index_Type) return Reference_Type + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type is + E : Element_Access; + begin - if Position > Container.Last then + if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - return (Element => Container.Elements.EA (Position).all'Access); + E := Container.Elements.EA (Index); + + if E = null then + raise Constraint_Error with "element at Index is empty"; + end if; + + return (Element => E.all'Access); end Reference; --------------------- diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index 85d68ebf7ee..8f55d81ed65 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -150,18 +150,20 @@ package Ada.Containers.Indefinite_Vectors is for Reference_Type'Read use Read; function Constant_Reference - (Container : Vector; Position : Cursor) -- SHOULD BE ALIASED - return Constant_Reference_Type; + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type; - function Constant_Reference - (Container : Vector; Position : Index_Type) - return Constant_Reference_Type; + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type; - function Reference (Container : Vector; Position : Cursor) - return Reference_Type; + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type; - function Reference (Container : Vector; Position : Index_Type) - return Reference_Type; + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type; function To_Cursor (Container : Vector; diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index 3d6794a74f5..a923871b148 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -437,6 +437,36 @@ package body Ada.Containers.Multiway_Trees is pragma Assert (Children_Count = Container_Count); end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + return (Element => Position.Node.Element'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -2000,24 +2030,30 @@ package body Ada.Containers.Multiway_Trees is -- Reference -- --------------- - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type - is - begin - pragma Unreferenced (Container); - - return (Element => Position.Node.Element'Unrestricted_Access); - end Constant_Reference; - function Reference - (Container : aliased Tree; + (Container : aliased in out Tree; Position : Cursor) return Reference_Type is begin - pragma Unreferenced (Container); + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element'Unrestricted_Access); + return (Element => Position.Node.Element'Access); end Reference; -------------------- diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads index 37e2eda0c2c..20a91bb9a13 100644 --- a/gcc/ada/a-comutr.ads +++ b/gcc/ada/a-comutr.ads @@ -108,6 +108,14 @@ package Ada.Containers.Multiway_Trees is (Element : not null access Element_Type) is private with Implicit_Dereference => Element; + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type; + procedure Assign (Target : in out Tree; Source : Tree); function Copy (Source : Tree) return Tree; @@ -341,7 +349,7 @@ private Prev : Tree_Node_Access; Next : Tree_Node_Access; Children : Children_Type; - Element : Element_Type; + Element : aliased Element_Type; end record; pragma Convention (C, Tree_Node_Type); @@ -445,14 +453,6 @@ private for Reference_Type'Write use Write; - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased Tree; - Position : Cursor) return Reference_Type; - Empty_Tree : constant Tree := (Controlled with others => <>); No_Element : constant Cursor := (others => <>); diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index f80dd3b29c0..2e3523514e4 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -478,6 +478,42 @@ package body Ada.Containers.Vectors is end if; end Clear; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + + return (Element => Container.Elements.EA (Position.Index)'Access); + end Constant_Reference; + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + else + return (Element => Container.Elements.EA (Index)'Access); + end if; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -2538,64 +2574,35 @@ package body Ada.Containers.Vectors is -- Reference -- --------------- - function Constant_Reference - (Container : Vector; - Position : Cursor) -- SHOULD BE ALIASED - return Constant_Reference_Type + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type is begin - pragma Unreferenced (Container); - if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - return - (Element => - Position.Container.Elements.EA (Position.Index)'Access); - end Constant_Reference; - - function Constant_Reference - (Container : Vector; - Position : Index_Type) - return Constant_Reference_Type - is - begin - if Position > Container.Last then - raise Constraint_Error with "Index is out of range"; - else - return (Element => Container.Elements.EA (Position)'Access); - end if; - end Constant_Reference; - - function Reference (Container : Vector; Position : Cursor) - return Reference_Type is - begin - pragma Unreferenced (Container); - - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; end if; if Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; - return - (Element => Position.Container.Elements.EA (Position.Index)'Access); + return (Element => Container.Elements.EA (Position.Index)'Access); end Reference; - function Reference (Container : Vector; Position : Index_Type) - return Reference_Type is + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type + is begin - if Position > Container.Last then + if Index > Container.Last then raise Constraint_Error with "Index is out of range"; else - return (Element => Container.Elements.EA (Position)'Access); + return (Element => Container.Elements.EA (Index)'Access); end if; end Reference; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 00f9b2abbac..babf94e9c45 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -189,18 +189,20 @@ package Ada.Containers.Vectors is for Reference_Type'Read use Read; function Constant_Reference - (Container : Vector; Position : Cursor) -- SHOULD BE ALIASED - return Constant_Reference_Type; + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type; - function Constant_Reference - (Container : Vector; Position : Index_Type) - return Constant_Reference_Type; + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type; - function Reference (Container : Vector; Position : Cursor) - return Reference_Type; + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type; - function Reference (Container : Vector; Position : Index_Type) - return Reference_Type; + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type; procedure Assign (Target : in out Vector; Source : Vector); diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index 41df493812d..c7153c5fcbb 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -323,11 +323,38 @@ package body Ada.Containers.Ordered_Maps is ------------------------ function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor in Constant_Reference is bad"); + + return (Element => Position.Node.Element'Access); + end Constant_Reference; + + function Constant_Reference (Container : Map; Key : Key_Type) return Constant_Reference_Type is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin - return (Element => Container.Element (Key)'Unrestricted_Access); + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + return (Element => Node.Element'Access); end Constant_Reference; -------------- @@ -1250,12 +1277,38 @@ package body Ada.Containers.Ordered_Maps is --------------- function Reference - (Container : Map; - Key : Key_Type) - return Reference_Type + (Container : aliased in out Map; + Position : Cursor) return Reference_Type is begin - return (Element => Container.Element (Key)'Unrestricted_Access); + if Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor in function Reference is bad"); + + return (Element => Position.Node.Element'Access); + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + return (Element => Node.Element'Access); end Reference; ------------- diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index 9d2737a5efb..a58a4f5a2a2 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -51,7 +51,7 @@ package Ada.Containers.Ordered_Maps is function Equivalent_Keys (Left, Right : Key_Type) return Boolean; type Map is tagged private with - constant_Indexing => Constant_Reference, + Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, Iterator_Element => Element_Type; @@ -96,6 +96,31 @@ package Ada.Containers.Ordered_Maps is Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + procedure Assign (Target : in out Map; Source : Map); function Copy (Source : Map) return Map; @@ -182,23 +207,6 @@ package Ada.Containers.Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : Map; - Key : Key_Type) -- SHOULD BE ALIASED??? - return Constant_Reference_Type; - - function Reference (Container : Map; Key : Key_Type) - return Reference_Type; - procedure Iterate (Container : Map; Process : not null access procedure (Position : Cursor)); @@ -234,7 +242,7 @@ private Right : Node_Access; Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; Key : Key_Type; - Element : Element_Type; + Element : aliased Element_Type; end record; package Tree_Types is diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index c8bf665ee17..41ebb5c0d71 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -331,6 +331,31 @@ package body Ada.Containers.Ordered_Sets is return Node.Color; end Color; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Container.Tree, Position.Node), + "bad cursor in Constant_Reference"); + + return (Element => Position.Node.Element'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -658,6 +683,25 @@ package body Ada.Containers.Ordered_Sets is else Cursor'(Container'Unrestricted_Access, Node)); end Ceiling; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in set"; + end if; + + return (Element => Node.Element'Access); + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -784,6 +828,66 @@ package body Ada.Containers.Ordered_Sets is return Key (Position.Node.Element); end Key; + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Container.Tree, Position.Node), + "bad cursor in function Reference_Preserving_Key"); + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Position has + -- not changed. ??? + + return (Element => Position.Node.Element'Access); + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in set"; + end if; + + -- Some form of finalization will be required in order to actually + -- check that the key-part of the element designated by Position has + -- not changed. ??? + + return (Element => Node.Element'Access); + end Reference_Preserving_Key; + ------------- -- Replace -- ------------- @@ -867,41 +971,9 @@ package body Ada.Containers.Ordered_Sets is raise Program_Error with "key was modified"; end Update_Element_Preserving_Key; - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Constant_Reference_Type - is - Position : constant Cursor := Find (Container, Key); - - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => Position.Node.Element'Access); - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Position : constant Cursor := Find (Container, Key); - - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => Position.Node.Element'Access); - end Reference_Preserving_Key; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; + ----------- + -- Write -- + ----------- procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -1536,22 +1608,6 @@ package body Ada.Containers.Ordered_Sets is raise Program_Error with "attempt to stream reference"; end Read; - --------------- - -- Reference -- - --------------- - - function Constant_Reference (Container : Set; Position : Cursor) - return Constant_Reference_Type - is - pragma Unreferenced (Container); - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => Position.Node.Element'Access); - end Constant_Reference; - ------------- -- Replace -- ------------- diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index 39f69f5eff0..cf28a7ccd1c 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -68,28 +68,6 @@ package Ada.Containers.Ordered_Sets is package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - function Constant_Reference - (Container : Set; Position : Cursor) - return Constant_Reference_Type; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - function "=" (Left, Right : Set) return Boolean; function Equivalent_Sets (Left, Right : Set) return Boolean; @@ -113,6 +91,28 @@ package Ada.Containers.Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + procedure Assign (Target : in out Set; Source : Set); function Copy (Source : Set) return Set; @@ -278,6 +278,10 @@ package Ada.Containers.Ordered_Sets is function Reference_Preserving_Key (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; Key : Key_Type) return Constant_Reference_Type; function Reference_Preserving_Key diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 21dc91634aa..dac30475e49 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -2977,8 +2977,15 @@ package body Prj.Nmsc is "library directory { does not exist", Lib_Dir.Location, Project); - elsif not Project.Externally_Built then + -- Checks for object/source directories + elsif not Project.Externally_Built + + -- An aggregate library does not have sources or objects, so + -- these tests are not required in this case. + + and then Project.Qualifier /= Aggregate_Library + then -- Library directory cannot be the same as Object directory if Project.Library_Dir.Name = Project.Object_Directory.Name then diff --git a/gcc/ada/s-gearop.adb b/gcc/ada/s-gearop.adb index a359f14dc28..db18a7ebec0 100644 --- a/gcc/ada/s-gearop.adb +++ b/gcc/ada/s-gearop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2012, 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- -- @@ -311,11 +311,23 @@ package body System.Generic_Array_Operations is if Max_Abs > 0.0 then Switch_Row (M, N, Row, Max_Row); - Divide_Row (M, N, Row, M (Row, J)); + + -- The temporaries below are necessary to force a copy of the + -- value and avoid improper aliasing. + + declare + Scale : constant Scalar := M (Row, J); + begin + Divide_Row (M, N, Row, Scale); + end; for U in Row + 1 .. M'Last (1) loop - Sub_Row (N, U, Row, M (U, J)); - Sub_Row (M, U, Row, M (U, J)); + declare + Factor : constant Scalar := M (U, J); + begin + Sub_Row (N, U, Row, Factor); + Sub_Row (M, U, Row, Factor); + end; end loop; exit when Row >= M'Last (1); diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 3599261498c..d0b83ae05f4 100755 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2012, 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- -- @@ -888,9 +888,10 @@ package System.OS_Lib is -- If the parent is using tasking, and needs to spawn subprocesses at -- arbitrary times, one technique is for the parent to spawn (very early) -- a particular spawn-manager subprocess whose job is to spawn other - -- processes. The spawn-manager avoids tasking. The parent sends messages - -- to the spawn-manager requesting it to spawn processes, using whatever - -- inter-process communication mechanism you like, such as sockets. + -- processes. The spawn-manager must avoid tasking. The parent sends + -- messages to the spawn-manager requesting it to spawn processes, using + -- whatever inter-process communication mechanism you like, such as + -- sockets. -- In short, mixing spawning of subprocesses with tasking is a tricky -- business, and should be avoided if possible, but if it is necessary, |