This patch fixes the handling of overloaded indexing operations that are
inherited by a type derived from one that carries an indexing aspect.
Source:
---
with Ada.Text_Io; use Ada.Text_Io;
with References;
procedure Main is
A : aliased References.Iterated;
begin
A (1) := 42;
Put_Line ("A (1)" & References.Object_T'Image (A (1)));
Put_Line ("A (1, 1)" & References.Object_T'Image (A (1, 1)));
end Main;
---
package body References is
function Find (I : aliased in out Indexed; Key : Index) return Reference_T
is
begin
return (Object => I.Rep (Key)'Access);
end Find;
function Find (I : aliased in out Indexed; Key1, Key2 : Index)
return Reference_T
is
begin
return (Object => I.Rep (Key1)'Access);
end Find;
function Find (I : aliased in out Iterated; C : Cursor) return Reference_T
is
begin
return (Object => I.Rep (C.I)'Access);
end Find;
function Has_Element (Position : Cursor) return Boolean is
begin
return Position.Has_Element;
end Has_Element;
function First (Object : Iterator) return Cursor is
Has_Elements : constant Boolean := Object.First <= Object.Last;
begin
if Has_Elements then
return (Has_Element => True, I => Object.First);
else
return (Has_Element => False);
end if;
end First;
function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Has_Element and then Position.I /= Index'Last then
return (Has_Element => True, I => Position.I + 1);
else
return (Has_Element => False);
end if;
end Next;
function Last (Object : Iterator) return Cursor is
Has_Elements : constant Boolean := Object.First <= Object.Last;
begin
if Has_Elements then
return (Has_Element => True, I => Object.Last);
else
return (Has_Element => False);
end if;
end Last;
function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Has_Element and then Position.I /= Index'First then
return (Has_Element => True, I => Position.I - 1);
else
return (Has_Element => False);
end if;
end Previous;
function Iterate (Container : Iterated)
return Iterators.Reversible_Iterator'Class
is
begin
return Iterator'(First => Container.Rep'First, Last => Container.Rep'Last);
end Iterate;
end References;
---
with Ada.Iterator_Interfaces;
package References is
type Object_T is new Integer;
type Reference_T (Object : not null access Object_T) is private
with Implicit_Dereference => Object;
type Index is range 1 .. 2;
type Array_T is array (Index) of aliased Object_T;
type Cursor is private;
type Indexed is tagged
record
Rep : Array_T;
end record
with Variable_Indexing => Find;
function Find (I : aliased in out Indexed; Key : Index) return Reference_T;
function Find (I : aliased in out Indexed; Key1, Key2 : Index)
return Reference_T;
function Has_Element (Position : Cursor) return Boolean;
package Iterators is new Ada.Iterator_Interfaces (Cursor, Has_Element);
type Iterator is new Iterators.Reversible_Iterator with
record
First : Index;
Last : Index;
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;
type Iterated is new Indexed with null record with
Default_Iterator => Iterate,
Iterator_Element => Object_T;
function Find (I : aliased in out Iterated; C : Cursor) return Reference_T;
function Iterate
(Container : Iterated)
return Iterators.Reversible_Iterator'Class;
private
type Reference_T (Object : not null access Object_T) is null record;
type Cursor (Has_Element : Boolean := False) is
record
case Has_Element is
when True =>
I : Index;
when False =>
null;
end case;
end record;
end References;
---
Command:
gnatmake -q main
main
---
Output:
A (1) 42
A (1, 1) 42
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-10-26 Ed Schonberg <schonb...@adacore.com>
* exp_util.ads, exp_util.adb (Find_Primitive_Operations): New
subprogram to retrieve by name the possibly overloaded set of
primitive operations of a type.
* sem_ch4.adb (Try_Container_Indexing): Use
Find_Primitive_Operations to handle overloaded indexing operations
of a derived type.
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 229313)
+++ exp_util.adb (working copy)
@@ -2707,6 +2707,50 @@
end if;
end Find_Optional_Prim_Op;
+ -------------------------------
+ -- Find_Primitive_Operations --
+ -------------------------------
+
+ function Find_Primitive_Operations
+ (T : Entity_Id;
+ Name : Name_Id) return Node_Id
+ is
+ Prim_Elmt : Elmt_Id;
+ Prim_Id : Entity_Id;
+ Ref : Node_Id;
+ Typ : Entity_Id := T;
+
+ begin
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ := Underlying_Type (Typ);
+
+ Ref := Empty;
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim_Id := Node (Prim_Elmt);
+ if Chars (Prim_Id) = Name then
+
+ -- If this is the first primitive operation found,
+ -- create a reference to it.
+
+ if No (Ref) then
+ Ref := New_Occurrence_Of (Prim_Id, Sloc (T));
+
+ -- Otherwise, add interpretation to existing reference
+
+ else
+ Add_One_Interp (Ref, Prim_Id, Etype (Prim_Id));
+ end if;
+ end if;
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ return Ref;
+ end Find_Primitive_Operations;
+
------------------
-- Find_Prim_Op --
------------------
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 229313)
+++ exp_util.ads (working copy)
@@ -467,6 +467,13 @@
-- Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-- return the record component containing the tag of Iface.
+ function Find_Primitive_Operations
+ (T : Entity_Id;
+ Name : Name_Id) return Node_Id;
+ -- Return a reference to a primitive operation with given name. If
+ -- operation is overloaded, the node carries the corresponding set
+ -- of overloaded interpretations.
+
function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
-- Find the first primitive operation of a tagged type T with name Name.
-- This function allows the use of a primitive operation which is not
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 229331)
+++ sem_ch4.adb (working copy)
@@ -7215,20 +7215,17 @@
-- However, Reference is also a primitive operation of the type, and
-- the inherited operation has a different signature. We retrieve the
- -- right one from the list of primitive operations of the derived type.
+ -- right ones (the function may be overloaded) from the list of
+ -- primitive operations of the derived type.
-- Note that predefined containers are typically all derived from one
-- of the Controlled types. The code below is motivated by containers
-- that are derived from other types with a Reference aspect.
- -- Additional machinery may be needed for types that have several user-
- -- defined Reference operations with different signatures ???
-
elsif Is_Derived_Type (C_Type)
and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix)
then
- Func := Find_Prim_Op (C_Type, Chars (Func_Name));
- Func_Name := New_Occurrence_Of (Func, Loc);
+ Func_Name := Find_Primitive_Operations (C_Type, Chars (Func_Name));
end if;
Assoc := New_List (Relocate_Node (Prefix));
