while Present (It.Nam) loop
T := It.Typ;
- if Is_Access_Type (T)
- and then No (First_Formal (Base_Type (Designated_Type (T))))
- then
- Set_Etype (P, T);
- else
- Remove_Interp (I);
+ if Is_Access_Type (T) then
+ if No (First_Formal (Base_Type (Designated_Type (T)))) then
+ Set_Etype (P, T);
+ else
+ Remove_Interp (I);
+ end if;
end if;
Get_Next_Interp (I, It);
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
- -- being called. If it is not a name, it is an expression that
+ -- If the prefix of the call is an entity name, indicate the entity
+ -- being called. If it is not such a name, it is an expression that
-- denotes an access to subprogram or else an entry or family. In
-- the latter case, the name is a selected component, and the entity
-- being called is noted on the selector.
end if;
end if;
+ -- Now add an interpretation for the implicit dereference, if any
+
+ Check_Implicit_Dereference (N, Etype (Nam));
+ Success := True;
+
if Debug_Flag_E and not Report then
Write_Str (" Overloaded call ");
Write_Int (Int (N));
Get_First_Interp (Lhs, I, It);
while Present (It.Typ) loop
+ -- AI22-0112 restores the Ada 95 rule that excludes limited
+ -- types from consideration during resolution of the target
+ -- variable in assignment statements.
+
if Is_Limited_Type (It.Typ) then
- Remove_Interp (I);
+ if not Has_Implicit_Dereference (It.Typ) then
+ Remove_Interp (I);
+ end if;
elsif T1 = Any_Type then
T1 := It.Typ;
end if;
-- variable in assignment statements.
if Is_Limited_Type (It.Typ) then
- Remove_Interp (I);
+ if not Has_Implicit_Dereference (It.Typ) then
+ Remove_Interp (I);
+ end if;
elsif Has_Compatible_Type (Rhs, It.Typ) then
if T1 = Any_Type then
I1 : Interp_Index := 0; -- prevent junk warning
It : Interp;
It1 : Interp;
+ Prev_It : Interp := No_Interp;
Seen : Entity_Id := Empty; -- prevent junk warning
function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
-- We have a matching interpretation, Expr_Type is the type
-- from this interpretation, and Seen is the entity.
- -- For an operator, just set the entity name. The type will be
- -- set by the specific operator resolution routine.
-
- if Nkind (N) in N_Op then
- Set_Entity (N, Seen);
- Generate_Reference (Seen, N);
+ -- If this is an additional interpretation introduced by
+ -- Check_Implicit_Dereference, the actual interpretation
+ -- for N was the previous one. Resolve N and insert the
+ -- explicit dereference.
- elsif Nkind (N) in N_Case_Expression
- | N_Character_Literal
- | N_Delta_Aggregate
- | N_If_Expression
+ if Present (It.Nam)
+ and then Ekind (It.Nam) = E_Discriminant
+ and then Has_Implicit_Dereference (It.Nam)
+ and then (Nkind (N) /= N_Indexed_Component
+ or else No (Generalized_Indexing (N)))
then
- Set_Etype (N, Expr_Type);
-
- -- AI05-0139-2: Expression is overloaded because type has
- -- implicit dereference. The context may be the one that
- -- requires implicit dereferemce.
+ pragma Assert (Prev_It /= No_Interp);
- elsif Has_Implicit_Dereference (Expr_Type) then
- Set_Etype (N, Expr_Type);
- Set_Is_Overloaded (N, False);
+ if Is_Entity_Name (N) then
+ Set_Etype (N, Prev_It.Typ);
+ Set_Entity (N, Prev_It.Nam);
+ Generate_Reference (Prev_It.Nam, N);
- -- If the expression is an entity, generate a reference
- -- to it, as this is not done for an overloaded construct
- -- during analysis.
-
- if Is_Entity_Name (N)
- and then Comes_From_Source (N)
+ elsif Nkind (N) in N_Subprogram_Call
+ and then Is_Entity_Name (Name (N))
then
- Generate_Reference (Entity (N), N);
-
- -- Examine access discriminants of entity type,
- -- to check whether one of them yields the
- -- expected type.
-
- declare
- Disc : Entity_Id :=
- First_Discriminant (Etype (Entity (N)));
-
- begin
- while Present (Disc) loop
- exit when Is_Access_Type (Etype (Disc))
- and then Has_Implicit_Dereference (Disc)
- and then Designated_Type (Etype (Disc)) = Typ;
+ Set_Etype (Name (N), Prev_It.Typ);
+ Set_Entity (Name (N), Prev_It.Nam);
+ Generate_Reference (Prev_It.Nam, Name (N));
+ Set_Is_Overloaded (Name (N), False);
+ end if;
- Next_Discriminant (Disc);
- end loop;
+ Build_Explicit_Dereference (N, It.Nam);
- if Present (Disc) then
- Build_Explicit_Dereference (N, Disc);
- end if;
- end;
- end if;
+ -- For an operator, just set the entity. The type will be
+ -- set by the specific operator resolution routine.
- exit Interp_Loop;
+ elsif Nkind (N) in N_Op then
+ Set_Entity (N, Seen);
+ Generate_Reference (Seen, N);
- elsif Is_Overloaded (N)
- and then Present (It.Nam)
- and then Ekind (It.Nam) = E_Discriminant
- and then Has_Implicit_Dereference (It.Nam)
- then
- -- If the node is a general indexing, the dereference is
- -- is inserted when resolving the rewritten form, else
- -- insert it now.
+ -- For an entity name, set both the type and the entity
- if Nkind (N) /= N_Indexed_Component
- or else No (Generalized_Indexing (N))
- then
- Build_Explicit_Dereference (N, It.Nam);
- end if;
+ elsif Is_Entity_Name (N) then
+ Set_Etype (N, Expr_Type);
+ Set_Entity (N, Seen);
+ Generate_Reference (Seen, N);
- -- 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
- -- nothing to be done at this point.
+ -- For nodes other than calls, or calls with a name that is an
+ -- explicit dereference, there is nothing to be done.
elsif Nkind (N) in N_Attribute_Reference
| N_And_Then
+ | N_Case_Expression
+ | N_Character_Literal
+ | N_Delta_Aggregate
| N_Explicit_Dereference
- | N_Identifier
+ | N_If_Expression
| N_Indexed_Component
| N_Or_Else
| N_Range
then
null;
- -- For procedure or function calls, set the type of the name,
- -- and also the entity pointer for the prefix.
+ -- For some calls, set the type and entity of the name
- elsif Nkind (N) in N_Subprogram_Call
- and then Is_Entity_Name (Name (N))
- then
+ elsif Is_Entity_Name (Name (N)) then
Set_Etype (Name (N), Expr_Type);
Set_Entity (Name (N), Seen);
Generate_Reference (Seen, Name (N));
- elsif Nkind (N) = N_Function_Call
- and then Nkind (Name (N)) = N_Selected_Component
- then
+ elsif Nkind (Name (N)) = N_Selected_Component then
Set_Etype (Name (N), Expr_Type);
Set_Entity (Selector_Name (Name (N)), Seen);
Generate_Reference (Seen, Selector_Name (Name (N)));
- -- For all other cases, just set the type of the Name
+ -- For other calls, just set the type of the Name
else
Set_Etype (Name (N), Expr_Type);
end if;
-
end if;
<<Continue>>
exit Interp_Loop when No (It.Typ);
+ Prev_It := It;
+
Get_Next_Interp (I, It);
end loop Interp_Loop;
end if;
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
- if Is_Access_Type (It.Typ)
- and then Covers (Typ, Designated_Type (It.Typ))
- then
- if No (P_Typ) then
- P_Typ := It.Typ;
- end if;
+ if Is_Access_Type (It.Typ) then
+ if Covers (Typ, Designated_Type (It.Typ)) then
+ if No (P_Typ) then
+ P_Typ := It.Typ;
+ end if;
- -- Remove access types that do not match, but preserve access
- -- to subprogram interpretations, in case a further dereference
- -- is needed (see below).
+ -- Remove access types that do not match, but preserve access
+ -- to subprogram interpretations, in case a further dereference
+ -- is needed (see below).
- elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then
- Remove_Interp (I);
+ elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then
+ Remove_Interp (I);
+ end if;
end if;
Get_Next_Interp (I, It);
return True;
end if;
+ -- Skip the direct interpretation for a limited type that has implicit
+ -- dereference, since it cannot be used for operands of an assignment,
+ -- per AI22-0112 which restores the Ada 95 rule for all versions.
+
+ if Present (It.Typ)
+ and then Is_Limited_Type (It.Typ)
+ and then Has_Implicit_Dereference (It.Typ)
+ then
+ Get_Next_Interp (I, It);
+ end if;
+
I1 := I;
It1 := It;
then
Add_Entry (Entity (Name (N)), Etype (N));
+ elsif Nkind (N) = N_Function_Call
+ and then Nkind (Name (N)) = N_Selected_Component
+ and then Is_Entity_Name (Selector_Name (Name (N)))
+ then
+ Add_Entry (Entity (Selector_Name (Name (N))), Etype (N));
+
-- If this is an indirect call there will be no name associated
-- with the previous entry. To make diagnostics clearer, save
-- Subprogram_Type of first interpretation, so that the error will
-- point to the anonymous access to subprogram, not to the result
-- type of the call itself.
- elsif (Nkind (N)) = N_Function_Call
+ elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Explicit_Dereference
and then Is_Overloaded (Name (N))
then
Add_Entry (It.Nam, Etype (N));
end;
- else
- -- Overloaded prefix in indexed or selected component, or call
- -- whose name is an expression or another call.
+ -- If this is a generalized indexing, treat it as a function call
+ elsif Nkind (N) = N_Indexed_Component
+ and then Present (Generalized_Indexing (N))
+ then
+ Add_Entry (Entity (Name (Generalized_Indexing (N))), Etype (N));
+
+ -- An overloaded prefix in indexed or selected component, or a call
+ -- whose name is an expression or another call.
+
+ else
Add_Entry (Etype (N), Etype (N));
end if;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+with Ada.Containers.Indefinite_Ordered_Maps;
+with Ada.Strings.Unbounded;
+
+procedure Implicit_Deref1 is
+ use Ada.Strings.Unbounded;
+
+ package Reproduce_Pkg is
+ type Person_Type is tagged private;
+
+ type Person_Ref (Data : not null access Person_Type) is
+ limited null record
+ with Implicit_Dereference => Data;
+
+ type Person_Handler_Ptr is access procedure (Person : Person_Type);
+
+ function New_Person (Name : Unbounded_String) return Person_Ref;
+
+ function New_Person
+ (Person : aliased in out Person_Type; Name : Unbounded_String)
+ return Person_Ref;
+
+ private
+
+ type Person_Type is tagged record
+ Name : Unbounded_String;
+ end record;
+ end Reproduce_Pkg;
+
+ package body Reproduce_Pkg is
+ function New_Person (Name : Unbounded_String) return Person_Ref is
+ begin
+ return (Data => new Person_Type'(Name => Name));
+ end New_Person;
+
+ function New_Person
+ (Person : aliased in out Person_Type; Name : Unbounded_String)
+ return Person_Ref is
+ begin
+ return (Data => new Person_Type'(Name => Name));
+ end New_Person;
+ end Reproduce_Pkg;
+
+ App : Reproduce_Pkg.Person_Type :=
+ Reproduce_Pkg.New_Person (Name => To_Unbounded_String ("hello"));
+begin
+ null;
+end;
--- /dev/null
+-- { dg-do compile }
+
+with Ada.Text_IO;
+with System.Address_To_Access_Conversions;
+
+procedure Implicit_Deref2 is
+
+ package Test is
+
+ type Any is
+ tagged limited
+ record
+ Address : System.Address;
+ end record;
+
+ type Any_Ptr is access Any;
+
+ generic
+ type T (<>) is limited private;
+ type T_Ptr is access T;
+ function Make (P : T_Ptr) return Any_Ptr;
+
+ generic
+ type T (<>) is limited private;
+ type T_Ref (Data : not null access constant T) is limited private;
+ with function Make_T_Ref (Data : not null access constant T) return T_Ref;
+ function Get (P : Any_Ptr) return T_Ref;
+
+ end Test;
+
+ package body Test is
+
+ function Make (P : T_Ptr) return Any_Ptr is
+ package Convert is new System.Address_To_Access_Conversions (T);
+ begin
+ return new Any'(Address => Convert.To_Address (Convert.Object_Pointer (P)));
+ end Make;
+
+ function Get (P : Any_Ptr) return T_Ref is
+ package Convert is new System.Address_To_Access_Conversions (T);
+ begin
+ return Make_T_Ref (Convert.To_Pointer (P.Address));
+ end Get;
+
+ end Test;
+
+ type Integer_Ptr is access Integer;
+ type Integer_Ref (Data : not null access constant Integer) is limited null record
+ with Implicit_Dereference => Data;
+ function Make_Integer_Ref (Data : not null access constant Integer) return Integer_Ref is
+ (Data => Data);
+
+ function Make is new Test.Make (Integer, Integer_Ptr);
+ function Get is new Test.Get (Integer, Integer_Ref, Make_Integer_Ref);
+
+ type Float_Ptr is access Float;
+ type Float_Ref (Data : not null access constant Float) is limited null record
+ with Implicit_Dereference => Data;
+ function Make_Float_Ref (Data : not null access constant Float) return Float_Ref is
+ (Data => Data);
+
+ function Make is new Test.Make (Float, Float_Ptr);
+ function Get is new Test.Get (Float, Float_Ref, Make_Float_Ref);
+
+ A1 : Test.Any_Ptr := Make (new Integer'(42));
+ A2 : Integer := Get (A1);
+
+ B1 : Test.Any_Ptr := Make (new Float'(43.0));
+ B2 : Float := Get (B1);
+
+begin
+ Ada.Text_IO.Put_Line (A2'Image);
+ Ada.Text_IO.Put_Line (B2'Image);
+end;
--- /dev/null
+-- { dg-do compile }
+
+procedure Implicit_Deref3 is
+
+ package P is
+ type Root is tagged null record;
+
+ type Access_Root_Class is access Root'Class;
+
+ type Root_Ref is tagged record
+ Block : Access_Root_Class;
+ end record;
+
+ function Create (Value : Root'Class) return Root_Ref
+ is (Block => new Root'Class'(Value));
+ end P;
+
+ use P;
+
+ generic
+ type T (<>) is abstract new Root with private;
+ type Parent_Ref is new Root_Ref with private;
+ package Pointers is
+ type Ref is new Parent_Ref with null record;
+
+ not overriding
+ function Create (Value : T) return Ref
+ is (Parent_Ref'(Create (Value)) with null record);
+
+ type Reference_Type (Data : access T) is limited null record
+ with Implicit_Dereference => Data;
+
+ function Get (This : Ref) return Reference_Type
+ is (Data => T (This.Block.all)'Access);
+ end Pointers;
+
+ type Derived_A is abstract new Root with null record;
+
+ type Derived_B is new Derived_A with record
+ I : Integer;
+ end record;
+
+ package A_Pointers is new Pointers (Derived_A, Root_Ref);
+ package B_Pointers is new Pointers (Derived_B, A_Pointers.Ref);
+
+ X : B_Pointers.Ref;
+ Y : Integer := X.Get.Data.I;
+ Z : Integer := B_Pointers.Get (X).Data.I;
+
+begin
+ null;
+end;
projects / thirdparty / gcc.git / commitdiff
