+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_Iterator_Loop): Handle properly a loop over a
+ container of a derived type.
+
+2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * impunit.adb, s-stposu.adb, s-stposu.ads, exp_ch4.adb, s-finmas.adb,
+ s-finmas.ads: Revert previous change.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads,
+ a-ciorse.adb, a-ciorse.ads: Add iterator machinery to containers.
+
2011-08-29 Pascal Obry <obry@adacore.com>
* exp_disp.adb: Minor comment fix.
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+ type Iterator is new
+ List_Iterator_Interfaces.Reversible_Iterator with record
+ Container : List_Access;
+ Node : Node_Access;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
+ overriding function Next (Object : Iterator; Position : Cursor)
+ return Cursor;
+ overriding function Previous (Object : Iterator; Position : Cursor)
+ return Cursor;
+
-----------------------
-- Local Subprograms --
-----------------------
return Cursor'(Container'Unchecked_Access, Container.First);
end First;
+ function First (Object : Iterator) return Cursor is
+ begin
+ return Cursor'(Object.Container, Object.Container.First);
+ end First;
+
-------------------
-- First_Element --
-------------------
B := B - 1;
end Iterate;
+ function Iterate (Container : List)
+ return List_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator := (Container'Unchecked_Access, Container.First);
+ begin
+ return It;
+ end Iterate;
+
+ function Iterate (Container : List; Start : Cursor)
+ return List_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator := (Container'Unchecked_Access, Start.Node);
+ begin
+ return It;
+ end Iterate;
+
----------
-- Last --
----------
return Cursor'(Container'Unchecked_Access, Container.Last);
end Last;
+ function Last (Object : Iterator) return Cursor is
+ begin
+ if Object.Container.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Object.Container, Object.Container.Last);
+ end Last;
+
------------------
-- Last_Element --
------------------
end;
end Next;
+ function Next (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Node = Object.Container.Last then
+ return No_Element;
+
+ else
+ return (Object.Container, Position.Node.Next);
+ end if;
+ end Next;
+
-------------
-- Prepend --
-------------
end;
end Previous;
+ function Previous (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Node = Position.Container.First then
+ return No_Element;
+
+ else
+ return (Object.Container, Position.Node.Prev);
+ end if;
+ end Previous;
+
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream list cursor";
end Read;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Constant_Reference (Container : List; Position : Cursor)
+ return Constant_Reference_Type is
+ begin
+ pragma Unreferenced (Container);
+
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element => Position.Node.Element.all'Access);
+ end Constant_Reference;
+
+ function Reference (Container : List; Position : Cursor)
+ return Reference_Type is
+ begin
+ pragma Unreferenced (Container);
+
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element => Position.Node.Element.all'Access);
+ end Reference;
+
---------------------
-- Replace_Element --
---------------------
raise Program_Error with "attempt to stream list cursor";
end Write;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
end Ada.Containers.Indefinite_Doubly_Linked_Lists;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Iterator_Interfaces;
+with Ada.Streams; use Ada.Streams;
private with Ada.Finalization;
-private with Ada.Streams;
generic
type Element_Type (<>) is private;
pragma Preelaborate;
pragma Remote_Types;
- type List is tagged private;
+ type List is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
pragma Preelaborable_Initialization (List);
type Cursor is private;
Empty_List : constant List;
No_Element : constant Cursor;
+ function Has_Element (Position : Cursor) return Boolean;
+
+ package List_Iterator_Interfaces is new
+ Ada.Iterator_Interfaces (Cursor, Has_Element);
function "=" (Left, Right : List) return Boolean;
(Container : List;
Item : Element_Type) return Boolean;
- function Has_Element (Position : Cursor) return Boolean;
-
procedure Iterate
(Container : List;
Process : not null access procedure (Position : Cursor));
(Container : List;
Process : not null access procedure (Position : Cursor));
+ function Iterate (Container : List)
+ return List_Iterator_Interfaces.Reversible_Iterator'class;
+
+ function Iterate (Container : List; Start : Cursor)
+ return List_Iterator_Interfaces.Reversible_Iterator'class;
+
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ type Reference_Type (Element : not null access Element_Type) is
+ private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ function Constant_Reference
+ (Container : List; Position : Cursor) -- SHOULD BE ALIASED
+ return Constant_Reference_Type;
+
+ function Reference
+ (Container : List; Position : Cursor) -- SHOULD BE ALIASED
+ return Reference_Type;
+
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
Lock : Natural := 0;
end record;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
+
overriding procedure Adjust (Container : in out List);
overriding procedure Finalize (Container : in out List) renames Clear;
- use Ada.Streams;
-
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out List);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Free_Element is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+ type Iterator is new
+ Map_Iterator_Interfaces.Forward_Iterator with record
+ Container : Map_Access;
+ Node : Node_Access;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Next (Object : Iterator; Position : Cursor)
+ return Cursor;
+
-----------------------
-- Local Subprograms --
-----------------------
return Cursor'(Container'Unchecked_Access, Node);
end First;
+ function First (Object : Iterator) return Cursor is
+ M : constant Map_Access := Object.Container;
+ N : constant Node_Access := HT_Ops.First (M.HT);
+ begin
+ if N = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Object.Container.all'Unchecked_Access, N);
+ end First;
+
----------
-- Free --
----------
B := B - 1;
end Iterate;
+ function Iterate (Container : Map)
+ return Map_Iterator_Interfaces.Forward_Iterator'class
+ is
+ Node : constant Node_Access := HT_Ops.First (Container.HT);
+ It : constant Iterator := (Container'Unrestricted_Access, Node);
+ begin
+ return It;
+ end Iterate;
+
---------
-- Key --
---------
end;
end Next;
+ function Next (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ return No_Element;
+
+ else
+ return (Object.Container, Next (Position).Node);
+ end if;
+ end Next;
+
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream map cursor";
end Read;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
---------------
-- Read_Node --
---------------
return Node;
end Read_Node;
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Constant_Reference (Container : Map; Key : Key_Type)
+ return Constant_Reference_Type is
+ begin
+ return (Element =>
+ Container.Find (Key).Node.Element.all'Unrestricted_Access);
+ end Constant_Reference;
+
+ function Reference (Container : Map; Key : Key_Type)
+ return Reference_Type is
+ begin
+ return (Element =>
+ Container.Find (Key).Node.Element.all'Unrestricted_Access);
+ end Reference;
+
-------------
-- Replace --
-------------
raise Program_Error with "attempt to stream map cursor";
end Write;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
----------------
-- Write_Node --
----------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
------------------------------------------------------------------------------
private with Ada.Containers.Hash_Tables;
-private with Ada.Streams;
private with Ada.Finalization;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
generic
type Key_Type (<>) is private;
pragma Preelaborate;
pragma Remote_Types;
- type Map is tagged private;
+ type Map is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
pragma Preelaborable_Initialization (Map);
type Cursor is private;
-- Cursor objects declared without an initialization expression are
-- initialized to the value No_Element.
+ function Has_Element (Position : Cursor) return Boolean;
+ -- Equivalent to Position /= No_Element
+
+ package Map_Iterator_Interfaces is new
+ Ada.Iterator_Interfaces (Cursor, Has_Element);
+
overriding function "=" (Left, Right : Map) return Boolean;
-- For each key/element pair in Left, equality attempts to find the key in
-- Right; if a search fails the equality returns False. The search works by
function Element (Container : Map; Key : Key_Type) return Element_Type;
-- Equivalent to Element (Find (Container, Key))
- function Has_Element (Position : Cursor) return Boolean;
- -- Equivalent to Position /= No_Element
-
function Equivalent_Keys (Left, Right : Cursor) return Boolean;
-- Returns the result of calling Equivalent_Keys with the keys of the nodes
-- designated by cursors Left and Right.
-- Returns the result of calling Equivalent_Keys with key Left and the node
-- designated by Right.
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ type Reference_Type (Element : not null access Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ function Constant_Reference
+ (Container : Map; Key : Key_Type) -- SHOULD BE ALIASED
+ return Constant_Reference_Type;
+
+ function Reference (Container : Map; Key : Key_Type)
+ return Reference_Type;
+
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
-- Calls Process for each node in the map
+ function Iterate (Container : Map)
+ return Map_Iterator_Interfaces.Forward_Iterator'class;
+
private
pragma Inline ("=");
pragma Inline (Length);
use HT_Types;
use Ada.Finalization;
- use Ada.Streams;
overriding procedure Adjust (Container : in out Map);
for Cursor'Write use Write;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
+
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
package body Ada.Containers.Indefinite_Ordered_Sets is
+ type Iterator is new
+ Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record
+ Container : access constant Set;
+ Node : Node_Access;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
+ overriding function Next (Object : Iterator; Position : Cursor)
+ return Cursor;
+ overriding function Previous (Object : Iterator; Position : Cursor)
+ return Cursor;
+
-----------------------
-- Local Subprograms --
-----------------------
return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end First;
+ function First (Object : Iterator) return Cursor is
+ begin
+ return Cursor'(
+ Object.Container.all'Unrestricted_Access, Object.Container.Tree.First);
+ end First;
+
-------------------
-- First_Element --
-------------------
B := B - 1;
end Iterate;
+ function Iterate (Container : Set)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator :=
+ (Container'Unchecked_Access, Container.Tree.First);
+ begin
+ return It;
+ end Iterate;
+
+ function Iterate (Container : Set; Start : Cursor)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator := (Container'Unchecked_Access, Start.Node);
+ begin
+ return It;
+ end Iterate;
+
----------
-- Last --
----------
return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
+ function Last (Object : Iterator) return Cursor is
+ begin
+ if Object.Container.Tree.Last = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(
+ Object.Container.all'Unrestricted_Access, Object.Container.Tree.Last);
+ end Last;
+
------------------
-- Last_Element --
------------------
end;
end Next;
+ function Next (Object : Iterator; Position : Cursor)
+ return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return Next (Position);
+ end Next;
+
-------------
-- Overlap --
-------------
end;
end Previous;
+ function Previous (Object : Iterator; Position : Cursor)
+ return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return Previous (Position);
+ end Previous;
+
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream set cursor";
end Read;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Constant_Reference (Container : Set; Position : Cursor)
+ return Constant_Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element => Position.Node.Element.all'Access);
+ end Constant_Reference;
+
+ function Reference (Container : Set; Position : Cursor)
+ return Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element => Position.Node.Element.all'Access);
+ end Reference;
+
-------------
-- Replace --
-------------
raise Program_Error with "attempt to stream set cursor";
end Write;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
end Ada.Containers.Indefinite_Ordered_Sets;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
-private with Ada.Streams;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
generic
type Element_Type (<>) is private;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
- type Set is tagged private;
+ type Set is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
pragma Preelaborable_Initialization (Set);
type Cursor is private;
Empty_Set : constant Set;
No_Element : constant Cursor;
+ function Has_Element (Position : Cursor) return Boolean;
+
+ package Ordered_Set_Iterator_Interfaces is new
+ Ada.Iterator_Interfaces (Cursor, Has_Element);
+
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is
+ private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ function Constant_Reference
+ (Container : Set; Position : Cursor)
+ return Constant_Reference_Type;
+
+ type Reference_Type (Element : not null access Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ function Reference
+ (Container : Set; Position : Cursor)
+ return Reference_Type;
function "=" (Left, Right : Set) return Boolean;
function Contains (Container : Set; Item : Element_Type) return Boolean;
- function Has_Element (Position : Cursor) return Boolean;
-
function "<" (Left, Right : Cursor) return Boolean;
function ">" (Left, Right : Cursor) return Boolean;
(Container : Set;
Process : not null access procedure (Position : Cursor));
+ function Iterate (Container : Set)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
+
+ function Iterate (Container : Set; Start : Cursor)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
+
generic
type Key_Type (<>) is private;
use Red_Black_Trees;
use Tree_Types;
use Ada.Finalization;
- use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
for Set'Read use Read;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
+
Empty_Set : constant Set :=
(Controlled with Tree => (First => null,
Last => null,
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
else
- Build_Allocate_Deallocate_Proc (N, True);
-
-- If we have:
-- type A is access T1;
-- X : A := new T2'(...);
if Of_Present (I_Spec) then
declare
- Default_Iter : constant Entity_Id :=
- Find_Aspect (Etype (Container), Aspect_Default_Iterator);
- Ent : Entity_Id;
+ Default_Iter : constant Entity_Id :=
+ Entity (
+ Find_Aspect
+ (Etype (Container), Aspect_Default_Iterator));
+ Container_Arg : Node_Id;
+ Ent : Entity_Id;
begin
Cursor := Make_Temporary (Loc, 'I');
null;
else
- Iter_Type :=
- Etype
- (Find_Aspect
- (Etype (Container), Aspect_Default_Iterator));
+ Iter_Type := Etype (Default_Iter);
-- Rewrite domain of iteration as a call to the default
- -- iterator for the container type.
+ -- iterator for the container type. If the container is
+ -- a derived type and the aspect is inherited, convert
+ -- container to parent type. The Cursor type is also
+ -- inherited from the scope of the parent.
+
+ if Base_Type (Etype (Container)) =
+ Base_Type (Etype (First_Formal (Default_Iter)))
+ then
+ Container_Arg := New_Copy_Tree (Container);
+
+ else
+ Pack := Scope (Default_Iter);
+
+ Container_Arg :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (
+ Etype (First_Formal (Default_Iter)), Loc),
+ Expression => New_Copy_Tree (Container));
+ end if;
Rewrite (Name (I_Spec),
Make_Function_Call (Loc,
- Name => Default_Iter,
+ Name => New_Occurrence_Of (Default_Iter, Loc),
Parameter_Associations =>
- New_List (Relocate_Node (Name (I_Spec)))));
+ New_List (Container_Arg)));
Analyze_And_Resolve (Name (I_Spec));
end if;
- -- Find cursor type in container package.
+ -- Find cursor type in proper container package.
Ent := First_Entity (Pack);
while Present (Ent) loop
"s-addima", -- System.Address_Image
"s-assert", -- System.Assertions
+ "s-finmas", -- System.Finalization_Masters
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
"s-pooglo", -- System.Pool_Global
-- GNAT Defined Additions to Ada 20012 --
-----------------------------------------
+ "s-spsufi", -- System.Storage_Pools.Subpools.Finalization
"a-cofove", -- Ada.Containers.Formal_Vectors
"a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists
"a-cforse", -- Ada.Containers.Formal_Ordered_Sets
with Ada.Exceptions; use Ada.Exceptions;
with System.Address_Image;
-with System.HTable; use System.HTable;
with System.IO; use System.IO;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
package body System.Finalization_Masters is
- -- Finalize_Address hash table types. In general, masters are homogeneous
- -- collections of controlled objects. Rare cases such as allocations on a
- -- subpool require heterogeneous masters. The following table provides a
- -- relation between object address and its Finalize_Address routine.
-
- type Header_Num is range 0 .. 127;
-
- function Hash (Key : System.Address) return Header_Num;
-
- -- Address --> Finalize_Address_Ptr
-
- package Finalize_Address_Table is new Simple_HTable
- (Header_Num => Header_Num,
- Element => Finalize_Address_Ptr,
- No_Element => null,
- Key => System.Address,
- Hash => Hash,
- Equal => "=");
-
---------------------------
-- Add_Offset_To_Address --
---------------------------
return Master.Base_Pool;
end Base_Pool;
- -----------------------------
- -- Delete_Finalize_Address --
- -----------------------------
-
- procedure Delete_Finalize_Address (Obj : System.Address) is
- begin
- Lock_Task.all;
- Finalize_Address_Table.Remove (Obj);
- Unlock_Task.all;
- end Delete_Finalize_Address;
-
------------
-- Detach --
------------
N.Next := null;
Unlock_Task.all;
-
- -- Note: No need to unlock in case of an exception because the above
- -- code can never raise one.
end if;
+
+ -- Note: No need to unlock in case of an exception because the above
+ -- code can never raise one.
end Detach;
--------------
--------------
overriding procedure Finalize (Master : in out Finalization_Master) is
- Cleanup : Finalize_Address_Ptr;
Curr_Ptr : FM_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Obj_Addr : Address;
Detach (Curr_Ptr);
- -- Skip the list header in order to offer proper object layout for
- -- finalization.
-
- Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
-
- -- Retrieve TSS primitive Finalize_Address depending on the master's
- -- mode of operation.
-
- if Master.Is_Homogeneous then
- Cleanup := Master.Finalize_Address;
- else
- Cleanup := Get_Finalize_Address (Obj_Addr);
- end if;
-
- -- If Finalize_Address is not available, then this is most likely an
- -- error in the expansion of the designated type or the allocator.
-
- pragma Assert (Cleanup /= null);
+ if Master.Finalize_Address /= null then
- begin
- Cleanup (Obj_Addr);
+ -- Skip the list header in order to offer proper object layout for
+ -- finalization and call Finalize_Address.
- exception
- when Fin_Occur : others =>
- if not Raised then
- Raised := True;
- Save_Occurrence (Ex_Occur, Fin_Occur);
- end if;
- end;
+ Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
- -- When the master is a heterogeneous collection, destroy the object
- -- - Finalize_Address pair since it is no longer needed.
+ begin
+ Master.Finalize_Address (Obj_Addr);
- if not Master.Is_Homogeneous then
- Delete_Finalize_Address (Obj_Addr);
+ exception
+ when Fin_Occur : others =>
+ if not Raised then
+ Raised := True;
+ Save_Occurrence (Ex_Occur, Fin_Occur);
+ end if;
+ end;
end if;
end loop;
end if;
end Finalize;
- --------------------------
- -- Get_Finalize_Address --
- --------------------------
-
- function Get_Finalize_Address
- (Obj : System.Address) return Finalize_Address_Ptr
- is
- Result : Finalize_Address_Ptr;
-
- begin
- Lock_Task.all;
- Result := Finalize_Address_Table.Get (Obj);
- Unlock_Task.all;
-
- return Result;
- end Get_Finalize_Address;
-
-----------------
-- Header_Size --
-----------------
return FM_Node'Size / Storage_Unit;
end Header_Size;
- ----------
- -- Hash --
- ----------
-
- function Hash (Key : System.Address) return Header_Num is
- begin
- return
- Header_Num
- (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
- end Hash;
-
-------------------
-- Header_Offset --
-------------------
Master.Objects.Prev := Master.Objects'Unchecked_Access;
end Initialize;
- ------------------
- -- Print_Master --
- ------------------
+ --------
+ -- pm --
+ --------
- procedure Print_Master (Master : Finalization_Master) is
+ procedure pm (Master : Finalization_Master) is
Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
Head_Seen : Boolean := False;
N_Ptr : FM_Node_Ptr;
-- Output the basic contents of a master
-- Master : 0x123456789
- -- Is_Hmgen : TURE <or> FALSE
-- Base_Pool: null <or> 0x123456789
-- Fin_Addr : null <or> 0x123456789
-- Fin_Start: TRUE <or> FALSE
Put ("Master : ");
Put_Line (Address_Image (Master'Address));
- Put ("Is_Hmgen : ");
- Put_Line (Master.Is_Homogeneous'Img);
-
Put ("Base_Pool: ");
+
if Master.Base_Pool = null then
- Put_Line ("null");
+ Put_Line (" null");
else
Put_Line (Address_Image (Master.Base_Pool'Address));
end if;
Put ("Fin_Addr : ");
+
if Master.Finalize_Address = null then
Put_Line ("null");
else
-- Header - the address of the list header
-- Prev - the address of the list header which the current element
- -- points back to
+ -- - points back to
-- Next - the address of the list header which the current element
- -- points to
+ -- - points to
-- (dummy head) - present if dummy head
N_Ptr := Head;
- while N_Ptr /= null loop -- Should never be null
+ while N_Ptr /= null loop -- Should never be null; we being defensive
Put_Line ("V");
-- We see the head initially; we want to exit when we see the head a
- -- second time.
+ -- SECOND time.
if N_Ptr = Head then
exit when Head_Seen;
N_Ptr := N_Ptr.Next;
end loop;
- end Print_Master;
+ end pm;
-------------------
-- Set_Base_Pool --
Master.Finalize_Address := Fin_Addr_Ptr;
end Set_Finalize_Address;
- --------------------------
- -- Set_Finalize_Address --
- --------------------------
-
- procedure Set_Finalize_Address
- (Obj : System.Address;
- Fin_Addr_Ptr : Finalize_Address_Ptr)
- is
- begin
- Lock_Task.all;
- Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
- Unlock_Task.all;
- end Set_Finalize_Address;
-
end System.Finalization_Masters;
with Ada.Finalization;
with Ada.Unchecked_Conversion;
+
with System.Storage_Elements;
with System.Storage_Pools;
-- Finalization master type structure. A unique master is associated with
-- each access-to-controlled or access-to-class-wide type. Masters also act
- -- as components of subpools. By default, a master contains objects of the
- -- same designated type but it may also accomodate heterogeneous objects.
+ -- as components of subpools.
- type Finalization_Master (Is_Homogeneous : Boolean := True) is
+ type Finalization_Master is
new Ada.Finalization.Limited_Controlled with
record
Base_Pool : Any_Storage_Pool_Ptr := null;
-- objects allocated in a [sub]pool.
Finalize_Address : Finalize_Address_Ptr := null;
- -- A reference to the routine reponsible for object finalization. This
- -- is used only when the master is in homogeneous mode.
+ -- A reference to the routine reponsible for object finalization
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- Return a reference to the underlying storage pool on which the master
-- operates.
- procedure Delete_Finalize_Address (Obj : System.Address);
- -- Destroy the relation pair object - Finalize_Address from the internal
- -- hash table.
-
procedure Detach (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master
-- the list of allocated controlled objects, finalizing each one by calling
-- its specific Finalize_Address. In the end, deallocate the dummy head.
- function Get_Finalize_Address
- (Obj : System.Address) return Finalize_Address_Ptr;
- -- Retrieve the Finalize_Address primitive associated with a particular
- -- object.
-
function Header_Offset return System.Storage_Elements.Storage_Offset;
-- Return the size of type FM_Node as Storage_Offset
overriding procedure Initialize (Master : in out Finalization_Master);
-- Initialize the dummy head of a finalization master
- procedure Print_Master (Master : Finalization_Master);
+ procedure pm (Master : Finalization_Master);
-- Debug routine, outputs the contents of a master
procedure Set_Base_Pool
Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Set the clean up routine of a finalization master
- procedure Set_Finalize_Address
- (Obj : System.Address;
- Fin_Addr_Ptr : Finalize_Address_Ptr);
- -- Add a relation pair object - Finalize_Address to the internal hash table
-
end System.Finalization_Masters;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Deallocation;
-with System.Address_Image;
+
with System.Finalization_Masters; use System.Finalization_Masters;
-with System.IO; use System.IO;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
package body System.Storage_Pools.Subpools is
- Finalize_Address_Table_In_Use : Boolean := False;
- -- This flag should be set only when a successfull allocation on a subpool
- -- has been performed and the associated Finalize_Address has been added to
- -- the hash table in System.Finalization_Masters.
-
procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
-- Attach a subpool node to a pool
-- +- Header_And_Padding --+
N_Ptr := Address_To_FM_Node_Ptr
- (N_Addr + Header_And_Padding - Header_Offset);
+ (N_Addr + Header_And_Padding - Header_Offset);
-- Prepend the allocated object to the finalization master
Attach (N_Ptr, Master.Objects'Unchecked_Access);
+ if Master.Finalize_Address = null then
+ Master.Finalize_Address := Fin_Address;
+ end if;
+
-- Move the address from the hidden list header to the start of the
-- object. This operation effectively hides the list header.
Addr := N_Addr + Header_And_Padding;
- -- Subpool allocations use heterogeneous masters to manage various
- -- controlled objects. Associate a Finalize_Address with the object.
- -- This relation pair is deleted when the object is deallocated or
- -- when the associated master is finalized.
-
- if Is_Subpool_Allocation then
- pragma Assert (not Master.Is_Homogeneous);
-
- Set_Finalize_Address (Addr, Fin_Address);
- Finalize_Address_Table_In_Use := True;
-
- -- Normal allocations chain objects on homogeneous collections
-
- else
- pragma Assert (Master.Is_Homogeneous);
-
- if Master.Finalize_Address = null then
- Master.Finalize_Address := Fin_Address;
- end if;
- end if;
-
- -- Non-controlled allocation
-
else
Addr := N_Addr;
end if;
if Is_Controlled then
- -- Destroy the relation pair object - Finalize_Address since it is no
- -- longer needed.
-
- if Finalize_Address_Table_In_Use then
- Delete_Finalize_Address (Addr);
- end if;
-
-- Account for possible padding space before the header due to a
-- larger alignment.
N.Prev.Next := N.Next;
N.Next.Prev := N.Prev;
- N.Prev := null;
- N.Next := null;
Unlock_Task.all;
procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
Curr_Ptr : SP_Node_Ptr;
Ex_Occur : Exception_Occurrence;
+ Next_Ptr : SP_Node_Ptr;
Raised : Boolean := False;
- function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
- -- Determine whether a list contains only one element, the dummy head
-
- -------------------
- -- Is_Empty_List --
- -------------------
-
- function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
- begin
- return L.Next = L and then L.Prev = L;
- end Is_Empty_List;
-
- -- Start of processing for Finalize_Pool
-
begin
-- It is possible for multiple tasks to cause the finalization of a
-- common pool. Allow only one task to finalize the contents.
Pool.Finalization_Started := True;
- while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
- Curr_Ptr := Pool.Subpools.Next;
+ -- Skip the dummy head
+
+ Curr_Ptr := Pool.Subpools.Next;
+ while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
+ Next_Ptr := Curr_Ptr.Next;
-- Perform the following actions:
Save_Occurrence (Ex_Occur, Fin_Occur);
end if;
end;
+
+ Curr_Ptr := Next_Ptr;
end loop;
-- If the finalization of a particular master failed, reraise the
return Subpool.Owner;
end Pool_Of_Subpool;
- ----------------
- -- Print_Pool --
- ----------------
-
- procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
- Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
- Head_Seen : Boolean := False;
- SP_Ptr : SP_Node_Ptr;
-
- begin
- -- Output the contents of the pool
-
- -- Pool : 0x123456789
- -- Subpools : 0x123456789
- -- Fin_Start : TRUE <or> FALSE
- -- Controller: OK <or> NOK
-
- Put ("Pool : ");
- Put_Line (Address_Image (Pool'Address));
-
- Put ("Subpools : ");
- Put_Line (Address_Image (Pool.Subpools'Address));
-
- Put ("Fin_Start : ");
- Put_Line (Pool.Finalization_Started'Img);
-
- Put ("Controlled: ");
- if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
- Put_Line ("OK");
- else
- Put_Line ("NOK (ERROR)");
- end if;
-
- SP_Ptr := Head;
- while SP_Ptr /= null loop -- Should never be null
- Put_Line ("V");
-
- -- We see the head initially; we want to exit when we see the head a
- -- second time.
-
- if SP_Ptr = Head then
- exit when Head_Seen;
-
- Head_Seen := True;
- end if;
-
- -- The current element is null. This should never happend since the
- -- list is circular.
-
- if SP_Ptr.Prev = null then
- Put_Line ("null (ERROR)");
-
- -- The current element points back to the correct element
-
- elsif SP_Ptr.Prev.Next = SP_Ptr then
- Put_Line ("^");
-
- -- The current element points to an erroneous element
-
- else
- Put_Line ("? (ERROR)");
- end if;
-
- -- Output the contents of the node
-
- Put ("|Header: ");
- Put (Address_Image (SP_Ptr.all'Address));
- if SP_Ptr = Head then
- Put_Line (" (dummy head)");
- else
- Put_Line ("");
- end if;
-
- Put ("| Prev: ");
-
- if SP_Ptr.Prev = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
- end if;
-
- Put ("| Next: ");
-
- if SP_Ptr.Next = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (SP_Ptr.Next.all'Address));
- end if;
-
- Put ("| Subp: ");
-
- if SP_Ptr.Subpool = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
- end if;
-
- SP_Ptr := SP_Ptr.Next;
- end loop;
- end Print_Pool;
-
- -------------------
- -- Print_Subpool --
- -------------------
-
- procedure Print_Subpool (Subpool : Subpool_Handle) is
- begin
- if Subpool = null then
- Put_Line ("null");
- return;
- end if;
-
- -- Output the contents of a subpool
-
- -- Owner : 0x123456789
- -- Master: 0x123456789
- -- Node : 0x123456789
-
- Put ("Owner : ");
- if Subpool.Owner = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (Subpool.Owner'Address));
- end if;
-
- Put ("Master: ");
- Put_Line (Address_Image (Subpool.Master'Address));
-
- Put ("Node : ");
- if Subpool.Node = null then
- Put ("null");
-
- if Subpool.Owner = null then
- Put_Line (" OK");
- else
- Put_Line (" (ERROR)");
- end if;
- else
- Put_Line (Address_Image (Subpool.Node'Address));
- end if;
-
- Print_Master (Subpool.Master);
- end Print_Subpool;
-
-------------------------
-- Set_Pool_Of_Subpool --
-------------------------
------------------------------------------------------------------------------
with Ada.Finalization;
+
with System.Finalization_Masters;
with System.Storage_Elements;
Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
-- A reference to the master pool_with_subpools
- Master : aliased System.Finalization_Masters.Finalization_Master (False);
- -- A heterogeneous collection of controlled objects
+ Master : aliased System.Finalization_Masters.Finalization_Master;
+ -- A collection of controlled objects
Node : SP_Node_Ptr := null;
-- A link to the doubly linked list node which contains the subpool.
procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
-- Setup the doubly linked list of subpools
- procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools);
- -- Debug routine, output the contents of a pool_with_subpools
-
- procedure Print_Subpool (Subpool : Subpool_Handle);
- -- Debug routine, output the contents of a subpool
-
end System.Storage_Pools.Subpools;
OSDN Git Service
