From patchwork Mon Jul 23 08:20:12 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 172573 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]) by ozlabs.org (Postfix) with SMTP id 9AAD92C0302 for ; Mon, 23 Jul 2012 18:20:58 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1343636460; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=+xiKZYb6w5AykFmtqF3u aO/c01M=; b=p01T8+snv7/DVdxfYpOhBRAyd6pqaAMQxpjTM14w2fohRVVXoa5T +p4Y4icgNeMFmRqZPAaAlLUaypNRHi8XPt5ipDgKie0Cf9mCJz8rG93u7S0II8vu HRc0qtCl7ZffYBnJdLxDRdo8BAk44OohOvDuvYfoFCYzI0Tq2DlfHq0= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=OqbYLl+BxJxWC7aqeKKV8weOC1LUbLtZSHCZl2dH2uivUsKutYNfslGeZrWVRV 6uxrDI9989t43obmH16ZyV8SELelGzIKERmesOqII4ZMGb1iygamKaPQZZXaIR2G BTuydZcQio9korYQ+jnc9ptqiIOsh3T/b/xHHBgOqB/XQ=; Received: (qmail 32327 invoked by alias); 23 Jul 2012 08:20:36 -0000 Received: (qmail 32307 invoked by uid 22791); 23 Jul 2012 08:20:30 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 23 Jul 2012 08:20:16 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 6332B1C6BDE; Mon, 23 Jul 2012 04:20:12 -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 D+TPVMWMHBya; Mon, 23 Jul 2012 04:20:12 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 24A6C1C6A3B; Mon, 23 Jul 2012 04:20:12 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 2325E92BF6; Mon, 23 Jul 2012 04:20:12 -0400 (EDT) Date: Mon, 23 Jul 2012 04:20:12 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] User-defined indexing operations Message-ID: <20120723082012.GA13531@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 A user-defined indexing operation can have more than one index, for example to describe user-defined matrix types. The following must compile quietly: gcc -c -gnat12 test_indexing.adb --- with Ada.Text_IO; use Ada.Text_IO; with Project; use Project; with Matrix_3x3s; use Matrix_3x3s; with Vector_3s; use Vector_3s; procedure Test_Indexing is procedure Display (X : Real) is begin Put_Line (Real'Image (X)); end Display; V : Vector_3 := Create (X => 12.34, Y => 123.4, Z => 1234.0); M : Matrix_3x3 := (Create (X => V, Y => V * 2.0, Z => V * 4.0)); begin V (1) := 1.0; Display (V (1)); Display (V (2)); Display (V (3)); M (1, 1) := 20.0; Display (M (1, 1)); end Test_Indexing; --- with Project; use Project; with Project.Real_Arrays; use Project.Real_Arrays; with Vector_3s; use Vector_3s; package Matrix_3x3s is pragma Pure (Matrix_3x3s); subtype An_Axis is Integer range 1 .. 3; type Matrix_3x3 is tagged private with Constant_Indexing => Matrix_3x3s.Constant_Reference, Variable_Indexing => Matrix_3x3s.Variable_Reference; function Create (X, Y, Z : Vector_3) return Matrix_3x3; type Constant_Reference_Type (Value : not null access constant Real) is private with Implicit_Dereference => Value; function Constant_Reference (This : Matrix_3x3; X, Y : An_Axis) return Constant_Reference_Type; type Reference_Type (Value : not null access Real) is private with Implicit_Dereference => Value; function Variable_Reference (This : Matrix_3x3; X, Y : An_Axis) return Reference_Type; private type Matrix_3x3 is tagged record M : Real_Matrix (An_Axis, An_Axis); end record; function Create (X, Y, Z : Vector_3) return Matrix_3x3 is (M => (1 => (X.Get_X, X.Get_Y, X.Get_Z), 2 => (Y.Get_X, Y.Get_Y, Y.Get_Z), 3 => (Z.Get_X, Z.Get_Y, Z.Get_Z))); type Constant_Reference_Type (Value : not null access constant Real) is null record; type Reference_Type (Value : not null access Real) is null record; function Constant_Reference (This : Matrix_3x3; X, Y : An_Axis) return Constant_Reference_Type is (Value => This.M (X, Y)'Unrestricted_Access); function Variable_Reference (This : Matrix_3x3; X, Y : An_Axis) return Reference_Type is (Value => This.M (X, Y)'Unrestricted_Access); end Matrix_3x3s; --- with Ada.Numerics.Long_Real_Arrays; package Project.Real_Arrays renames Ada.Numerics.Long_Real_Arrays; package Project is pragma Pure (Project); subtype Real is Long_Float; pragma Assert (Real'Size >= 64); subtype Non_Negative_Real is Real range 0.0 .. Real'Last; subtype Positive_Real is Real range Real'Succ (0.0) .. Real'Last; end Project; --- with Project; use Project; with Project.Real_Arrays; use Project.Real_Arrays; package Vector_3s is pragma Pure (Vector_3s); subtype An_Axis is Integer range 1 .. 3; type Vector_3 is tagged private with Constant_Indexing => Vector_3s.Constant_Reference, Variable_Indexing => Vector_3s.Variable_Reference; function Create (X, Y, Z : Real) return Vector_3; function Get_X (This : Vector_3) return Real; function Get_Y (This : Vector_3) return Real; function Get_Z (This : Vector_3) return Real; function "*" (Left : Vector_3; Right : Real'Base) return Vector_3; subtype Real_Vector_3 is Real_Vector (An_Axis); type Constant_Reference_Type (Value : not null access constant Real) is private with Implicit_Dereference => Value; function Constant_Reference (This : Vector_3; Axis : An_Axis) return Constant_Reference_Type; type Reference_Type (Value : not null access Real) is private with Implicit_Dereference => Value; function Variable_Reference (This : Vector_3; Axis : An_Axis) return Reference_Type; private type Vector_3 is tagged record V : Real_Vector (An_Axis); end record; function Create (X, Y, Z : Real) return Vector_3 is (V => (1 => X, 2 => Y, 3 => Z)); function Get_X (This : Vector_3) return Real is (This.V (1)); function Get_Y (This : Vector_3) return Real is (This.V (2)); function Get_Z (This : Vector_3) return Real is (This.V (3)); function "*" (Left : Vector_3; Right : Real'Base) return Vector_3 is (V => Left.V * Right); type Constant_Reference_Type (Value : not null access constant Real) is null record; type Reference_Type (Value : not null access Real) is null record; function Constant_Reference (This : Vector_3; Axis : An_Axis) return Constant_Reference_Type is (Value => This.V (Axis)'Unrestricted_Access); function Variable_Reference (This : Vector_3; Axis : An_Axis) return Reference_Type is (Value => This.V (Axis)'Unrestricted_Access); end Vector_3s; Tested on x86_64-pc-linux-gnu, committed on trunk 2012-07-23 Ed Schonberg * sem_ch4.adb (Try_Container_Indexing): A user-defined indexing aspect can have more than one index, e.g. to describe indexing of a multidimensional object. Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 189768) +++ sem_ch4.adb (working copy) @@ -253,7 +253,7 @@ function Try_Container_Indexing (N : Node_Id; Prefix : Node_Id; - Expr : Node_Id) return Boolean; + Exprs : List_Id) return Boolean; -- AI05-0139: Generalized indexing to support iterators over containers function Try_Indexed_Call @@ -2114,7 +2114,7 @@ then return; - elsif Try_Container_Indexing (N, P, Exp) then + elsif Try_Container_Indexing (N, P, Exprs) then return; elsif Array_Type = Any_Type then @@ -2276,7 +2276,7 @@ end; end if; - elsif Try_Container_Indexing (N, P, First (Exprs)) then + elsif Try_Container_Indexing (N, P, Exprs) then return; end if; @@ -6475,9 +6475,10 @@ function Try_Container_Indexing (N : Node_Id; Prefix : Node_Id; - Expr : Node_Id) return Boolean + Exprs : List_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); + Assoc : List_Id; Disc : Entity_Id; Func : Entity_Id; Func_Name : Node_Id; @@ -6508,19 +6509,34 @@ if Has_Implicit_Dereference (Etype (Prefix)) then Build_Explicit_Dereference (Prefix, First_Discriminant (Etype (Prefix))); - return Try_Container_Indexing (N, Prefix, Expr); + return Try_Container_Indexing (N, Prefix, Exprs); else return False; end if; end if; + Assoc := New_List (Relocate_Node (Prefix)); + + -- A generalized iterator may have nore than one index expression, so + -- transfer all of them to the argument list to be used in the call. + + declare + Arg : Node_Id; + + begin + Arg := First (Exprs); + while Present (Arg) loop + Append (Relocate_Node (Arg), Assoc); + Next (Arg); + end loop; + end; + if not Is_Overloaded (Func_Name) then Func := Entity (Func_Name); Indexing := Make_Function_Call (Loc, Name => New_Occurrence_Of (Func, Loc), - Parameter_Associations => - New_List (Relocate_Node (Prefix), Relocate_Node (Expr))); + Parameter_Associations => Assoc); Rewrite (N, Indexing); Analyze (N); @@ -6544,8 +6560,7 @@ else Indexing := Make_Function_Call (Loc, Name => Make_Identifier (Loc, Chars (Func_Name)), - Parameter_Associations => - New_List (Relocate_Node (Prefix), Relocate_Node (Expr))); + Parameter_Associations => Assoc); Rewrite (N, Indexing); @@ -6586,7 +6601,8 @@ end if; if Etype (N) = Any_Type then - Error_Msg_NE ("container cannot be indexed with&", N, Etype (Expr)); + Error_Msg_NE ("container cannot be indexed with&", + N, Etype (First (Exprs))); Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); else Analyze (N);