Ada2012 introduces a general indexing mechanism, using implicit dereference
and new aspects Constant_Indexing and Variable_Indexing.
The following must compile and execute quietly in Ada_2012 mode:
with Index1; use Index1;
procedure Test_Index1 is
Obj : Container (15) := (15, T => (others => -999));
begin
if Obj (10) /= -999 then
raise Program_Error;
end if;
Obj (5) := 1;
end;
---
package Index1 is
type Table is Array (integer range <>) of Integer;
type Container (D : Integer) is tagged record
T : Table (1 .. D);
end record
with Variable_Indexing => Retrieve;
type Cursor (Value : access constant Integer) is null record
with Implicit_Dereference => Value;
function Retrieve (From : Container; Using : Integer) return Cursor;
function Retrieve (From : Container; Using : Float) return Cursor;
end Index1;
---
package body Index1 is
function Retrieve (From : Container; Using : Integer) return Cursor is
begin
return Cursor'(Value => new Integer'(From.T (Using)));
end;
function Retrieve (From : Container; Using : Float) return Cursor is
begin
return Cursor'(Value => new Integer'(From.T (Integer (Using))));
end;
end Index1;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-05 Ed Schonberg <schonb...@adacore.com>
* sem_ch4.adb (Try_Container_Indexing): New procedure to implement the
general indexing aspects of Ada2012. Called when analyzing indexed
components when other interpretations fail.
* sem_ch8.adb (Find_Direct_Name): check for implicit dereference only
in an expression context where overloading is meaningful. This excludes
the occurrence in an aspect specification (efficiency only).
* sem_attr.adb (Analyze_Attribute): indicate that the attributes
related to iterators can be set by an attribute specification, but
cannot be queried.
* sem_ch13.adb (Analyze_Aspect_Specifications): handle
Constant_Indexing and Variable_Indexing.
(Check_Indexing_Functions): New procedure to perform legality checks.
Additional semantic checks at end of declarations.
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 177441)
+++ sem_attr.adb (working copy)
@@ -2110,13 +2110,15 @@
case Attr_Id is
- -- Attributes related to Ada2012 iterators (placeholder ???)
+ -- Attributes related to Ada2012 iterators. Attribute specifications
+ -- exist for these, but they cannot be queried.
- when Attribute_Constant_Indexing => null;
- when Attribute_Default_Iterator => null;
- when Attribute_Implicit_Dereference => null;
- when Attribute_Iterator_Element => null;
- when Attribute_Variable_Indexing => null;
+ when Attribute_Constant_Indexing |
+ Attribute_Default_Iterator |
+ Attribute_Implicit_Dereference |
+ Attribute_Iterator_Element |
+ Attribute_Variable_Indexing =>
+ Error_Msg_N ("illegal attribute", N);
------------------
-- Abort_Signal --
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 177442)
+++ sem_ch4.adb (working copy)
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
@@ -248,6 +249,12 @@
-- Ada 2005: implementation of AI-310. An abstract non-dispatching
-- operation is not a candidate interpretation.
+ function Try_Container_Indexing
+ (N : Node_Id;
+ Prefix : Node_Id;
+ Expr : Node_Id) return Boolean;
+ -- AI05-0139: Generalized indexing to support iterators over containers
+
function Try_Indexed_Call
(N : Node_Id;
Nam : Entity_Id;
@@ -2032,6 +2039,9 @@
then
return;
+ elsif Try_Container_Indexing (N, P, Exp) then
+ return;
+
elsif Array_Type = Any_Type then
Set_Etype (N, Any_Type);
@@ -6270,6 +6280,130 @@
end if;
end Remove_Abstract_Operations;
+ ----------------------------
+ -- Try_Container_Indexing --
+ ----------------------------
+
+ function Try_Container_Indexing
+ (N : Node_Id;
+ Prefix : Node_Id;
+ Expr : Node_Id) return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Disc : Entity_Id;
+ Func : Entity_Id;
+ Func_Name : Node_Id;
+ Indexing : Node_Id;
+ Is_Var : Boolean;
+ Ritem : Node_Id;
+
+ begin
+
+ -- Check whether type has a specified indexing aspect.
+
+ Func_Name := Empty;
+ Is_Var := False;
+ Ritem := First_Rep_Item (Etype (Prefix));
+
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Aspect_Specification then
+
+ -- Prefer Variable_Indexing, but will settle for Constant.
+
+ if Get_Aspect_Id (Chars (Identifier (Ritem))) =
+ Aspect_Constant_Indexing
+ then
+ Func_Name := Expression (Ritem);
+
+ elsif Get_Aspect_Id (Chars (Identifier (Ritem))) =
+ Aspect_Variable_Indexing
+ then
+ Func_Name := Expression (Ritem);
+ Is_Var := True;
+ exit;
+ end if;
+ end if;
+ Next_Rep_Item (Ritem);
+ end loop;
+
+ -- If aspect does not exist the expression is illegal. Error is
+ -- diagnosed in caller.
+
+ if No (Func_Name) then
+ return False;
+ end if;
+
+ if Is_Var
+ and then not Is_Variable (Prefix)
+ then
+ Error_Msg_N ("Variable indexing cannot be applied to a constant", N);
+ end if;
+
+ 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)));
+ Rewrite (N, Indexing);
+ Analyze (N);
+
+ -- The return type of the indexing function is a reference type, so
+ -- add the dereference as a possible interpretation.
+
+ Disc := First_Discriminant (Etype (Func));
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Add_One_Interp (N, Disc, Designated_Type (Etype (Disc)));
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ else
+ Indexing := Make_Function_Call (Loc,
+ Name => Make_Identifier (Loc, Chars (Func_Name)),
+ Parameter_Associations =>
+ New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+
+ Rewrite (N, Indexing);
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Success : Boolean;
+
+ begin
+ Get_First_Interp (Func_Name, I, It);
+ Set_Etype (N, Any_Type);
+ while Present (It.Nam) loop
+ Analyze_One_Call (N, It.Nam, False, Success);
+ if Success then
+ Set_Etype (Name (N), It.Typ);
+
+ -- Add implicit dereference interpretation.
+
+ Disc := First_Discriminant (Etype (It.Nam));
+
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Add_One_Interp
+ (N, Disc, Designated_Type (Etype (Disc)));
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ return True;
+ end Try_Container_Indexing;
+
-----------------------
-- Try_Indirect_Call --
-----------------------
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 177442)
+++ sem_ch8.adb (working copy)
@@ -4818,7 +4818,12 @@
end if;
Set_Entity_Or_Discriminal (N, E);
- Check_Implicit_Dereference (N, Etype (E));
+
+ if Ada_Version >= Ada_2012
+ and then Nkind (Parent (N)) in N_Subexpr
+ then
+ Check_Implicit_Dereference (N, Etype (E));
+ end if;
end if;
end;
end Find_Direct_Name;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 177441)
+++ sem_ch13.adb (working copy)
@@ -946,14 +946,37 @@
Delay_Required := False;
- -- Aspects related to container iterators (fill in later???)
+ -- Aspects related to container iterators. These aspects denote
+ -- subprograms, and thus must be delayed.
when Aspect_Constant_Indexing |
- Aspect_Default_Iterator |
- Aspect_Iterator_Element |
Aspect_Variable_Indexing =>
- null;
+ if not Is_Type (E) or else not Is_Tagged_Type (E) then
+ Error_Msg_N ("indexing applies to a tagged type", N);
+ end if;
+
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
+
+ Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
+
+ when Aspect_Default_Iterator |
+ Aspect_Iterator_Element =>
+
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
+
+ Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
+
when Aspect_Implicit_Dereference =>
if not Is_Type (E)
or else not Has_Discriminants (E)
@@ -1511,6 +1534,11 @@
-- and if so gives an error message. If there is a duplicate, True is
-- returned, otherwise if there is no error, False is returned.
+ procedure Check_Indexing_Functions;
+ -- Check that the function in Constant_Indexing or Variable_Indexing
+ -- attribute has the proper type structure. If the name is overloaded,
+ -- check that all interpretations are legal.
+
-----------------------------------
-- Analyze_Stream_TSS_Definition --
-----------------------------------
@@ -1648,6 +1676,89 @@
end if;
end Analyze_Stream_TSS_Definition;
+ ------------------------------
+ -- Check_Indexing_Functions --
+ ------------------------------
+
+ procedure Check_Indexing_Functions is
+ Ctrl : Entity_Id;
+
+ procedure Check_One_Function (Subp : Entity_Id);
+ -- Check one possible interpretation
+
+ ------------------------
+ -- Check_One_Function --
+ ------------------------
+
+ procedure Check_One_Function (Subp : Entity_Id) is
+ begin
+ if Ekind (Subp) /= E_Function then
+ Error_Msg_N ("indexing requires a function", Subp);
+ end if;
+
+ if No (First_Formal (Subp)) then
+ Error_Msg_N
+ ("function for indexing must have parameters", Subp);
+ else
+ Ctrl := Etype (First_Formal (Subp));
+ end if;
+
+ if Ctrl = Ent
+ or else Ctrl = Class_Wide_Type (Ent)
+ or else
+ (Ekind (Ctrl) = E_Anonymous_Access_Type
+ and then
+ (Designated_Type (Ctrl) = Ent
+ or else Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
+ then
+ null;
+
+ else
+ Error_Msg_N ("indexing function must apply to type&", Subp);
+ end if;
+
+ if No (Next_Formal (First_Formal (Subp))) then
+ Error_Msg_N
+ ("function for indexing must have two parameters", Subp);
+ end if;
+
+ if not Has_Implicit_Dereference (Etype (Subp)) then
+ Error_Msg_N
+ ("function for indexing must return a reference type", Subp);
+ end if;
+ end Check_One_Function;
+
+ -- Start of processing for Check_Indexing_Functions
+
+ begin
+ Analyze (Expr);
+
+ if not Is_Overloaded (Expr) then
+ Check_One_Function (Entity (Expr));
+
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+
+ -- Note that analysis will have added the interpretation
+ -- that corresponds to the dereference. We only check the
+ -- subprogram itself.
+
+ if Is_Overloadable (It.Nam) then
+ Check_One_Function (It.Nam);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+ end Check_Indexing_Functions;
+
----------------------
-- Duplicate_Clause --
----------------------
@@ -2267,6 +2378,13 @@
end if;
end Component_Size_Case;
+ -----------------------
+ -- Constant_Indexing --
+ -----------------------
+
+ when Attribute_Constant_Indexing =>
+ Check_Indexing_Functions;
+
------------------
-- External_Tag --
------------------
@@ -2845,6 +2963,13 @@
end if;
end Value_Size;
+ -----------------------
+ -- Variable_Indexing --
+ -----------------------
+
+ when Attribute_Variable_Indexing =>
+ Check_Indexing_Functions;
+
-----------
-- Write --
-----------
@@ -5381,6 +5506,13 @@
Analyze (End_Decl_Expr);
Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
+ elsif A_Id = Aspect_Variable_Indexing or else
+ A_Id = Aspect_Constant_Indexing
+ then
+ Analyze (End_Decl_Expr);
+ Analyze (Aspect_Rep_Item (ASN));
+ Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
+
-- All other cases
else
@@ -5485,15 +5617,6 @@
Aspect_Value_Size =>
T := Any_Integer;
- -- Following to be done later ???
-
- when Aspect_Constant_Indexing |
- Aspect_Default_Iterator |
- Aspect_Iterator_Element |
- Aspect_Implicit_Dereference |
- Aspect_Variable_Indexing =>
- null;
-
-- Stream attribute. Special case, the expression is just an entity
-- that does not need any resolution, so just analyze.
@@ -5504,6 +5627,17 @@
Analyze (Expression (ASN));
return;
+ -- Same for Iterator aspects, where the expression is a function
+ -- name. Legality rules are checked separately.
+
+ when Aspect_Constant_Indexing |
+ Aspect_Default_Iterator |
+ Aspect_Iterator_Element |
+ Aspect_Implicit_Dereference |
+ Aspect_Variable_Indexing =>
+ Analyze (Expression (ASN));
+ return;
+
-- Suppress/Unsuppress/Warnings should never be delayed
when Aspect_Suppress |
