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 <schonb...@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.
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);
