+2011-11-23 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Freeze_All_Ent): An incomplete type is not
+ frozen by a subprogram body that does not come from source.
+
+2011-11-23 Pascal Obry <obry@adacore.com>
+
+ * s-oscons-tmplt.c: Add PTY_Library constant. It contains
+ the library for pseudo terminal support.
+ * g-exptty.ads: Add pseudo-terminal library into a Linker_Options
+ pragma.
+
+2011-11-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch9.adb: No check on entry family index if generic.
+
+2011-11-23 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch9.adb, s-taprop.ads, s-taprop-hpux-dce.adb, s-taprop-irix.adb,
+ s-taprop-posix.adb, s-taprop-rtx.adb, s-taprop-solaris.adb,
+ s-taprop-tru64.adb, s-taprop-vxworks.adb: Move dependency on
+ System.OS_Constants from shared spec of
+ System.Tasking.Primitive_Operations to the specific body variants
+ that really require this dependency.
+
+2011-11-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Analyze_Subprogram_Renaming_Declaration):
+ If the declaration has aspects, analyze them so they can be
+ properly rejected.
+
+2011-11-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * a-comutr.adb, a-coorma.adb, a-coorse.adb, a-convec.adb, a-cihase.adb,
+ a-cimutr.adb, a-coinve.adb, a-ciorma.adb, a-ciorse.adb, a-cobove.adb,
+ a-cohama.adb, a-cihama.adb, a-cidlli.adb, a-cdlili.adb, a-cbhama.adb,
+ a-cbhase.adb, a-cbmutr.adb, a-cborma.adb, a-cborse.adb, a-cbdlli.adb:
+ Add with and use clause for Ada.Finalization. Type
+ Iterator and Child_Iterator are now derived from Limited_Controlled.
+ (Finalize): New routine.
+ (Iterate): Add a renaming of counter Busy and
+ increment it. Update the return aggregate.
+ (Iterate_Children): Add a renaming of
+ counter Busy and increment it. Update the return aggregate.
+ (Iterate_Subtree): Add a renaming of counter Busy and increment
+ it. Update the return aggregate.
+ * a-cdlili.ads, a-cidlli.ads: Type List_Access is now a general access
+ type.
+ * a-cihama.ads: Type Map_Access is now a general access type.
+ * a-comutr.ads, a-cimutr.ads: Use type Natural for the two locks
+ associated with the tree.
+ * a-cohama.ads: Type Map_Access is now a general access type.
+ * a-coinve.ads, a-convec.ads: Type Vector_Access is now a general
+ access type.
+ * exp_ch5.adb (Expand_Iterator_Loop): Do not create a block
+ to wrap the loop as this is done at an earlier step, during
+ analysis. The declarations of the iterator and the cursor use
+ the usual Insert_Action mechanism when added into the tree.
+ * sem_ch5.adb (Analyze_Loop_Statement): Remove local constant
+ Loop_Statement and replace all respective uses by N. Add local
+ constant Loc. Preanalyze the loop iterator to discover whether
+ it is a container iterator and if it is, wrap the loop in a
+ block. This ensures that any controlled temporaries produced
+ by the iteration scheme share the same lifetime of the loop.
+ (Is_Container_Iterator): New routine.
+ (Is_Wrapped_In_Block): New routine.
+ (Pre_Analyze_Range): Move spec and body to the library level.
+
+2011-11-23 Sergey Rybin <rybin@adacore.com frybin>
+
+ * gnat_ugn.texi, vms_data.ads: Add documentation for new gnatpp option
+ that controls casing of type and subtype names.
+
+2011-11-23 Yannick Moy <moy@adacore.com>
+
+ * sem_ch3.adb: Minor addition of comments.
+
+2011-11-23 Thomas Quinot <quinot@adacore.com>
+
+ * prj-part.adb (Extension_Withs): New global variable,
+ contains the head of the list of WITH clauses from the EXTENDS
+ ALL projects for which virtual packages are being created.
+ (Look_For_Virtual_Projects_For): When recursing through
+ an EXTENDS ALL, add the WITH clauses of the extending
+ project to Extension_Withs. When adding a project to the
+ Virtual_Hash, record the associated Extension_Withs list.
+ (Create_Virtual_Extending_Project): Add a copy of the appropriate
+ Extension_Withs to the virtual project.
+
+2011-11-23 Thomas Quinot <quinot@adacore.com>
+
+ * mlib-tgt-specific-vxworks.adb: Minor reformatting.
+
+2011-11-23 Thomas Quinot <quinot@adacore.com>
+
+ * Make-generated.in (Sdefault.Target_Name): Set to
+ $(target_noncanonical) instead of $(target) for consistency.
+
2011-11-23 Matthew Heaney <heaney@adacore.com>
* a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb (Iterator): Declared
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with System; use type System.Address;
+with Ada.Finalization; use Ada.Finalization;
+with System; use type System.Address;
package body Ada.Containers.Bounded_Doubly_Linked_Lists is
- type Iterator is limited new
- List_Iterator_Interfaces.Reversible_Iterator with record
- Container : List_Access;
- Node : Count_Type;
+ type Iterator is new Limited_Controlled and
+ List_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : List_Access;
+ Node : Count_Type;
end record;
+ overriding procedure Finalize (Object : in out Iterator);
+
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
return Position.Container.Nodes (Position.Node).Element;
end Element;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- C : List renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
-
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
Node : Count_Type := Container.First;
begin
(Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => 0)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate
Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
+with Ada.Finalization; use Ada.Finalization;
with System; use type System.Address;
package body Ada.Containers.Bounded_Hashed_Maps is
- type Iterator is new
- Map_Iterator_Interfaces.Forward_Iterator with record
- Container : Map_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ Map_Iterator_Interfaces.Forward_Iterator with
+ record
+ Container : Map_Access;
+ end record;
+
+ overriding procedure Finalize (Object : in out Iterator);
overriding function First (Object : Iterator) return Cursor;
HT_Ops.Free (Container, X);
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
-- Start of processing for Iterate
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return Iterator'(Container => Container'Unrestricted_Access);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access)
+ do
+ B := B + 1;
+ end return;
end Iterate;
---------
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
+with Ada.Finalization; use Ada.Finalization;
with System; use type System.Address;
package body Ada.Containers.Bounded_Hashed_Sets is
- type Iterator is new Set_Iterator_Interfaces.Forward_Iterator with record
+ type Iterator is new Limited_Controlled and
+ Set_Iterator_Interfaces.Forward_Iterator with
+ record
Container : Set_Access;
end record;
+ overriding procedure Finalize (Object : in out Iterator);
+
overriding function First (Object : Iterator) return Cursor;
overriding function Next
HT_Ops.Free (Container, X);
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
-- Start of processing for Iterate
end Iterate;
function Iterate (Container : Set)
- return Set_Iterator_Interfaces.Forward_Iterator'Class is
+ return Set_Iterator_Interfaces.Forward_Iterator'Class
+ is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return Iterator'(Container => Container'Unrestricted_Access);
+ B := B + 1;
+
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access);
end Iterate;
------------
begin
if Node = 0 then
- raise Constraint_Error with "key not in map"; -- ??? "set"
+ raise Constraint_Error with "key not in map"; -- ??? "set"
end if;
return Container.Nodes (Node).Element;
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with System; use type System.Address;
+with Ada.Finalization; use Ada.Finalization;
+with System; use type System.Address;
+
package body Ada.Containers.Bounded_Multiway_Trees is
No_Node : constant Count_Type'Base := -1;
- type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with
+ type Iterator is new Limited_Controlled and
+ Tree_Iterator_Interfaces.Forward_Iterator with
record
Container : Tree_Access;
Position : Cursor;
From_Root : Boolean;
end record;
+ overriding procedure Finalize (Object : in out Iterator);
+
overriding function First (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
Position : Cursor) return Cursor;
- type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with
+ type Child_Iterator is new Limited_Controlled and
+ Tree_Iterator_Interfaces.Reversible_Iterator with
record
Container : Tree_Access;
Position : Cursor;
end record;
+ overriding procedure Finalize (Object : in out Child_Iterator);
+
overriding function First (Object : Child_Iterator) return Cursor;
overriding function Next
Right_Subtree => Right_Subtree);
end Equal_Subtree;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
+ procedure Finalize (Object : in out Child_Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
(Container : Tree;
Process : not null access procedure (Position : Cursor))
is
- T : Tree renames Container'Unrestricted_Access.all;
- B : Integer renames T.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
if Container.Count = 0 then
function Iterate (Container : Tree)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
- Root_Cursor : constant Cursor :=
- (Container'Unrestricted_Access, Root_Node (Container));
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+ RC : constant Cursor :=
+ (Container'Unrestricted_Access, Root_Node (Container));
+
begin
- return
- Iterator'(Container'Unrestricted_Access,
- First_Child (Root_Cursor),
- From_Root => True);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Position => First_Child (RC),
+ From_Root => True)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------------------
end if;
declare
- NN : Tree_Node_Array renames Parent.Container.Nodes;
- B : Integer renames Parent.Container.Busy;
+ B : Natural renames Parent.Container.Busy;
C : Count_Type;
+ NN : Tree_Node_Array renames Parent.Container.Nodes;
begin
B := B + 1;
Parent : Cursor)
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
- pragma Unreferenced (Container);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return Child_Iterator'(Parent.Container, Parent);
+ return It : constant Child_Iterator :=
+ Child_Iterator'(Limited_Controlled with
+ Container => Parent.Container,
+ Position => Parent)
+ do
+ B := B + 1;
+ end return;
end Iterate_Children;
---------------------
(Position : Cursor)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
+ B : Natural renames Position.Container.all.Busy;
+
begin
- return Iterator'(Position.Container, Position, From_Root => False);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Position.Container,
+ Position => Position,
+ From_Root => False)
+ do
+ B := B + 1;
+ end return;
end Iterate_Subtree;
procedure Iterate_Subtree
declare
T : Tree renames Position.Container.all;
- B : Integer renames T.Busy;
+ B : Natural renames T.Busy;
begin
B := B + 1;
declare
T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Integer renames T.Busy;
- L : Integer renames T.Lock;
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
begin
B := B + 1;
declare
NN : Tree_Node_Array renames Parent.Container.Nodes;
- B : Integer renames Parent.Container.Busy;
+ B : Natural renames Parent.Container.Busy;
C : Count_Type;
begin
declare
T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Integer renames T.Busy;
- L : Integer renames T.Lock;
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
begin
B := B + 1;
pragma Elaborate_All
(Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
-with System; use type System.Address;
+with Ada.Finalization; use Ada.Finalization;
+with System; use type System.Address;
package body Ada.Containers.Bounded_Ordered_Maps is
- type Iterator is limited new
- Map_Iterator_Interfaces.Reversible_Iterator with record
- Container : Map_Access;
- Node : Count_Type;
- end record;
+ type Iterator is new Limited_Controlled and
+ Map_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Map_Access;
+ Node : Count_Type;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
end if;
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Container.First)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate
Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
- begin
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
- -- iterator was defined to behave the same as for a complete iterator,
+ begin
+ -- 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,
-- 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);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
---------
pragma Elaborate_All
(Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
+with Ada.Finalization; use Ada.Finalization;
with System; use type System.Address;
package body Ada.Containers.Bounded_Ordered_Sets is
- type Iterator is limited new
- Set_Iterator_Interfaces.Reversible_Iterator with record
- Container : Set_Access;
- Node : Count_Type;
- end record;
+ type Iterator is new Limited_Controlled and
+ Set_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Set_Access;
+ Node : Count_Type;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
end if;
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
end Iterate;
function Iterate (Container : Set)
- return Set_Iterator_Interfaces.Reversible_Iterator'Class
+ return Set_Iterator_Interfaces.Reversible_Iterator'class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => 0)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate (Container : Set; Start : Cursor)
- return Set_Iterator_Interfaces.Reversible_Iterator'Class
+ return Set_Iterator_Interfaces.Reversible_Iterator'class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with System; use type System.Address;
-
with Ada.Unchecked_Deallocation;
+with System; use type System.Address;
package body Ada.Containers.Doubly_Linked_Lists is
- type Iterator is limited new
- List_Iterator_Interfaces.Reversible_Iterator with record
- Container : List_Access;
- Node : Node_Access;
+ type Iterator is new Limited_Controlled and
+ List_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : List_Access;
+ Node : Node_Access;
end record;
+ overriding procedure Finalize (Object : in out Iterator);
+
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
return Position.Node.Element;
end Element;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
while Node /= null loop
if Node.Element = Item then
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Next;
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.First);
+ return Cursor'(Container'Unrestricted_Access, Container.First);
end First;
function First (Object : Iterator) return Cursor is
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- C : List renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
-
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
Node : Node_Access := Container.First;
begin
begin
while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Node.Next;
end loop;
exception
function Iterate (Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => null)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate (Container : List; Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Last);
end Last;
function Last (Object : Iterator) return Cursor is
while Node /= null loop
if Node.Element = Item then
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Prev;
begin
while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Node.Prev;
end loop;
for List'Write use Write;
- type List_Access is access constant List;
+ type List_Access is access all List;
for List_Access'Storage_Size use 0;
type Cursor is
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with System; use type System.Address;
with Ada.Unchecked_Deallocation;
+with System; use type System.Address;
package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
- type Iterator is limited new
- List_Iterator_Interfaces.Reversible_Iterator with record
- Container : List_Access;
- Node : Node_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ List_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : List_Access;
+ Node : Node_Access;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
return Position.Node.Element.all;
end Element;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
while Node /= null loop
if Node.Element.all = Item then
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Next;
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.First);
+ return Cursor'(Container'Unrestricted_Access, Container.First);
end First;
function First (Object : Iterator) return Cursor is
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- C : List renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
-
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
Node : Node_Access := Container.First;
begin
begin
while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Node.Next;
end loop;
exception
function Iterate
(Container : List)
- return List_Iterator_Interfaces.Reversible_Iterator'Class
+ return List_Iterator_Interfaces.Reversible_Iterator'class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => null)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate
Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Last);
end Last;
function Last (Object : Iterator) return Cursor is
while Node /= null loop
if Node.Element.all = Item then
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Prev;
begin
while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Node.Prev;
end loop;
exception
for List'Write use Write;
- type List_Access is access constant List;
+ type List_Access is access all List;
for List_Access'Storage_Size use 0;
type Cursor is
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
with Ada.Unchecked_Deallocation;
-
with System; use type System.Address;
package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Free_Element is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
- type Iterator is limited new
- Map_Iterator_Interfaces.Forward_Iterator with record
- Container : Map_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ Map_Iterator_Interfaces.Forward_Iterator with
+ record
+ Container : Map_Access;
+ end record;
+
+ overriding procedure Finalize (Object : in out Iterator);
overriding function First (Object : Iterator) return Cursor;
HT_Ops.Finalize (Container.HT);
end Finalize;
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.HT.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
--------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end First;
function First (Object : Iterator) return Cursor is
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.HT.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
-- Start of processing Iterate
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
+
begin
- return Iterator'(Container => Container'Unrestricted_Access);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access)
+ do
+ B := B + 1;
+ end return;
end Iterate;
---------
use HT_Types;
use Ada.Finalization;
- overriding procedure Adjust (Container : in out Map);
-
+ overriding procedure Adjust (Container : in out Map);
overriding procedure Finalize (Container : in out Map);
- type Map_Access is access constant Map;
+ type Map_Access is access all Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
with Ada.Containers.Prime_Numbers;
-
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Indefinite_Hashed_Sets is
- type Iterator is limited new
- Set_Iterator_Interfaces.Forward_Iterator with record
- Container : Set_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ Set_Iterator_Interfaces.Forward_Iterator with
+ record
+ Container : Set_Access;
+ end record;
+
+ overriding procedure Finalize (Object : in out Iterator);
overriding function First (Object : Iterator) return Cursor;
HT_Ops.Finalize (Container.HT);
end Finalize;
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.HT.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.HT.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
-- Start of processing for Iterate
end Iterate;
function Iterate (Container : Set)
- return Set_Iterator_Interfaces.Forward_Iterator'Class is
+ return Set_Iterator_Interfaces.Forward_Iterator'Class
+ is
+ B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
+
begin
- return Iterator'(Container => Container'Unrestricted_Access);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access)
+ do
+ B := B + 1;
+ end return;
end Iterate;
------------
Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
if X = null then
- raise Constraint_Error with "key not in map"; -- ??? "set"
+ raise Constraint_Error with "key not in map"; -- ??? "set"
end if;
Free (X);
begin
if Node = null then
- raise Constraint_Error with "key not in map"; -- ??? "set"
+ raise Constraint_Error with "key not in map"; -- ??? "set"
end if;
return Node.Element.all;
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Indefinite_Multiway_Trees is
- type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with
+ type Iterator is new Limited_Controlled and
+ Tree_Iterator_Interfaces.Forward_Iterator with
record
Container : Tree_Access;
Position : Cursor;
From_Root : Boolean;
end record;
- type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with
+ type Child_Iterator is new Limited_Controlled and
+ Tree_Iterator_Interfaces.Reversible_Iterator with
record
Container : Tree_Access;
Position : Cursor;
end record;
+ overriding procedure Finalize (Object : in out Iterator);
+
overriding function First (Object : Iterator) return Cursor;
overriding function Next
- (Object : Iterator;
+ (Object : Iterator;
Position : Cursor) return Cursor;
+ overriding procedure Finalize (Object : in out Child_Iterator);
+
overriding function First (Object : Child_Iterator) return Cursor;
overriding function Next
- (Object : Child_Iterator;
+ (Object : Child_Iterator;
Position : Cursor) return Cursor;
overriding function Previous
- (Object : Child_Iterator;
+ (Object : Child_Iterator;
Position : Cursor) return Cursor;
overriding function Last (Object : Child_Iterator) return Cursor;
return Equal_Children (Left_Subtree, Right_Subtree);
end Equal_Subtree;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
+ procedure Finalize (Object : in out Child_Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
(Container : Tree;
Process : not null access procedure (Position : Cursor))
is
- T : Tree renames Container'Unrestricted_Access.all;
- B : Integer renames T.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
B := B + 1;
function Iterate (Container : Tree)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
- Root_Cursor : constant Cursor :=
- (Container'Unrestricted_Access, Root_Node (Container));
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+ RC : constant Cursor :=
+ (Container'Unrestricted_Access, Root_Node (Container));
+
begin
- return
- Iterator'(Container'Unrestricted_Access,
- First_Child (Root_Cursor),
- From_Root => True);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Position => First_Child (RC),
+ From_Root => True)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------------------
end if;
declare
- B : Integer renames Parent.Container.Busy;
+ B : Natural renames Parent.Container.Busy;
C : Tree_Node_Access;
begin
Parent : Cursor)
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
- pragma Unreferenced (Container);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return Child_Iterator'(Parent.Container, Parent);
+ return It : constant Child_Iterator :=
+ Child_Iterator'(Limited_Controlled with
+ Container => Parent.Container,
+ Position => Parent)
+ do
+ B := B + 1;
+ end return;
end Iterate_Children;
---------------------
(Position : Cursor)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
+ B : Natural renames Position.Container'Unrestricted_Access.all.Busy;
+
begin
- return Iterator'(Position.Container, Position, From_Root => False);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Position.Container,
+ Position => Position,
+ From_Root => False)
+ do
+ B := B + 1;
+ end return;
end Iterate_Subtree;
procedure Iterate_Subtree
end if;
declare
- B : Integer renames Position.Container.Busy;
+ B : Natural renames Position.Container.Busy;
begin
B := B + 1;
declare
T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Integer renames T.Busy;
- L : Integer renames T.Lock;
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
begin
B := B + 1;
end if;
declare
- B : Integer renames Parent.Container.Busy;
+ B : Natural renames Parent.Container.Busy;
C : Tree_Node_Access;
begin
declare
T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Integer renames T.Busy;
- L : Integer renames T.Lock;
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
begin
B := B + 1;
type Tree is new Controlled with record
Root : aliased Tree_Node_Type;
- Busy : Integer := 0;
- Lock : Integer := 0;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
Count : Count_Type := 0;
end record;
package body Ada.Containers.Indefinite_Ordered_Maps is
pragma Suppress (All_Checks);
- type Iterator is limited new
- Map_Iterator_Interfaces.Reversible_Iterator with record
- Container : Map_Access;
- Node : Node_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ Map_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Map_Access;
+ Node : Node_Access;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
end if;
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Tree.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
-- Start of processing for Iterate
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => null)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate
Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- 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);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
---------
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
with Ada.Unchecked_Deallocation;
-
with System; use type System.Address;
package body Ada.Containers.Indefinite_Ordered_Sets is
- type Iterator is limited new
- Set_Iterator_Interfaces.Reversible_Iterator with record
- Container : Set_Access;
- Node : Node_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ Set_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
end if;
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Tree.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
-- Start of processing for Iterate
function Iterate
(Container : Set)
- return Set_Iterator_Interfaces.Reversible_Iterator'Class
+ return Set_Iterator_Interfaces.Reversible_Iterator'class
is
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => null)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate
(Container : Set;
Start : Cursor)
- return Set_Iterator_Interfaces.Reversible_Iterator'Class
+ return Set_Iterator_Interfaces.Reversible_Iterator'class
is
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- 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);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
------------------------------------------------------------------------------
with Ada.Containers.Generic_Array_Sort;
-
+with Ada.Finalization; use Ada.Finalization;
with System; use type System.Address;
package body Ada.Containers.Bounded_Vectors is
- type Iterator is new
- Vector_Iterator_Interfaces.Reversible_Iterator with record
- Container : Vector_Access;
- Index : Index_Type;
- end record;
+ type Iterator is new Limited_Controlled and
+ Vector_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Vector_Access;
+ Index : Index_Type;
+ end record;
+
+ overriding procedure Finalize (Object : in out Iterator);
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
end if;
end Element;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
- V : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames V.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
B := B + 1;
(Container : Vector)
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return Iterator'(Container'Unrestricted_Access, Index_Type'First);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Index_Type'First)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate
Start : Cursor)
return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return Iterator'(Container'Unrestricted_Access, Start.Index);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Start.Index)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
package body Ada.Containers.Hashed_Maps is
- type Iterator is limited new
- Map_Iterator_Interfaces.Forward_Iterator with record
- Container : Map_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ Map_Iterator_Interfaces.Forward_Iterator with
+ record
+ Container : Map_Access;
+ end record;
+
+ overriding procedure Finalize (Object : in out Iterator);
overriding function First (Object : Iterator) return Cursor;
HT_Ops.Finalize (Container.HT);
end Finalize;
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.HT.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
--------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end First;
function First (Object : Iterator) return Cursor is
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
procedure Insert
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
procedure Insert
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.HT.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
-- Start of processing for Iterate
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
+
begin
- return Iterator'(Container => Container'Unrestricted_Access);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access)
+ do
+ B := B + 1;
+ end return;
end Iterate;
---------
for Map'Read use Read;
- type Map_Access is access constant Map;
+ type Map_Access is access all Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
with Ada.Containers.Generic_Array_Sort;
with Ada.Unchecked_Deallocation;
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Indefinite_Vectors is
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
- type Iterator is new
- Vector_Iterator_Interfaces.Reversible_Iterator with record
+ type Iterator is new Limited_Controlled and
+ Vector_Iterator_Interfaces.Reversible_Iterator with
+ record
Container : Vector_Access;
Index : Index_Type;
end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
end;
end Finalize;
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
if Container.Elements.EA (J) /= null
and then Container.Elements.EA (J).all = Item
then
- return (Container'Unchecked_Access, J);
+ return (Container'Unrestricted_Access, J);
end if;
end loop;
return No_Element;
end if;
- return (Container'Unchecked_Access, Index_Type'First);
+ return (Container'Unrestricted_Access, Index_Type'First);
end First;
function First (Object : Iterator) return Cursor is
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
begin
if Before.Container /= null
- and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
+ and then Before.Container /=
+ Vector_Access'(Container'Unrestricted_Access)
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
Insert (Container, Index, New_Item);
- Position := Cursor'(Container'Unchecked_Access, Index);
+ Position := Cursor'(Container'Unrestricted_Access, Index);
end Insert;
procedure Insert
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
Insert (Container, Index, New_Item, Count);
- Position := (Container'Unchecked_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert;
------------------
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
Insert_Space (Container, Index, Count);
- Position := Cursor'(Container'Unchecked_Access, Index);
+ Position := Cursor'(Container'Unrestricted_Access, Index);
end Insert_Space;
--------------
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
- V : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames V.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
B := B + 1;
begin
for Indx in Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, Indx));
+ Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
function Iterate (Container : Vector)
return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
- It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return It;
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Index_Type'First)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate
Start : Cursor)
return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
- It : constant Iterator :=
- (Container'Unchecked_Access, Start.Index);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return It;
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Start.Index)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
return No_Element;
end if;
- return (Container'Unchecked_Access, Container.Last);
+ return (Container'Unrestricted_Access, Container.Last);
end Last;
function Last (Object : Iterator) return Cursor is
begin
if Position.Container /= null
- and then Position.Container /= Container'Unchecked_Access
+ and then Position.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
- return (Container'Unchecked_Access, Indx);
+ return (Container'Unrestricted_Access, Indx);
end if;
end loop;
begin
for Indx in reverse Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, Indx));
+ Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Index);
+ return Cursor'(Container'Unrestricted_Access, Index);
end To_Cursor;
--------------
for Vector'Read use Read;
- type Vector_Access is access constant Vector;
+ type Vector_Access is access all Vector;
for Vector_Access'Storage_Size use 0;
type Cursor is record
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Multiway_Trees is
- type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with
+ type Iterator is new Limited_Controlled and
+ Tree_Iterator_Interfaces.Forward_Iterator with
record
Container : Tree_Access;
Position : Cursor;
From_Root : Boolean;
end record;
- type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with
+ type Child_Iterator is new Limited_Controlled and
+ Tree_Iterator_Interfaces.Reversible_Iterator with
record
Container : Tree_Access;
Position : Cursor;
end record;
+ overriding procedure Finalize (Object : in out Iterator);
+
overriding function First (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
Position : Cursor) return Cursor;
+ overriding procedure Finalize (Object : in out Child_Iterator);
+
overriding function First (Object : Child_Iterator) return Cursor;
overriding function Next
(Object : Child_Iterator;
return Equal_Children (Left_Subtree, Right_Subtree);
end Equal_Subtree;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
+ procedure Finalize (Object : in out Child_Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
(Container : Tree;
Process : not null access procedure (Position : Cursor))
is
- T : Tree renames Container'Unrestricted_Access.all;
- B : Integer renames T.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
B := B + 1;
function Iterate (Container : Tree)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
- Root_Cursor : constant Cursor :=
- (Container'Unrestricted_Access, Root_Node (Container));
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+ RC : constant Cursor :=
+ (Container'Unrestricted_Access, Root_Node (Container));
+
begin
- return
- Iterator'(Container'Unrestricted_Access,
- First_Child (Root_Cursor),
- From_Root => True);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Position => First_Child (RC),
+ From_Root => True)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------------------
end if;
declare
- B : Integer renames Parent.Container.Busy;
+ B : Natural renames Parent.Container.Busy;
C : Tree_Node_Access;
begin
Parent : Cursor)
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
- pragma Unreferenced (Container);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return Child_Iterator'(Parent.Container, Parent);
+ return It : constant Child_Iterator :=
+ Child_Iterator'(Limited_Controlled with
+ Container => Parent.Container,
+ Position => Parent)
+ do
+ B := B + 1;
+ end return;
end Iterate_Children;
---------------------
(Position : Cursor)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
+ B : Natural renames Position.Container'Unrestricted_Access.all.Busy;
+
begin
- return Iterator'(Position.Container, Position, From_Root => False);
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Position.Container,
+ Position => Position,
+ From_Root => False)
+ do
+ B := B + 1;
+ end return;
end Iterate_Subtree;
procedure Iterate_Subtree
end if;
declare
- B : Integer renames Position.Container.Busy;
+ B : Natural renames Position.Container.Busy;
begin
B := B + 1;
declare
T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Integer renames T.Busy;
- L : Integer renames T.Lock;
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
begin
B := B + 1;
end if;
declare
- B : Integer renames Parent.Container.Busy;
+ B : Natural renames Parent.Container.Busy;
C : Tree_Node_Access;
begin
declare
T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Integer renames T.Busy;
- L : Integer renames T.Lock;
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
begin
B := B + 1;
type Tree is new Controlled with record
Root : aliased Root_Node_Type;
- Busy : Integer := 0;
- Lock : Integer := 0;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
Count : Count_Type := 0;
end record;
with Ada.Containers.Generic_Array_Sort;
with Ada.Unchecked_Deallocation;
-
with System; use type System.Address;
package body Ada.Containers.Vectors is
procedure Free is
new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
- type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with
+ type Iterator is new Limited_Controlled and
+ Vector_Iterator_Interfaces.Reversible_Iterator with
record
Container : Vector_Access;
Index : Index_Type;
end record;
+ overriding procedure Finalize (Object : in out Iterator);
+
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
overriding function Next
Free (X);
end Finalize;
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) = Item then
- return (Container'Unchecked_Access, J);
+ return (Container'Unrestricted_Access, J);
end if;
end loop;
if Is_Empty (Container) then
return No_Element;
else
- return (Container'Unchecked_Access, Index_Type'First);
+ return (Container'Unrestricted_Access, Index_Type'First);
end if;
end First;
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
Insert (Container, Index, New_Item);
- Position := (Container'Unchecked_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert;
procedure Insert
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
Insert (Container, Index, New_Item, Count);
- Position := (Container'Unchecked_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert;
procedure Insert
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
Insert_Space (Container, Index, Count => Count);
- Position := (Container'Unchecked_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert_Space;
--------------
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
- V : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames V.Busy;
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
B := B + 1;
begin
for Indx in Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, Indx));
+ Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
(Container : Vector)
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
- It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return It;
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Index_Type'First)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate
Start : Cursor)
return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
- It : constant Iterator := (Container'Unchecked_Access, Start.Index);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return It;
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Start.Index)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
if Is_Empty (Container) then
return No_Element;
else
- return (Container'Unchecked_Access, Container.Last);
+ return (Container'Unrestricted_Access, Container.Last);
end if;
end Last;
begin
if Position.Container /= null
- and then Position.Container /= Container'Unchecked_Access
+ and then Position.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Position cursor denotes wrong container";
end if;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = Item then
- return (Container'Unchecked_Access, Indx);
+ return (Container'Unrestricted_Access, Indx);
end if;
end loop;
begin
for Indx in reverse Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, Indx));
+ Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
if Index not in Index_Type'First .. Container.Last then
return No_Element;
else
- return (Container'Unchecked_Access, Index);
+ return (Container'Unrestricted_Access, Index);
end if;
end To_Cursor;
Lock : Natural := 0;
end record;
- type Vector_Access is access constant Vector;
+ type Vector_Access is access all Vector;
for Vector_Access'Storage_Size use 0;
type Cursor is record
package body Ada.Containers.Ordered_Maps is
- type Iterator is limited new
- Map_Iterator_Interfaces.Reversible_Iterator with record
- Container : Map_Access;
- Node : Node_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ Map_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Map_Access;
+ Node : Node_Access;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
end if;
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Tree.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => null)
+ do
+ B := B + 1;
+ end return;
end Iterate;
function Iterate (Container : Map; Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- 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);
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
---------
package body Ada.Containers.Ordered_Sets is
- type Iterator is limited new
- Set_Iterator_Interfaces.Reversible_Iterator with record
- Container : Set_Access;
- Node : Node_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ Set_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
end if;
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Tree.Busy;
+
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
-- Start of processing for Iterate
function Iterate (Container : Set)
return Set_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- 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);
+ B := B + 1;
+
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => null);
end Iterate;
function Iterate (Container : Set; Start : Cursor)
return Set_Iterator_Interfaces.Reversible_Iterator'Class
is
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- 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);
+ B := B + 1;
+
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node);
end Iterate;
----------
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pack, Loc),
Selector_Name =>
- Make_Identifier (Loc, Name_Has_Element)),
+ Make_Identifier (Loc, Name_Has_Element)),
Parameter_Associations =>
New_List (
-- I : Iterator_Type renames Container;
-- C : Pack.Cursor_Type := Container.[First | Last];
- declare
- Decl1 : Node_Id;
- Decl2 : Node_Id;
- Decl3 : Node_Id;
+ Insert_Action (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Iterator,
+ Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc),
+ Name => Relocate_Node (Name (I_Spec))));
- begin
- Decl1 :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Iterator,
- Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc),
- Name => Relocate_Node (Name (I_Spec)));
+ -- Create declaration for cursor
- -- Create declaration for cursor
+ declare
+ Decl : Node_Id;
- Decl2 :=
+ begin
+ Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Cursor,
Object_Definition =>
Selector_Name =>
Make_Identifier (Loc, Name_Init)));
- Set_Assignment_OK (Decl2);
-
-- The cursor is only modified in expanded code, so it appears
-- as unassigned to the warning machinery. We must suppress
-- this spurious warning explicitly.
- Decl3 :=
- Make_Pragma (Loc,
- Chars => Name_Warnings,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Name_Off)),
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- New_Occurrence_Of (Cursor, Loc))));
+ Set_Warnings_Off (Cursor);
+ Set_Assignment_OK (Decl);
- -- The expanded loop is wrapped in a block, to make the loop
- -- variable local.
-
- New_Loop :=
- Make_Block_Statement (Loc,
- Declarations => New_List (Decl1, Decl2, Decl3),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (New_Loop)));
+ Insert_Action (N, Decl);
end;
-- If the range of iteration is given by a function call that
-- If an incomplete type is still not frozen, this may be a
-- premature freezing because of a body declaration that follows.
- -- Indicate where the freezing took place.
+ -- Indicate where the freezing took place. Freezing will happen
+ -- if the body comes from source, but not if it is internally
+ -- generated, for example as the body of a type invariant.
-- If the freezing is caused by the end of the current declarative
-- part, it is a Taft Amendment type, and there is no error.
N_Protected_Body,
N_Task_Body)
or else Nkind (Bod) in N_Body_Stub)
- and then
- List_Containing (After) = List_Containing (Parent (E))
+ and then
+ List_Containing (After) = List_Containing (Parent (E))
+ and then Comes_From_Source (Bod)
then
Error_Msg_Sloc := Sloc (Next (After));
Error_Msg_NE
with GNAT.TTY;
with System;
+with System.OS_Constants;
package GNAT.Expect.TTY is
+ pragma Linker_Options (System.OS_Constants.PTY_Library);
+
------------------
-- TTY_Process --
------------------
Enumeration literals are in mixed case. Overrides ^-n^/NAME_CASING^ casing
setting.
+@cindex @option{^-nt@var{x}^/TYPE_CASING^} (@command{gnatpp})
+@item ^-neD^/TYPE_CASING=AS_DECLARED^
+Type and subtype name casing for defining occurrences are as they appear in
+the source file. Overrides ^-n^/NAME_CASING^ casing setting.
+
+@item ^-ntU^/TYPE_CASING=UPPER_CASE^
+Type and subtype names are in upper case. Overrides ^-n^/NAME_CASING^ casing
+setting.
+
+@item ^-ntL^/TYPE_CASING=LOWER_CASE^
+Type and subtype names are in lower case. Overrides ^-n^/NAME_CASING^ casing
+setting.
+
+@item ^-ntM^/TYPE_CASING=MIXED_CASE^
+Type and subtype names are in mixed case. Overrides ^-n^/NAME_CASING^ casing
+setting.
+
@cindex @option{^-p@var{x}^/PRAGMA_CASING^} (@command{gnatpp})
@item ^-pL^/PRAGMA_CASING=LOWER_CASE^
Pragma names are lower case
package Virtual_Hash is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Project_Node_Id,
- No_Element => Empty_Node,
+ No_Element => Project_Node_High_Bound,
Key => Project_Node_Id,
Hash => Prj.Tree.Hash,
Equal => "=");
- -- Hash table to store the node id of the project for which a virtual
- -- extending project need to be created.
+ -- Hash table to store the node ids of projects for which a virtual
+ -- extending project need to be created. The corresponding value is the
+ -- head of a list of WITH clauses corresponding to the context of the
+ -- enclosing EXTEND ALL projects. Note: Default_Element is Project_Node_
+ -- High_Bound because we want Empty_Node to be a possible value.
package Processed_Hash is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
-- Check that an aggregate project only imports abstract projects
procedure Create_Virtual_Extending_Project
- (For_Project : Project_Node_Id;
- Main_Project : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref);
+ (For_Project : Project_Node_Id;
+ Main_Project : Project_Node_Id;
+ Extension_Withs : Project_Node_Id;
+ In_Tree : Project_Node_Tree_Ref);
-- Create a virtual extending project of For_Project. Main_Project is
- -- the extending all project.
+ -- the extending all project. Extension_Withs is the head of a WITH clause
+ -- list to be added to the created virtual project.
--
-- The String_Value_Of is not set for the automatically added with
-- clause and keeps the default value of No_Name. This enables Prj.PP
-- Returns No_Name if the path name is invalid, because the corresponding
-- project name does not have the syntax of an ada identifier.
+ function Copy_With_Clause
+ (With_Clause : Project_Node_Id;
+ In_Tree : Project_Node_Tree_Ref;
+ Next_Clause : Project_Node_Id) return Project_Node_Id;
+ -- Return a copy of With_Clause in In_Tree, whose Next_With_Clause is the
+ -- indicated one.
+
+ ----------------------
+ -- Copy_With_Clause --
+ ----------------------
+
+ function Copy_With_Clause
+ (With_Clause : Project_Node_Id;
+ In_Tree : Project_Node_Tree_Ref;
+ Next_Clause : Project_Node_Id) return Project_Node_Id
+ is
+ New_With_Clause : constant Project_Node_Id :=
+ Default_Project_Node (In_Tree, N_With_Clause);
+ begin
+ Set_Name_Of (New_With_Clause, In_Tree,
+ Name_Of (With_Clause, In_Tree));
+ Set_Path_Name_Of (New_With_Clause, In_Tree,
+ Path_Name_Of (With_Clause, In_Tree));
+ Set_Project_Node_Of (New_With_Clause, In_Tree,
+ Project_Node_Of (With_Clause, In_Tree));
+ Set_Next_With_Clause_Of (New_With_Clause, In_Tree, Next_Clause);
+
+ return New_With_Clause;
+ end Copy_With_Clause;
+
--------------------------------------
-- Create_Virtual_Extending_Project --
--------------------------------------
procedure Create_Virtual_Extending_Project
- (For_Project : Project_Node_Id;
- Main_Project : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
+ (For_Project : Project_Node_Id;
+ Main_Project : Project_Node_Id;
+ Extension_Withs : Project_Node_Id;
+ In_Tree : Project_Node_Tree_Ref)
is
Virtual_Name : constant String :=
Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree);
- -- With clause
+ -- Add a WITH clause to the main project to import the newly created
+ -- virtual extending project.
Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id);
Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id);
(With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree));
Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause);
+ -- Copy with clauses for projects imported by the extending-all project
+
+ declare
+ Org_With_Clause : Project_Node_Id := Extension_Withs;
+ New_With_Clause : Project_Node_Id := Empty_Node;
+ begin
+ while Present (Org_With_Clause) loop
+ New_With_Clause :=
+ Copy_With_Clause (Org_With_Clause, In_Tree, New_With_Clause);
+
+ Org_With_Clause := Next_With_Clause_Of (Org_With_Clause, In_Tree);
+ end loop;
+ Set_First_With_Clause_Of (Virtual_Project, In_Tree, New_With_Clause);
+ end;
+
-- Virtual project node
Set_Location_Of
-- Look_For_Virtual_Projects_For --
-----------------------------------
+ Extension_Withs : Project_Node_Id;
+ -- Head of the current EXTENDS ALL imports list. When creating virtual
+ -- projects for an EXTENDS ALL, we import in each virtual project all
+ -- of the projects that appear in WITH clauses of the extending projects.
+ -- This ensures that virtual projects share a consistent environment (in
+ -- particular if a project imported by one of the extending projects
+ -- replaces some runtime units).
+
procedure Look_For_Virtual_Projects_For
(Proj : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
Extended : Project_Node_Id := Empty_Node;
-- Node for the eventual project extended by Proj
+ Extends_All : Boolean := False;
+ -- Set True if Proj is an EXTENDS ALL project
+
+ Saved_Extension_Withs : constant Project_Node_Id := Extension_Withs;
+
begin
- -- Nothing to do if Proj is not defined or if it has already been
- -- processed.
+ -- Nothing to do if Proj is undefined or has already been processed
if Present (Proj) and then not Processed_Hash.Get (Proj) then
-- Make sure the project will not be processed again
if Present (Declaration) then
Extended := Extended_Project_Of (Declaration, In_Tree);
+ Extends_All := Is_Extending_All (Proj, In_Tree);
end if;
-- If this is a project that may need a virtual extending project
-- and it is not itself an extending project, put it in the list.
if Potentially_Virtual and then No (Extended) then
- Virtual_Hash.Set (Proj, Proj);
+ Virtual_Hash.Set (Proj, Extension_Withs);
end if;
-- Now check the projects it imports
(Imported, In_Tree, Potentially_Virtual => True);
end if;
+ if Extends_All then
+ -- This is an EXTENDS ALL project: prepend each of its WITH
+ -- clauses to the currently active list of extension deps.
+
+ Extension_Withs :=
+ Copy_With_Clause (With_Clause, In_Tree, Extension_Withs);
+ end if;
+
With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
end loop;
Look_For_Virtual_Projects_For
(Extended, In_Tree, Potentially_Virtual => False);
+
+ Extension_Withs := Saved_Extension_Withs;
end if;
end Look_For_Virtual_Projects_For;
Declaration : constant Project_Node_Id :=
Project_Declaration_Of (Project, In_Tree);
begin
+ Extension_Withs := First_With_Clause_Of (Project, In_Tree);
Look_For_Virtual_Projects_For
(Extended_Project_Of (Declaration, In_Tree), In_Tree,
Potentially_Virtual => False);
-- Now create all the virtual extending projects
declare
- Proj : Project_Node_Id := Virtual_Hash.Get_First;
+ Proj : Project_Node_Id := Empty_Node;
+ Withs : Project_Node_Id;
begin
- while Present (Proj) loop
- Create_Virtual_Extending_Project (Proj, Project, In_Tree);
- Proj := Virtual_Hash.Get_Next;
+ Virtual_Hash.Get_First (Proj, Withs);
+ while Withs /= Project_Node_High_Bound loop
+ Create_Virtual_Extending_Project
+ (Proj, Project, Withs, In_Tree);
+ Virtual_Hash.Get_Next (Proj, Withs);
end loop;
end;
end if;
#endif /* HAVE_TERMIOS */
+/*
+
+ -----------------------------
+ -- Pseudo terminal library --
+ -----------------------------
+
+*/
+
+#if defined (__FreeBSD__) || defined (linux)
+# define PTY_Library "-lutil"
+#else
+# define PTY_Library ""
+#endif
+CST(PTY_Library, "for g-exptty")
+
/**
** Sockets constants
**/
with System.Tasking.Debug;
with System.Interrupt_Management;
+with System.OS_Constants;
with System.OS_Primitives;
with System.Task_Primitives.Interrupt_Operations;
package body System.Task_Primitives.Operations is
+ package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
use System.Tasking.Debug;
with System.Task_Info;
with System.Tasking.Debug;
with System.Interrupt_Management;
+with System.OS_Constants;
with System.OS_Primitives;
with System.IO;
package body System.Task_Primitives.Operations is
+ package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
use System.Tasking;
with System.Tasking.Debug;
with System.Interrupt_Management;
+with System.OS_Constants;
with System.OS_Primitives;
with System.Task_Info;
package body System.Task_Primitives.Operations is
+ package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
use System.Tasking.Debug;
with System.Multiprocessors;
with System.Tasking.Debug;
with System.Interrupt_Management;
+with System.OS_Constants;
with System.OS_Primitives;
with System.Task_Info;
package body System.Task_Primitives.Operations is
+ package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
use System.Tasking.Debug;
with System.Tasking.Debug;
with System.Interrupt_Management;
+with System.OS_Constants;
with System.OS_Primitives;
with System.Task_Info;
package body System.Task_Primitives.Operations is
+ package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
use System.Tasking.Debug;
with System.Tasking.Debug;
with System.Interrupt_Management;
with System.Float_Control;
+with System.OS_Constants;
with System.Soft_Links;
-- We use System.Soft_Links instead of System.Tasking.Initialization
package body System.Task_Primitives.Operations is
+ package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
use System.Tasking.Debug;
with System.Parameters;
with System.Tasking;
-with System.OS_Constants;
with System.OS_Interface;
package System.Task_Primitives.Operations is
pragma Preelaborate;
package ST renames System.Tasking;
- package OSC renames System.OS_Constants;
package OSI renames System.OS_Interface;
procedure Initialize (Environment_Task : ST.Task_Id);
-- needed, since checks may cause duplication of the expressions
-- which must not be reevaluated.
+ -- The forced evaluation removes side effects from expressions,
+ -- which should occur also in Alfa mode. Otherwise, we end up with
+ -- unexpected insertions of actions at places where this is not
+ -- supposed to occur, e.g. on default parameters of a call.
+
if Expander_Active then
Force_Evaluation (Low_Bound (R));
Force_Evaluation (High_Bound (R));
-- if needed, before applying checks, since checks may cause
-- duplication of the expression without forcing evaluation.
+ -- The forced evaluation removes side effects from expressions,
+ -- which should occur also in Alfa mode. Otherwise, we end up with
+ -- unexpected insertions of actions at places where this is not
+ -- supposed to occur, e.g. on default parameters of a call.
+
if Expander_Active then
Force_Evaluation (Lo);
Force_Evaluation (Hi);
-- Case of other than an explicit N_Range node
+ -- The forced evaluation removes side effects from expressions, which
+ -- should occur also in Alfa mode. Otherwise, we end up with unexpected
+ -- insertions of actions at places where this is not supposed to occur,
+ -- e.g. on default parameters of a call.
+
elsif Expander_Active then
Get_Index_Bounds (R, Lo, Hi);
Force_Evaluation (Lo);
-- messages. This variable is recursively saved on entry to processing the
-- construct, and restored on exit.
+ procedure Pre_Analyze_Range (R_Copy : Node_Id);
+ -- Determine expected type of range or domain of iteration of Ada 2012
+ -- loop by analyzing separate copy. Do the analysis and resolution of the
+ -- copy of the bound(s) with expansion disabled, to prevent the generation
+ -- of finalization actions. This prevents memory leaks when the bounds
+ -- contain calls to functions returning controlled arrays or when the
+ -- domain of iteration is a container.
+
------------------------
-- Analyze_Assignment --
------------------------
-- calls that use the secondary stack, returning True if any such call
-- is found, and False otherwise.
- procedure Pre_Analyze_Range (R_Copy : Node_Id);
- -- Determine expected type of range or domain of iteration of Ada 2012
- -- loop by analyzing separate copy. Do the analysis and resolution of
- -- the copy of the bound(s) with expansion disabled, to prevent the
- -- generation of finalization actions. This prevents memory leaks when
- -- the bounds contain calls to functions returning controlled arrays or
- -- when the domain of iteration is a container.
-
- -----------------------
- -- Pre_Analyze_Range --
- -----------------------
-
- procedure Pre_Analyze_Range (R_Copy : Node_Id) is
- Save_Analysis : Boolean;
- begin
- Save_Analysis := Full_Analysis;
- Full_Analysis := False;
- Expander_Mode_Save_And_Set (False);
-
- Analyze (R_Copy);
-
- if Nkind (R_Copy) in N_Subexpr
- and then Is_Overloaded (R_Copy)
- then
-
- -- Apply preference rules for range of predefined integer types,
- -- or diagnose true ambiguity.
-
- declare
- I : Interp_Index;
- It : Interp;
- Found : Entity_Id := Empty;
-
- begin
- Get_First_Interp (R_Copy, I, It);
- while Present (It.Typ) loop
- if Is_Discrete_Type (It.Typ) then
- if No (Found) then
- Found := It.Typ;
- else
- if Scope (Found) = Standard_Standard then
- null;
-
- elsif Scope (It.Typ) = Standard_Standard then
- Found := It.Typ;
-
- else
- -- Both of them are user-defined
-
- Error_Msg_N
- ("ambiguous bounds in range of iteration",
- R_Copy);
- Error_Msg_N ("\possible interpretations:", R_Copy);
- Error_Msg_NE ("\\} ", R_Copy, Found);
- Error_Msg_NE ("\\} ", R_Copy, It.Typ);
- exit;
- end if;
- end if;
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
- end;
- end if;
-
- if Is_Entity_Name (R_Copy)
- and then Is_Type (Entity (R_Copy))
- then
-
- -- Subtype mark in iteration scheme
-
- null;
-
- elsif Nkind (R_Copy) in N_Subexpr then
-
- -- Expression in range, or Ada 2012 iterator
-
- Resolve (R_Copy);
- end if;
-
- Expander_Mode_Restore;
- Full_Analysis := Save_Analysis;
- end Pre_Analyze_Range;
-
--------------------
-- Process_Bounds --
--------------------
if New_Lo_Bound /= Lo
and then Is_Static_Expression (New_Lo_Bound)
then
- Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound));
+ Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound));
end if;
if New_Hi_Bound /= Hi
begin
if Present (H)
and then Enclosing_Dynamic_Scope (H) =
- Enclosing_Dynamic_Scope (Id)
+ Enclosing_Dynamic_Scope (Id)
and then Ekind (H) = E_Variable
and then Is_Discrete_Type (Etype (H))
then
then
Process_Bounds (DS);
- -- expander not active or else range of iteration is a subtype
+ -- Expander not active or else range of iteration is a subtype
-- indication, an entity, or a function call that yields an
-- aggregate or a container.
----------------------------
procedure Analyze_Loop_Statement (N : Node_Id) is
- Loop_Statement : constant Node_Id := N;
- Id : constant Node_Id := Identifier (Loop_Statement);
- Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);
+ function Is_Container_Iterator (Iter : Node_Id) return Boolean;
+ -- Given a loop iteration scheme, determine whether it is an Ada 2012
+ -- container iteration.
+
+ function Is_Wrapped_In_Block (N : Node_Id) return Boolean;
+ -- Determine whether node N is the sole statement of a block
+
+ ---------------------------
+ -- Is_Container_Iterator --
+ ---------------------------
+
+ function Is_Container_Iterator (Iter : Node_Id) return Boolean is
+ begin
+ -- Infinite loop
+
+ if No (Iter) then
+ return False;
+
+ -- While loop
+
+ elsif Present (Condition (Iter)) then
+ return False;
+
+ -- for Def_Id in [reverse] Name loop
+ -- for Def_Id [: Subtype_Indication] of [reverse] Name loop
+
+ elsif Present (Iterator_Specification (Iter)) then
+ declare
+ Nam : constant Node_Id := Name (Iterator_Specification (Iter));
+ Nam_Copy : Node_Id;
+
+ begin
+ Nam_Copy := New_Copy_Tree (Nam);
+ Set_Parent (Nam_Copy, Parent (Nam));
+ Pre_Analyze_Range (Nam_Copy);
+
+ -- The only two options here are iteration over a container or
+ -- an array.
+
+ return not Is_Array_Type (Etype (Nam_Copy));
+ end;
+
+ -- for Def_Id in [reverse] Discrete_Subtype_Definition loop
+
+ else
+ declare
+ LP : constant Node_Id := Loop_Parameter_Specification (Iter);
+ DS : constant Node_Id := Discrete_Subtype_Definition (LP);
+ DS_Copy : Node_Id;
+
+ begin
+ DS_Copy := New_Copy_Tree (DS);
+ Set_Parent (DS_Copy, Parent (DS));
+ Pre_Analyze_Range (DS_Copy);
+
+ -- Check for a call to Iterate ()
+
+ return
+ Nkind (DS_Copy) = N_Function_Call
+ and then Needs_Finalization (Etype (DS_Copy));
+ end;
+ end if;
+ end Is_Container_Iterator;
+
+ -------------------------
+ -- Is_Wrapped_In_Block --
+ -------------------------
+
+ function Is_Wrapped_In_Block (N : Node_Id) return Boolean is
+ HSS : constant Node_Id := Parent (N);
+
+ begin
+ return
+ Nkind (HSS) = N_Handled_Sequence_Of_Statements
+ and then Nkind (Parent (HSS)) = N_Block_Statement
+ and then First (Statements (HSS)) = N
+ and then No (Next (First (Statements (HSS))));
+ end Is_Wrapped_In_Block;
+
+ -- Local declarations
+
+ Id : constant Node_Id := Identifier (N);
+ Iter : constant Node_Id := Iteration_Scheme (N);
+ Loc : constant Source_Ptr := Sloc (N);
Ent : Entity_Id;
+ -- Start of processing for Analyze_Loop_Statement
+
begin
if Present (Id) then
if No (Ent) then
if Total_Errors_Detected /= 0 then
- Ent :=
- New_Internal_Entity
- (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L');
+ Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
else
raise Program_Error;
end if;
else
- Generate_Reference (Ent, Loop_Statement, ' ');
+ Generate_Reference (Ent, N, ' ');
Generate_Definition (Ent);
-- If we found a label, mark its type. If not, ignore it, since it
Set_Ekind (Ent, E_Loop);
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
- Set_Label_Construct (Parent (Ent), Loop_Statement);
+ Set_Label_Construct (Parent (Ent), N);
end if;
end if;
end if;
-- Case of no identifier present
else
- Ent :=
- New_Internal_Entity
- (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L');
- Set_Etype (Ent, Standard_Void_Type);
- Set_Parent (Ent, Loop_Statement);
+ Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, N);
+ end if;
+
+ -- Iteration over a container in Ada 2012 involves the creation of a
+ -- controlled iterator object. Wrap the loop in a block to ensure the
+ -- timely finalization of the iterator and release of container locks.
+
+ if Ada_Version >= Ada_2012
+ and then Is_Container_Iterator (Iter)
+ and then not Is_Wrapped_In_Block (N)
+ then
+ Rewrite (N,
+ Make_Block_Statement (Loc,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Relocate_Node (N)))));
+
+ Analyze (N);
+ return;
end if;
-- Kill current values on entry to loop, since statements in the body of
end;
end if;
- Analyze_Statements (Statements (Loop_Statement));
+ Analyze_Statements (Statements (N));
end if;
-- Finish up processing for the loop. We kill all current values, since
-- know will execute at least once, but it's not worth the trouble and
-- the front end is not in the business of flow tracing.
- Process_End_Label (Loop_Statement, 'e', Ent);
+ Process_End_Label (N, 'e', Ent);
End_Scope;
Kill_Current_Values;
end if;
end Check_Unreachable_Code;
+ -----------------------
+ -- Pre_Analyze_Range --
+ -----------------------
+
+ procedure Pre_Analyze_Range (R_Copy : Node_Id) is
+ Save_Analysis : constant Boolean := Full_Analysis;
+
+ begin
+ Full_Analysis := False;
+ Expander_Mode_Save_And_Set (False);
+
+ Analyze (R_Copy);
+
+ if Nkind (R_Copy) in N_Subexpr
+ and then Is_Overloaded (R_Copy)
+ then
+ -- Apply preference rules for range of predefined integer types, or
+ -- diagnose true ambiguity.
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Found : Entity_Id := Empty;
+
+ begin
+ Get_First_Interp (R_Copy, I, It);
+ while Present (It.Typ) loop
+ if Is_Discrete_Type (It.Typ) then
+ if No (Found) then
+ Found := It.Typ;
+ else
+ if Scope (Found) = Standard_Standard then
+ null;
+
+ elsif Scope (It.Typ) = Standard_Standard then
+ Found := It.Typ;
+
+ else
+ -- Both of them are user-defined
+
+ Error_Msg_N
+ ("ambiguous bounds in range of iteration", R_Copy);
+ Error_Msg_N ("\possible interpretations:", R_Copy);
+ Error_Msg_NE ("\\} ", R_Copy, Found);
+ Error_Msg_NE ("\\} ", R_Copy, It.Typ);
+ exit;
+ end if;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ -- Subtype mark in iteration scheme
+
+ if Is_Entity_Name (R_Copy)
+ and then Is_Type (Entity (R_Copy))
+ then
+ null;
+
+ -- Expression in range, or Ada 2012 iterator
+
+ elsif Nkind (R_Copy) in N_Subexpr then
+ Resolve (R_Copy);
+ end if;
+
+ Expander_Mode_Restore;
+ Full_Analysis := Save_Analysis;
+ end Pre_Analyze_Range;
+
end Sem_Ch5;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
("?redundant renaming, entity is directly visible", Name (N));
end if;
+ -- Implementation-defined aspect specifications can appear in a renaming
+ -- declaration, but not language-defined ones.
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, New_S);
+ end if;
+
Ada_Version := Save_AV;
Ada_Version_Explicit := Save_AV_Exp;
end Analyze_Subprogram_Renaming;
-- Note: originally this check was not performed here, but in that
-- case the check happens deep in the expander, and the message is
-- posted at the wrong location, and omitted in -gnatc mode.
+ -- If the type of the entry index is a generic formal, no check
+ -- is possible. In an instance, the check is not static and a run-
+ -- time exception will be raised if the bounds are unreasonable.
declare
PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
UBR : Node_Id;
begin
- if Nkind (D_Sdef) = N_Range then
+ if Is_Generic_Type (Etype (D_Sdef))
+ or else In_Instance
+ then
+ goto Skip_LB;
+
+ elsif Nkind (D_Sdef) = N_Range then
LBR := Low_Bound (D_Sdef);
+
elsif Is_Entity_Name (D_Sdef)
and then Is_Type (Entity (D_Sdef))
then
LBR := Type_Low_Bound (Entity (D_Sdef));
+
else
goto Skip_LB;
end if;
end if;
<<Skip_LB>>
- if Nkind (D_Sdef) = N_Range then
+ if Is_Generic_Type (Etype (D_Sdef))
+ or else In_Instance
+ then
+ goto Skip_UB;
+
+ elsif Nkind (D_Sdef) = N_Range then
UBR := High_Bound (D_Sdef);
+
elsif Is_Entity_Name (D_Sdef)
and then Is_Type (Entity (D_Sdef))
then
UBR := Type_High_Bound (Entity (D_Sdef));
+
else
goto Skip_UB;
end if;
-- of the directory specified in the project file. If the subdirectory
-- does not exist, it is created automatically.
+ S_Pretty_Types : aliased constant S := "/TYPE_CASING=" &
+ "AS_DECLARED " &
+ "-ntD " &
+ "LOWER_CASE " &
+ "-ntL " &
+ "UPPER_CASE " &
+ "-ntU " &
+ "MIXED_CASE " &
+ "-ntM";
+ -- /TYPE_CASING=name-option
+ --
+ -- Specify the casing of type and subtype. If not specified, the
+ -- casing of these names is defined by the NAME_CASING option.
+ -- 'name-option' may be one of:
+ --
+ -- AS_DECLARED Name casing for defining occurrences are
+ -- as they appear in the source file.
+ --
+ -- LOWER_CASE Namess are in lower case.
+ --
+ -- UPPER_CASE Namess are in upper case.
+ --
+ -- MIXED_CASE Namess are in mixed case.
+
S_Pretty_Verbose : aliased constant S := "/VERBOSE " &
"-v";
-- /NOVERBOSE (D)
S_Pretty_Stnm_On_Nw_Line 'Access,
S_Pretty_Specific 'Access,
S_Pretty_Standard 'Access,
+ S_Pretty_Types 'Access,
S_Pretty_Verbose 'Access,
S_Pretty_Warnings 'Access);
git://gcc.gnu.org / gcc.git / commitdiff