The use of reference types and generalized indexing leads to multiple tree
rewritings. When these uses are in a generic unit, the transformations are not
propagated to instantiations, and the analysis of the instance must replicate
that of the generic to recognize the presence of implicit dereferences. This
patch removes some global information from selected components whose prefix
involves an implicit dereference, to force the re-analysis and resolution in
the instantiation.
Executing;
gnatmake -q cont
cont
must yield:
1234
1234
1234
2468
---
with Par; use Par;
with Par.Child;
with Ada.Finalization; use Ada.Finalization;
procedure Cont is
use My_Lists;
Bunch : List;
Ptr : Cursor;
package Inst is new Par.Child;
use Inst;
begin
Append (Bunch, R'(Controlled with Kind => 1234));
Try (Bunch, Bunch.First);
end;
---
with ada.containers.doubly_linked_lists;
with Ada.Finalization; use Ada.Finalization;
use ada.containers;
package Par is
type R is new Ada.Finalization.Controlled with record
Kind : Integer;
end record;
package My_Lists is new Doubly_Linked_Lists (R);
end Par;
---
generic
package Par.Child is
use My_Lists;
procedure Try (Bunch: List; C : Cursor);
end Par.Child;
--
with Text_IO; use Text_IO;
package body Par.Child is
use My_Lists;
procedure Try (Bunch: List; C : Cursor) is
V1 : Integer := Constant_Reference (Bunch, C).Element.Kind;
V2 : Integer := Constant_Reference (Bunch, C).Kind;
V3 : Integer := Bunch (C).Kind;
begin
Put_Line (Integer'Image (V1));
Put_Line (Integer'Image (V2));
Put_Line (Integer'Image (V3));
for Elmt of Bunch loop
Put_Line (Integer'Image (2 * Elmt.Kind));
end loop;
end;
end Par.Child;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-31 Ed Schonberg <[email protected]>
* sem_ch4.adb (Try_Container_Indexing): Use Check_Implicit_Dereference.
* sem_util.adb (Check_Implicit_Dereference): a) Handle generalized
indexing as well as function calls. b) If the context is a
selected component and whe are in an instance, remove entity from
selector name to force resolution of the node, so that explicit
dereferences can be generated in the instance if they were in
the generic unit.
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 216925)
+++ sem_util.adb (working copy)
@@ -2673,17 +2673,29 @@
-- Check_Implicit_Dereference --
--------------------------------
- procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is
+ procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is
Disc : Entity_Id;
Desig : Entity_Id;
+ Nam : Node_Id;
begin
+ if Nkind (N) = N_Indexed_Component
+ and then Present (Generalized_Indexing (N))
+ then
+ Nam := Generalized_Indexing (N);
+
+ else
+ Nam := N;
+ end if;
+
if Ada_Version < Ada_2012
or else not Has_Implicit_Dereference (Base_Type (Typ))
then
return;
- elsif not Comes_From_Source (Nam) then
+ elsif not Comes_From_Source (N)
+ and then Nkind (N) /= N_Indexed_Component
+ then
return;
elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
@@ -2695,6 +2707,26 @@
if Has_Implicit_Dereference (Disc) then
Desig := Designated_Type (Etype (Disc));
Add_One_Interp (Nam, Disc, Desig);
+
+ -- If the node is a generalized indexing, add interpretation
+ -- to that node as well, for subsequent resolution.
+
+ if Nkind (N) = N_Indexed_Component then
+ Add_One_Interp (N, Disc, Desig);
+ end if;
+
+ -- If the operation comes from a generic unit and the context
+ -- is a selected component, the selector name may be global
+ -- and set in the instance already. Remove the entity to
+ -- force resolution of the selected component, and the
+ -- generation of an explicit dereference if needed.
+
+ if In_Instance
+ and then Nkind (Parent (Nam)) = N_Selected_Component
+ then
+ Set_Entity (Selector_Name (Parent (Nam)), Empty);
+ end if;
+
exit;
end if;
@@ -16543,11 +16575,21 @@
begin
-- Nothing to do if argument is Empty or has Debug_Info_Off set, which
-- indicates that Debug_Info_Needed is never required for the entity.
+ -- Nothing to do if entity comes from a predefined file. Library files
+ -- are compiled without debug information, but inlined bodies of these
+ -- routines may appear in user code, and debug information on them ends
+ -- up complicating debugging the user code.
if No (T)
or else Debug_Info_Off (T)
then
return;
+
+ elsif In_Inlined_Body
+ and then Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Sloc (T))))
+ then
+ Set_Needs_Debug_Info (T, False);
end if;
-- Set flag in entity itself. Note that we will go through the following
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 216925)
+++ sem_util.ads (working copy)
@@ -285,10 +285,12 @@
-- the one containing C2, that is known to refer to the same object (RM
-- 6.4.1(6.17/3)).
- procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id);
+ procedure Check_Implicit_Dereference (N : 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.
+ -- to N whose type is the designated type of the reference_discriminant.
+ -- If N is a generalized indexing operation, the interpretation is added
+ -- both to the corresponding function call, and to the indexing node.
procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id);
-- Within a protected function, the current object is a constant, and
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 216925)
+++ sem_ch4.adb (working copy)
@@ -7036,7 +7036,6 @@
Loc : constant Source_Ptr := Sloc (N);
C_Type : Entity_Id;
Assoc : List_Id;
- Disc : Entity_Id;
Func : Entity_Id;
Func_Name : Node_Id;
Indexing : Node_Id;
@@ -7149,21 +7148,7 @@
-- discriminant is not the first discriminant.
if Has_Discriminants (Etype (Func)) then
- Disc := First_Discriminant (Etype (Func));
- while Present (Disc) loop
- declare
- Elmt_Type : Entity_Id;
- begin
- if Has_Implicit_Dereference (Disc) then
- Elmt_Type := Designated_Type (Etype (Disc));
- Add_One_Interp (Indexing, Disc, Elmt_Type);
- Add_One_Interp (N, Disc, Elmt_Type);
- exit;
- end if;
- end;
-
- Next_Discriminant (Disc);
- end loop;
+ Check_Implicit_Dereference (N, Etype (Func));
end if;
else
@@ -7194,18 +7179,7 @@
-- Add implicit dereference interpretation
if Has_Discriminants (Etype (It.Nam)) then
- Disc := First_Discriminant (Etype (It.Nam));
- while Present (Disc) loop
- if Has_Implicit_Dereference (Disc) then
- Add_One_Interp
- (Indexing, Disc, Designated_Type (Etype (Disc)));
- Add_One_Interp
- (N, Disc, Designated_Type (Etype (Disc)));
- exit;
- end if;
-
- Next_Discriminant (Disc);
- end loop;
+ Check_Implicit_Dereference (N, Etype (It.Nam));
end if;
exit;
