Ada2012 introduces the notion of a reference type, to generalize the use of
cursors in containers. A reference type is a type with an access discriminant,
with the semantics that a reference to an object of the type is in fact a
reference to the object denoted by the access discriminant.
The following must compile and execute quietly in Ada2012 mode:
with Deref; use Deref;
procedure Test_Deref is
C : Cursor := Index (5);
V : Integer := Index (5);
Fifteen : Float := Index (1234);
Obj : Wrapper;
C1 : Cursor := Obj.Ptr;
V2 : Integer := Obj.Ptr;
begin
if Value /= 1234
or else Value2 /= 1234
or else V /= 1234
or else V2 /= 1234
then
raise Program_Error;
end if;
end;
---
package deref is
type Cursor (E : access Integer) is tagged null record
with Implicit_Dereference => E;
function Index (N : Integer) return Cursor;
function Index (N : Integer) return Float;
Thing : Cursor := (E => New Integer'(1234));
Value : aliased Integer := Thing;
type Wrapper is record
Ptr : Cursor (Value'access);
end record;
type Table is array (1..10) of Cursor (Value'access);
It : Table;
Value2 : Integer := It (5);
end;
--
The following compilation:
gcc -c -gnat12 -gnatf ambig_deref.ads
must yield the following errors:
ambig_deref.ads:12:23: can be interpreted as implicit dereference
ambig_deref.ads:12:30: ambiguous operands for equality
ambig_deref.ads:12:32: can be interpreted as implicit dereference
---
package ambig_deref is
type Cursor (E : access Integer) is tagged null record
with Implicit_Dereference => E;
Thing : Cursor := (E => New Integer'(1234));
Value : aliased Integer := Thing;
type Table is array (1..10) of Cursor (Value'access);
It : Table;
Value2 : Integer := It (5);
Maybe : Boolean := It (4) = It (5);
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-05 Ed Schonberg <schonb...@adacore.com>
* sem_util.adb, sem_util.ads (Check_Implicit_Dereference): If a
possible interpretation of name is a reference type, add an
interpretation that is the designated type of the reference
discriminant of that type.
* sem_res.adb (resolve): If the interpretation imposed by context is an
implicit dereference, rewrite the node as the deference of the
reference discriminant.
* sem_ch3.adb (Analyze_Subtype_Declaration, Build_Derived_Record_Type,
Build_Discriminated_Subtype): Inherit Has_Implicit_Dereference from
parent type or base type.
* sem_ch4.adb (Process_Indexed_Component,
Process_Overloaded_Indexed_Component, Indicate_Name_And_Type,
Analyze_Overloaded_Selected_Component, Analyze_Selected_Component):
Check for implicit dereference.
(List_Operand_Interps): Indicate when an implicit dereference is
ambiguous.
* sem_ch8.adb (Find_Direct_Name): Check for implicit dereference.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 177441)
+++ sem_ch3.adb (working copy)
@@ -4215,6 +4215,8 @@
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
+ Set_Has_Implicit_Dereference
+ (Id, Has_Implicit_Dereference (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
@@ -4248,6 +4250,8 @@
Set_Last_Entity (Id, Last_Entity (T));
Set_Private_Dependents (Id, New_Elmt_List);
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
+ Set_Has_Implicit_Dereference
+ (Id, Has_Implicit_Dereference (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
Set_Known_To_Have_Preelab_Init
@@ -7875,6 +7879,8 @@
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
Replace_Components (Derived_Type, New_Decl);
+ Set_Has_Implicit_Dereference
+ (Derived_Type, Has_Implicit_Dereference (Parent_Type));
end if;
-- Insert the new derived type declaration
@@ -8586,6 +8592,8 @@
Set_First_Entity (Def_Id, First_Entity (T));
Set_Last_Entity (Def_Id, Last_Entity (T));
+ Set_Has_Implicit_Dereference
+ (Def_Id, Has_Implicit_Dereference (T));
-- If the subtype is the completion of a private declaration, there may
-- have been representation clauses for the partial view, and they must
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 177433)
+++ sem_util.adb (working copy)
@@ -1104,6 +1104,43 @@
end if;
end Cannot_Raise_Constraint_Error;
+ --------------------------------
+ -- Check_Implicit_Dereference --
+ --------------------------------
+
+ procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id)
+ is
+ Disc : Entity_Id;
+ Desig : Entity_Id;
+
+ begin
+ if Ada_Version < Ada_2012
+ or else not Has_Implicit_Dereference (Base_Type (Typ))
+ then
+ return;
+
+ elsif not Comes_From_Source (Nam) then
+ return;
+
+ elsif Is_Entity_Name (Nam)
+ and then Is_Type (Entity (Nam))
+ then
+ null;
+
+ else
+ Disc := First_Discriminant (Typ);
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Desig := Designated_Type (Etype (Disc));
+ Add_One_Interp (Nam, Disc, Desig);
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
+ end Check_Implicit_Dereference;
+
---------------------------------------
-- Check_Later_Vs_Basic_Declarations --
---------------------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 177433)
+++ sem_util.ads (working copy)
@@ -147,6 +147,11 @@
-- not necessarily mean that CE could be raised, but a response of True
-- means that for sure CE cannot be raised.
+ procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id);
+ -- AI05-139-2 : accessors and iterators for containers. This procedure
+ -- checks whether T is a reference type, and if so it adds an interprettion
+ -- to Expr whose type is the designated type of the reference_discriminant.
+
procedure Check_Later_Vs_Basic_Declarations
(Decls : List_Id;
During_Parsing : Boolean);
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 177431)
+++ sem_res.adb (working copy)
@@ -1753,6 +1753,15 @@
It1 : Interp;
Seen : Entity_Id := Empty; -- prevent junk warning
+ procedure Build_Explicit_Dereference
+ (Expr : Node_Id;
+ Disc : Entity_Id);
+ -- AI05-139 : names with implicit dereference. If the expression N is a
+ -- reference type and the context imposes the corresponding designated
+ -- type, convert N into N.Disc.all. Such expressions are always over-
+ -- loaded with both interpretations, and the dereference interpretation
+ -- carries the name of the reference discriminant.
+
function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
-- Determine whether a node comes from a predefined library unit or
-- Standard.
@@ -1768,6 +1777,30 @@
procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails
+ --------------------------------
+ -- Build_Explicit_Dereference --
+ --------------------------------
+
+ procedure Build_Explicit_Dereference
+ (Expr : Node_Id;
+ Disc : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ begin
+ Set_Is_Overloaded (Expr, False);
+ Rewrite (Expr,
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Relocate_Node (Expr),
+ Selector_Name =>
+ New_Occurrence_Of (Disc, Loc))));
+
+ Set_Etype (Prefix (Expr), Etype (Disc));
+ Set_Etype (Expr, Typ);
+ end Build_Explicit_Dereference;
+
------------------------------------
-- Comes_From_Predefined_Lib_Unit --
-------------------------------------
@@ -2279,6 +2312,22 @@
elsif Nkind (N) = N_Conditional_Expression then
Set_Etype (N, Expr_Type);
+ -- AI05-0139-2 : expression is overloaded because
+ -- type has implicit dereference. If type matches
+ -- context, no implicit dereference is involved.
+
+ elsif Has_Implicit_Dereference (Expr_Type) then
+ Set_Etype (N, Expr_Type);
+ Set_Is_Overloaded (N, False);
+ exit Interp_Loop;
+
+ elsif Is_Overloaded (N)
+ and then Present (It.Nam)
+ and then Ekind (It.Nam) = E_Discriminant
+ and then Has_Implicit_Dereference (It.Nam)
+ then
+ Build_Explicit_Dereference (N, It.Nam);
+
-- For an explicit dereference, attribute reference, range,
-- short-circuit form (which is not an operator node), or call
-- with a name that is an explicit dereference, there is
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 177431)
+++ sem_ch4.adb (working copy)
@@ -301,7 +301,24 @@
Nam := Opnd;
elsif Nkind (Opnd) = N_Function_Call then
Nam := Name (Opnd);
- else
+ elsif Ada_Version >= Ada_2012 then
+ declare
+ It : Interp;
+ I : Interp_Index;
+
+ begin
+ Get_First_Interp (Opnd, I, It);
+ while Present (It.Nam) loop
+ if Has_Implicit_Dereference (It.Typ) then
+ Error_Msg_N
+ ("can be interpreted as implicit dereference", Opnd);
+ return;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
return;
end if;
@@ -2068,6 +2085,7 @@
end loop;
Set_Etype (N, Component_Type (Array_Type));
+ Check_Implicit_Dereference (N, Etype (N));
if Present (Index) then
Error_Msg_N
@@ -2164,9 +2182,13 @@
end loop;
if Found and then No (Index) and then No (Exp) then
- Add_One_Interp (N,
- Etype (Component_Type (Typ)),
- Etype (Component_Type (Typ)));
+ declare
+ CT : constant Entity_Id :=
+ Base_Type (Component_Type (Typ));
+ begin
+ Add_One_Interp (N, CT, CT);
+ Check_Implicit_Dereference (N, CT);
+ end;
end if;
end if;
@@ -2644,6 +2666,7 @@
procedure Indicate_Name_And_Type is
begin
Add_One_Interp (N, Nam, Etype (Nam));
+ Check_Implicit_Dereference (N, Etype (Nam));
Success := True;
-- If the prefix of the call is a name, indicate the entity
@@ -3133,6 +3156,7 @@
Set_Entity (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
Add_One_Interp (N, Etype (Comp), Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (Comp));
-- This also specifies a candidate to resolve the name.
-- Further overloading will be resolved from context.
@@ -3740,6 +3764,7 @@
New_Occurrence_Of (Comp, Sloc (N)));
Set_Original_Discriminant (Selector_Name (N), Comp);
Set_Etype (N, Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (Comp));
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
@@ -3876,6 +3901,7 @@
Set_Etype (N, Etype (Comp));
end if;
+ Check_Implicit_Dereference (N, Etype (N));
return;
end if;
@@ -3941,6 +3967,7 @@
Set_Etype (Sel, Etype (Comp));
Set_Etype (N, Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (N));
if Is_Generic_Type (Prefix_Type)
or else Is_Generic_Type (Root_Type (Prefix_Type))
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 177431)
+++ sem_ch8.adb (working copy)
@@ -4818,6 +4818,7 @@
end if;
Set_Entity_Or_Discriminal (N, E);
+ Check_Implicit_Dereference (N, Etype (E));
end if;
end;
end Find_Direct_Name;
