Patchwork [Ada] User-defined indexing operations

login
register
mail settings
Submitter Arnaud Charlet
Date July 23, 2012, 8:20 a.m.
Message ID <20120723082012.GA13531@adacore.com>
Download mbox | patch
Permalink /patch/172573/
State New
Headers show

Comments

Arnaud Charlet - July 23, 2012, 8:20 a.m.
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  <schonberg@adacore.com>

	* 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.

Patch

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);