From patchwork Mon Oct 26 11:51:53 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 535881 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 0214B1412FD for ; Mon, 26 Oct 2015 22:52:05 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=Xi0mZJlj; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=Q9dcHRsHcvy1XUBdxl5rMxee36qaVU4O5PGgd3AysZFwZCtT2U QE1LM59koExyW3bGdhMsXJP2WCsSO78nnJymGQhMyY7QKAAmBQ8SqPHeo70a2b2u gwHU7mslQjmTcqAqhDl14Lz94X2Hz4mpSdIyKD2tfSD5KyG+o/ILAysp8= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=8l1lH8KEo49jOq1aUmJIt4L0h3k=; b=Xi0mZJljBPKDfMPzipji 2eKMBIwiQcQS+RLE1o07kqSxl97kOwFUUI1dbU63q+OLkuA540sKQVKJTPpjo3Ta fMHuDjEUZmnckKC400VBgndDD9jw7Ro9/g5CLWAykL+qh2L/VLcqpRD4sbxhvHAC Bxjphm/fq5HIcxKH1rlfS5o= Received: (qmail 130684 invoked by alias); 26 Oct 2015 11:51:57 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 130674 invoked by uid 89); 26 Oct 2015 11:51:56 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.2 required=5.0 tests=AWL, BAYES_50, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY, RCVD_IN_DNSWL_LOW autolearn=no version=3.3.2 X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Mon, 26 Oct 2015 11:51:55 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id B122E11823F; Mon, 26 Oct 2015 07:51:53 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id jYweiyR25v-V; Mon, 26 Oct 2015 07:51:53 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 9D7F911823B; Mon, 26 Oct 2015 07:51:53 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 9946418F; Mon, 26 Oct 2015 07:51:53 -0400 (EDT) Date: Mon, 26 Oct 2015 07:51:53 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Overloaded indexing operations of a derived type Message-ID: <20151026115153.GA103952@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) 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 * 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));