THis patch fixes an omission in the handling of iterators over containers.
The code now handles properly an iterator type that is a subtype of the
type obtained from an instantiation of the predefined iterator interfaces.
Compiling and executing main.adb must yield:
Element_T.F: 42
Element_T.F: 42
Element_T.F: 42
Element_T.F: 42
Element_T.F: 42
Element_T.F: 42
Element_T.F: 42
Element_T.F: 42
V.Element (C).F: 42
V.Element (C).F: 42
V.Element (C).F: 42
V.Element (C).F: 42
---
with Ada.Text_Io; use Ada.Text_Io;
with Containers;
procedure Main is
type Index is range 1 .. 4;
type Element_T is
record
F : Integer := 42;
end record;
package Vectors is new Containers.Vectors (Index, Element_T);
V : Vectors.Vector;
begin
for E of V loop
Put_Line ("Element_T.F:" & Integer'Image (E.F));
end loop;
for E of reverse V loop
Put_Line ("Element_T.F:" & Integer'Image (E.F));
end loop;
for C in V.Iterate loop
Put_Line ("V.Element (C).F:" & Integer'Image (V.Element (C).F));
end loop;
end Main;
---
with Ada.Iterator_Interfaces;
package Containers is
generic
type Index is (<>);
type Element_T is private;
package Vectors is
type Vector is tagged private
with
Constant_Indexing => Constant_Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_T;
type Cursor is private;
function Has_Element (Position : Cursor) return Boolean;
function Element (Container : in Vector; Position : Cursor)
return Element_T;
package Vector_Iterator_Interfaces is
new Ada.Iterator_Interfaces (Cursor, Has_Element);
subtype Iterator_Class is
Vector_Iterator_Interfaces.Reversible_Iterator'Class;
function Iterate (Container : in Vector) return Iterator_Class;
function Iterate (Container : in Vector; Start : in Cursor)
return Iterator_Class;
type Constant_Reference_Type
(Element : not null access constant Element_T) is private
with Implicit_Dereference => Element;
function Constant_Reference
(Container : aliased in Vector;
Position : in Cursor)
return Constant_Reference_Type;
private
type Rep is array (Index) of aliased Element_T;
type Vector is tagged
record
A : aliased Rep;
end record;
type Cursor (Going : Boolean := False) is
record
case Going is
when False =>
null;
when True =>
I : Index;
end case;
end record;
type Constant_Reference_Type
(Element : not null access constant Element_T) is
record
null;
end record;
type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with
record
C : Cursor;
end record;
function First (Object : Iterator) return Cursor;
function Next (Object : Iterator; Position : Cursor) return Cursor;
function Last (Object : Iterator) return Cursor;
function Previous (Object : Iterator; Position : Cursor) return Cursor;
end Vectors;
end Containers;
---
package body Containers is
package body Vectors is
function Has_Element (Position : Cursor) return Boolean is
begin
return Position.Going;
end Has_Element;
function Element (Container : in Vector; Position : Cursor)
return Element_T is
begin
return Container.A (Position.I);
end Element;
function Iterate (Container : in Vector) return Iterator_Class is
begin
return Iterator_Class
(Iterator'(C => (Going => True, I => Index'First)));
end Iterate;
function Iterate (Container : in Vector; Start: in Cursor)
return Iterator_Class is
begin
return Iterator_Class (Iterator'(C => Start));
end Iterate;
function Constant_Reference
(Container : aliased in Vector;
Position : in Cursor)
return Constant_Reference_Type is
begin
return (Element => Container.A (Position.I)'Access);
end Constant_Reference;
function First (Object : Iterator) return Cursor is
begin
return (Going => True, I => Index'First);
end First;
function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.I /= Index'Last then
return (Going => True, I => Index'Succ (Position.I));
else
return (Going => False);
end if;
end Next;
function Last (Object : Iterator) return Cursor is
begin
return (Going => True, I => Index'Last);
end Last;
function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.I /= Index'First then
return (Going => True, I => Index'Pred (Position.I));
else
return (Going => False);
end if;
end Previous;
end Vectors;
end Containers;
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-10-23 Ed Schonberg <schonb...@adacore.com>
* sem_util.adb (Is_Iterator, Is_Reversible_iterator): Use
root type to determine whether the type is a descendant of the
corresponding interface type, so take into account multiple
levels of subtypes and derivations.
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 229238)
+++ sem_util.adb (working copy)
@@ -12119,12 +12119,16 @@
Iface : Entity_Id;
begin
+ -- The type may be a subtype of a descendant of the proper instance of
+ -- the predefined interface type, so we must use the root type of the
+ -- given type. The same us done for Is_Reversible_Iterator.
+
if Is_Class_Wide_Type (Typ)
- and then Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
+ and then Nam_In (Chars (Root_Type (Typ)), Name_Forward_Iterator,
Name_Reversible_Iterator)
and then
Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
+ (Unit_File_Name (Get_Source_Unit (Root_Type (Typ))))
then
return True;
@@ -13009,9 +13013,9 @@
begin
if Is_Class_Wide_Type (Typ)
- and then Chars (Etype (Typ)) = Name_Reversible_Iterator
+ and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator
and then Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
+ (Unit_File_Name (Get_Source_Unit (Root_Type (Typ))))
then
return True;
