From b38c20a636ec4e92cdabecbfa487b742829ebe93 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 23 Nov 2011 14:32:44 +0100 Subject: [PATCH] [multiple changes] 2011-11-23 Matthew Heaney * a-coorse.ads, a-ciorse.ads, a-cborse.ads (Set_Iterator_Interfaces): Renamed from Ordered_Set_Iterator_Interfaces. * a-coorse.adb, a-ciorse.adb, a-cborse.adb (Iterator): Declared Iterator type as limited (First, Last): Cursor return value depends on iterator node value (Iterate): Use start position as iterator node value (Next, Previous): Forward to corresponding cursor-based operation. * a-cohase.ads, a-cohase.adb: Implemented forward iterator. * a-cihase.adb, a-cbhase.adb (Iterator): Removed unnecessary node component (First, Next): Forward call to corresponding cursor-based operation (Iterate): Representation of iterator no longer has node component 2011-11-23 Hristian Kirtchev * exp_intr.adb (Expand_Unc_Deallocation): Ensure that the dereference has a proper type before the side effect removal mechanism kicks in. * sem_ch3.adb (Analyze_Subtype_Declaration): Handle a rare case where the base type of the subtype is a private itype created to act as the partial view of a constrained record type. This scenario manifests with equivalent class-wide types for records with unknown discriminants. 2011-11-23 Jerome Guitton * s-osprim-vxworks.adb (Clock): Use Clock_RT_Ada. 2011-11-23 Thomas Quinot * s-oscons-tmplt.c: Fix unbalanced preprocessor directives Minor reformatting/reorganization. From-SVN: r181666 --- gcc/ada/ChangeLog | 35 ++++++ gcc/ada/a-cbhase.adb | 21 ++-- gcc/ada/a-cborse.adb | 124 +++++++++++++++++---- gcc/ada/a-cborse.ads | 8 +- gcc/ada/a-cihase.adb | 30 +++--- gcc/ada/a-ciorse.adb | 121 ++++++++++++++++++--- gcc/ada/a-ciorse.ads | 6 +- gcc/ada/a-cohase.adb | 42 +++++++- gcc/ada/a-cohase.ads | 19 +++- gcc/ada/a-coorse.adb | 124 +++++++++++++++++---- gcc/ada/a-coorse.ads | 6 +- gcc/ada/exp_intr.adb | 4 + gcc/ada/s-oscons-tmplt.c | 201 ++++++++++++++++++----------------- gcc/ada/s-osprim-vxworks.adb | 7 +- gcc/ada/sem_ch3.adb | 13 +++ 15 files changed, 563 insertions(+), 198 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e68a478b9d1..42021e58a20 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2011-11-23 Matthew Heaney + + * a-coorse.ads, a-ciorse.ads, a-cborse.ads (Set_Iterator_Interfaces): + Renamed from Ordered_Set_Iterator_Interfaces. + * a-coorse.adb, a-ciorse.adb, a-cborse.adb (Iterator): Declared + Iterator type as limited (First, Last): Cursor return value + depends on iterator node value (Iterate): Use start position as + iterator node value (Next, Previous): Forward to corresponding + cursor-based operation. + * a-cohase.ads, a-cohase.adb: Implemented forward iterator. + * a-cihase.adb, a-cbhase.adb (Iterator): Removed unnecessary + node component (First, Next): Forward call to corresponding + cursor-based operation (Iterate): Representation of iterator no + longer has node component + +2011-11-23 Hristian Kirtchev + + * exp_intr.adb (Expand_Unc_Deallocation): Ensure that the + dereference has a proper type before the side effect removal + mechanism kicks in. + * sem_ch3.adb (Analyze_Subtype_Declaration): Handle a rare case + where the base type of the subtype is a private itype created + to act as the partial view of a constrained record type. This + scenario manifests with equivalent class-wide types for records + with unknown discriminants. + +2011-11-23 Jerome Guitton + + * s-osprim-vxworks.adb (Clock): Use Clock_RT_Ada. + +2011-11-23 Thomas Quinot + + * s-oscons-tmplt.c: Fix unbalanced preprocessor directives Minor + reformatting/reorganization. + 2011-11-23 Thomas Quinot * g-htable.ads: Remove old comments. diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 97a765a6839..1de29ab1a7e 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -41,7 +41,6 @@ package body Ada.Containers.Bounded_Hashed_Sets is type Iterator is new Set_Iterator_Interfaces.Forward_Iterator with record Container : Set_Access; - Position : Cursor; end record; overriding function First (Object : Iterator) return Cursor; @@ -596,10 +595,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is end First; overriding function First (Object : Iterator) return Cursor is - Node : constant Count_Type := HT_Ops.First (Object.Container.all); begin - return (if Node = 0 then No_Element - else Cursor'(Object.Container, Node)); + return Object.Container.First; end First; ----------------- @@ -911,7 +908,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class is begin - return Iterator'(Container'Unrestricted_Access, First (Container)); + return Iterator'(Container => Container'Unrestricted_Access); end Iterate; ------------ @@ -982,12 +979,16 @@ package body Ada.Containers.Bounded_Hashed_Sets is Position : Cursor) return Cursor is begin - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor designates wrong set"; + if Position.Container = null then + return No_Element; end if; - return (if Position.Node = 0 then No_Element else Next (Position)); + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); end Next; ------------- @@ -1599,7 +1600,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin if Node = 0 then - raise Constraint_Error with "key not in map"; + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Container.Nodes (Node).Element; diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index 674d2abee33..62ab5f21470 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -42,9 +42,9 @@ with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Sets is - type Iterator is new - Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record - Container : access constant Set; + type Iterator is limited new + Set_Iterator_Interfaces.Reversible_Iterator with record + Container : Set_Access; Node : Count_Type; end record; @@ -591,9 +591,24 @@ package body Ada.Containers.Bounded_Ordered_Sets is function First (Object : Iterator) return Cursor is begin - return (if Object.Container.First = 0 then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.First)); + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Sets.First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; end First; ------------------- @@ -1206,22 +1221,60 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Iterate; function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'Class is begin - if Container.Length = 0 then - return Iterator'(null, 0); - else - return Iterator'(Container'Unchecked_Access, Container.First); - end if; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is 0 (as is the case here), this means the iterator object + -- was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return Iterator'(Container'Unrestricted_Access, Node => 0); end Iterate; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Start.Node); begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is positive (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. (Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration.) + + return Iterator'(Container'Unrestricted_Access, Node => Start.Node); end Iterate; ---------- @@ -1236,9 +1289,24 @@ package body Ada.Containers.Bounded_Ordered_Sets is function Last (Object : Iterator) return Cursor is begin - return (if Object.Container.Last = 0 then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.Last)); + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Sets.Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; end Last; ------------------ @@ -1323,8 +1391,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + return Next (Position); end Next; @@ -1374,8 +1450,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + return Previous (Position); end Previous; diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads index 0c8ae6b1703..9c4fdb4f31d 100644 --- a/gcc/ada/a-cborse.ads +++ b/gcc/ada/a-cborse.ads @@ -31,9 +31,9 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with Ada.Iterator_Interfaces; private with Ada.Containers.Red_Black_Trees; with Ada.Streams; use Ada.Streams; +with Ada.Iterator_Interfaces; generic type Element_Type is private; @@ -62,7 +62,7 @@ package Ada.Containers.Bounded_Ordered_Sets is No_Element : constant Cursor; function Has_Element (Position : Cursor) return Boolean; - package Ordered_Set_Iterator_Interfaces is new + package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); type Constant_Reference_Type @@ -212,12 +212,12 @@ package Ada.Containers.Bounded_Ordered_Sets is function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; generic type Key_Type (<>) is private; diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index e29a204570e..22c5890cea6 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -41,10 +41,10 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Sets is - type Iterator is new Set_Iterator_Interfaces.Forward_Iterator with record - Container : Set_Access; - Position : Cursor; - end record; + type Iterator is limited new + Set_Iterator_Interfaces.Forward_Iterator with record + Container : Set_Access; + end record; overriding function First (Object : Iterator) return Cursor; @@ -649,10 +649,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end First; function First (Object : Iterator) return Cursor is - Node : constant Node_Access := HT_Ops.First (Object.Container.HT); begin - return (if Node = null then No_Element - else Cursor'(Object.Container, Node)); + return Object.Container.First; end First; ---------- @@ -1011,7 +1009,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class is begin - return Iterator'(Container'Unrestricted_Access, First (Container)); + return Iterator'(Container => Container'Unrestricted_Access); end Iterate; ------------ @@ -1072,12 +1070,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : Cursor) return Cursor is begin - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor designates wrong set"; + if Position.Container = null then + return No_Element; end if; - return (if Position.Node = null then No_Element else Next (Position)); + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); end Next; ------------- @@ -1895,7 +1897,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then - raise Constraint_Error with "key not in map"; + raise Constraint_Error with "key not in map"; -- ??? "set" end if; Free (X); @@ -1913,7 +1915,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if Node = null then - raise Constraint_Error with "key not in map"; + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Node.Element.all; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 56c33cfe670..0d3af93f6d8 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -42,9 +42,9 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Sets is - type Iterator is new - Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record - Container : access constant Set; + type Iterator is limited new + Set_Iterator_Interfaces.Reversible_Iterator with record + Container : Set_Access; Node : Node_Access; end record; @@ -600,8 +600,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function First (Object : Iterator) return Cursor is begin - return Cursor'( - Object.Container.all'Unrestricted_Access, Object.Container.Tree.First); + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; end First; ------------------- @@ -1259,22 +1275,62 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := - (Container'Unchecked_Access, Container.Tree.First); begin - return It; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return Iterator'(Container'Unrestricted_Access, Node => null); end Iterate; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Start.Node); begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return Iterator'(Container'Unrestricted_Access, Node => Start.Node); end Iterate; ---------- @@ -1290,9 +1346,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Last (Object : Iterator) return Cursor is begin - return (if Object.Container.Tree.Last = null then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.Tree.Last)); + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; end Last; ------------------ @@ -1372,8 +1443,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + return Next (Position); end Next; @@ -1430,8 +1509,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + return Previous (Position); end Previous; diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index c0ead018bb2..ac711246542 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -64,7 +64,7 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Has_Element (Position : Cursor) return Boolean; - package Ordered_Set_Iterator_Interfaces is new + package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); type Constant_Reference_Type @@ -233,12 +233,12 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; generic type Key_Type (<>) is private; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index e0b2345234b..fadff195ff5 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -41,6 +41,17 @@ with System; use type System.Address; package body Ada.Containers.Hashed_Sets is + type Iterator is limited new + Set_Iterator_Interfaces.Forward_Iterator with record + Container : Set_Access; + end record; + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + ----------------------- -- Local Subprograms -- ----------------------- @@ -601,6 +612,11 @@ package body Ada.Containers.Hashed_Sets is return Cursor'(Container'Unrestricted_Access, Node); end First; + function First (Object : Iterator) return Cursor is + begin + return Object.Container.First; + end First; + ---------- -- Free -- ---------- @@ -920,6 +936,13 @@ package body Ada.Containers.Hashed_Sets is B := B - 1; end Iterate; + function Iterate + (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return Iterator'(Container => Container'Unrestricted_Access); + end Iterate; + ------------ -- Length -- ------------ @@ -973,6 +996,23 @@ package body Ada.Containers.Hashed_Sets is Position := Next (Position); end Next; + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + ------------- -- Overlap -- ------------- @@ -1695,7 +1735,7 @@ package body Ada.Containers.Hashed_Sets is begin if Node = null then - raise Constraint_Error with "key not in map"; + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Node.Element; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 0bb370bfe83..96944cd2b2f 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -34,6 +34,7 @@ private with Ada.Containers.Hash_Tables; private with Ada.Streams; private with Ada.Finalization; +with Ada.Iterator_Interfaces; generic type Element_Type is private; @@ -49,7 +50,11 @@ package Ada.Containers.Hashed_Sets is pragma Preelaborate; pragma Remote_Types; - type Set is tagged private; + type Set is tagged private + with + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (Set); type Cursor is private; @@ -63,6 +68,12 @@ package Ada.Containers.Hashed_Sets is -- Cursor objects declared without an initialization expression are -- initialized to the value No_Element. + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + function "=" (Left, Right : Set) return Boolean; -- For each element in Left, set equality attempts to find the equal -- element in Right; if a search fails, then set equality immediately @@ -303,9 +314,6 @@ package Ada.Containers.Hashed_Sets is function Contains (Container : Set; Item : Element_Type) return Boolean; -- Equivalent to Find (Container, Item) /= No_Element - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - function Equivalent_Elements (Left, Right : Cursor) return Boolean; -- Returns the result of calling Equivalent_Elements with the elements of -- the nodes designated by cursors Left and Right. @@ -327,6 +335,9 @@ package Ada.Containers.Hashed_Sets is Process : not null access procedure (Position : Cursor)); -- Calls Process for each node in the set + function Iterate + (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class; + generic type Key_Type (<>) is private; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 4c6476864b8..ce004e2d737 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -42,9 +42,9 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Sets is - type Iterator is new - Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record - Container : access constant Set; + type Iterator is limited new + Set_Iterator_Interfaces.Reversible_Iterator with record + Container : Set_Access; Node : Node_Access; end record; @@ -537,9 +537,24 @@ package body Ada.Containers.Ordered_Sets is function First (Object : Iterator) return Cursor is begin - return (if Object.Container = null then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.Tree.First)); + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; end First; ------------------- @@ -1165,22 +1180,60 @@ package body Ada.Containers.Ordered_Sets is end Iterate; function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'Class is begin - if Container.Length = 0 then - return Iterator'(null, null); - else - return Iterator'(Container'Unchecked_Access, Container.Tree.First); - end if; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return Iterator'(Container'Unrestricted_Access, Node => null); end Iterate; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Start.Node); begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return Iterator'(Container'Unrestricted_Access, Node => Start.Node); end Iterate; ---------- @@ -1196,9 +1249,24 @@ package body Ada.Containers.Ordered_Sets is function Last (Object : Iterator) return Cursor is begin - return (if Object.Container = null then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.Tree.Last)); + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; end Last; ------------------ @@ -1271,8 +1339,16 @@ package body Ada.Containers.Ordered_Sets is end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + return Next (Position); end Next; @@ -1322,8 +1398,16 @@ package body Ada.Containers.Ordered_Sets is end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + return Previous (Position); end Previous; diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index 45e6ab90a73..39f69f5eff0 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -65,7 +65,7 @@ package Ada.Containers.Ordered_Sets is No_Element : constant Cursor; - package Ordered_Set_Iterator_Interfaces is new + package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); type Constant_Reference_Type @@ -227,12 +227,12 @@ package Ada.Containers.Ordered_Sets is function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; generic type Key_Type (<>) is private; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index ce7c0dcc979..b116a8a28f0 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -1123,6 +1123,10 @@ package body Exp_Intr is D_Type : Entity_Id; begin + -- Perform minor decoration as it is needed by the side effect + -- removal mechanism. + + Set_Etype (Deref, Desig_T); Set_Parent (Deref, Free_Node); D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index d8a6477c441..2bab2b93049 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -146,7 +146,7 @@ pragma Style_Checks ("M32766"); # define NATIVE -#endif +#endif /* DUMMY */ #ifndef TARGET # error Please define TARGET @@ -213,7 +213,7 @@ int counter = 0; : : "i" (__LINE__)); /* Freeform text */ -#endif +#endif /* NATIVE */ #define CST(name,comment) C(#name,String,name,comment) @@ -1208,55 +1208,6 @@ CND(IP_DROP_MEMBERSHIP, "Leave a multicast group") #endif CND(IP_PKTINFO, "Get datagram info") -#endif /* HAVE_SOCKETS */ - -/* - - ------------ - -- Clocks -- - ------------ - -*/ - -#ifdef CLOCK_REALTIME -CND(CLOCK_REALTIME, "System realtime clock") -#endif - -#ifdef CLOCK_MONOTONIC -CND(CLOCK_MONOTONIC, "System monotonic clock") -#endif - -#ifdef CLOCK_FASTEST -CND(CLOCK_FASTEST, "Fastest clock") -#endif - -#if defined (__sgi) -CND(CLOCK_SGI_FAST, "SGI fast clock") -CND(CLOCK_SGI_CYCLE, "SGI CPU clock") -#endif - -#if defined(__APPLE__) -/* There's no clock_gettime or clock_id's on Darwin */ -# define CLOCK_RT_Ada "-1" - -#elif defined(FreeBSD) || defined(_AIX) -/* On these platforms use system provided monotonic clock */ -# define CLOCK_RT_Ada "CLOCK_MONOTONIC" - -#elif defined(CLOCK_REALTIME) -/* By default use CLOCK_REALTIME */ -# define CLOCK_RT_Ada "CLOCK_REALTIME" -#endif - -#ifdef CLOCK_RT_Ada -CNS(CLOCK_RT_Ada, "Ada realtime clock") -#endif - -#ifndef CLOCK_THREAD_CPUTIME_ID -# define CLOCK_THREAD_CPUTIME_ID -1 -#endif -CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") - /* ---------------------- @@ -1367,58 +1318,67 @@ CST(Inet_Pton_Linkname, "") #endif /* HAVE_SOCKETS */ -/** - ** System-specific constants follow - ** Each section should be activated if compiling for the corresponding - ** platform *or* generating the dummy version for runtime test compilation. - **/ - -#if defined (__vxworks) || defined (DUMMY) - /* - -------------------------------- - -- VxWorks-specific constants -- - -------------------------------- + --------------------- + -- Threads support -- + --------------------- + + -- Clock identifier definitions - -- These constants may be used only within the VxWorks version of - -- GNAT.Sockets.Thin. */ -CND(OK, "VxWorks generic success") -CND(ERROR, "VxWorks generic error") - +#ifdef CLOCK_REALTIME +CND(CLOCK_REALTIME, "System realtime clock") #endif -#if defined (__MINGW32__) || defined (DUMMY) -/* - - ------------------------------ - -- MinGW-specific constants -- - ------------------------------ - - -- These constants may be used only within the MinGW version of - -- GNAT.Sockets.Thin. -*/ - -CND(WSASYSNOTREADY, "System not ready") -CND(WSAVERNOTSUPPORTED, "Version not supported") -CND(WSANOTINITIALISED, "Winsock not initialized") -CND(WSAEDISCON, "Disconnected") - +#ifdef CLOCK_MONOTONIC +CND(CLOCK_MONOTONIC, "System monotonic clock") #endif -#ifdef NATIVE - putchar ('\n'); +#ifdef CLOCK_FASTEST +CND(CLOCK_FASTEST, "Fastest clock") #endif +#if defined (__sgi) +CND(CLOCK_SGI_FAST, "SGI fast clock") +CND(CLOCK_SGI_CYCLE, "SGI CPU clock") +#endif + +#if defined(__APPLE__) +/* There's no clock_gettime or clock_id's on Darwin */ +# define CLOCK_RT_Ada "-1" + +#elif defined(FreeBSD) || defined(_AIX) +/* On these platforms use system provided monotonic clock */ +# define CLOCK_RT_Ada "CLOCK_MONOTONIC" + +#elif defined(CLOCK_REALTIME) +/* By default use CLOCK_REALTIME */ +# define CLOCK_RT_Ada "CLOCK_REALTIME" +#endif + +#ifdef CLOCK_RT_Ada +CNS(CLOCK_RT_Ada, "") +#endif + +#ifndef CLOCK_THREAD_CPUTIME_ID +# define CLOCK_THREAD_CPUTIME_ID -1 +#endif +CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") + #if defined (__APPLE__) || defined (__linux__) || defined (DUMMY) /* - -- Sizes of pthread data types (on Darwin these are padding) + -- Sizes of pthread data types + */ #if defined (__APPLE__) || defined (DUMMY) +/* + -- (on Darwin, these are just placeholders) + +*/ #define PTHREAD_SIZE __PTHREAD_SIZE__ #define PTHREAD_ATTR_SIZE __PTHREAD_ATTR_SIZE__ #define PTHREAD_MUTEXATTR_SIZE __PTHREAD_MUTEXATTR_SIZE__ @@ -1440,24 +1400,65 @@ CND(WSAEDISCON, "Disconnected") #define PTHREAD_ONCE_SIZE (sizeof (pthread_once_t)) #endif -CND(PTHREAD_SIZE, "pthread_t") - -CND(PTHREAD_ATTR_SIZE, "pthread_attr_t") - -CND(PTHREAD_MUTEXATTR_SIZE, "pthread_mutexattr_t") - -CND(PTHREAD_MUTEX_SIZE, "pthread_mutex_t") - -CND(PTHREAD_CONDATTR_SIZE, "pthread_condattr_t") - -CND(PTHREAD_COND_SIZE, "pthread_cond_t") - +CND(PTHREAD_SIZE, "pthread_t") +CND(PTHREAD_ATTR_SIZE, "pthread_attr_t") +CND(PTHREAD_MUTEXATTR_SIZE, "pthread_mutexattr_t") +CND(PTHREAD_MUTEX_SIZE, "pthread_mutex_t") +CND(PTHREAD_CONDATTR_SIZE, "pthread_condattr_t") +CND(PTHREAD_COND_SIZE, "pthread_cond_t") CND(PTHREAD_RWLOCKATTR_SIZE, "pthread_rwlockattr_t") +CND(PTHREAD_RWLOCK_SIZE, "pthread_rwlock_t") +CND(PTHREAD_ONCE_SIZE, "pthread_once_t") -CND(PTHREAD_RWLOCK_SIZE, "pthread_rwlock_t") +#endif /* __APPLE__ || __linux__ */ -CND(PTHREAD_ONCE_SIZE, "pthread_once_t") +/** + ** System-specific constants follow + ** Each section should be activated if compiling for the corresponding + ** platform *or* generating the dummy version for runtime test compilation. + **/ +#if defined (__vxworks) || defined (DUMMY) + +/* + + -------------------------------- + -- VxWorks-specific constants -- + -------------------------------- + + -- These constants may be used only within the VxWorks version of + -- GNAT.Sockets.Thin. +*/ + +CND(OK, "VxWorks generic success") +CND(ERROR, "VxWorks generic error") + +#endif /* __vxworks */ + +#if defined (__MINGW32__) || defined (DUMMY) +/* + + ------------------------------ + -- MinGW-specific constants -- + ------------------------------ + + -- These constants may be used only within the MinGW version of + -- GNAT.Sockets.Thin. +*/ + +CND(WSASYSNOTREADY, "System not ready") +CND(WSAVERNOTSUPPORTED, "Version not supported") +CND(WSANOTINITIALISED, "Winsock not initialized") +CND(WSAEDISCON, "Disconnected") + +#endif /* __MINGW32__ */ + +/** + ** End of constants definitions + **/ + +#ifdef NATIVE + putchar ('\n'); #endif /* diff --git a/gcc/ada/s-osprim-vxworks.adb b/gcc/ada/s-osprim-vxworks.adb index f75850af026..1eccae5612a 100644 --- a/gcc/ada/s-osprim-vxworks.adb +++ b/gcc/ada/s-osprim-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -37,6 +37,7 @@ with System.OS_Interface; -- set of C imported routines: using Ada routines from this package would -- create a dependency on libgnarl in libgnat, which is not desirable. +with System.OS_Constants; with Interfaces.C; package body System.OS_Primitives is @@ -44,6 +45,8 @@ package body System.OS_Primitives is use System.OS_Interface; use type Interfaces.C.int; + package OSC renames System.OS_Constants; + ------------------------ -- Internal functions -- ------------------------ @@ -94,7 +97,7 @@ package body System.OS_Primitives is TS : aliased timespec; Result : int; begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); pragma Assert (Result = 0); return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; end Clock; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 92e1b9da994..16bfbeb539a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4064,6 +4064,19 @@ package body Sem_Ch3 is T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); + -- Class-wide equivalent types of records with unknown discriminants + -- involve the generation of an itype which serves as the private view + -- of a constrained record subtype. In such cases the base type of the + -- current subtype we are processing is the private itype. Use the full + -- of the private itype when decorating various attributes. + + if Is_Itype (T) + and then Is_Private_Type (T) + and then Present (Full_View (T)) + then + T := Full_View (T); + end if; + -- Inherit common attributes Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));