Patchwork [Ada] Visibility of selected components in instantiations

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 11, 2010, 8:29 a.m.
Message ID <20101011082926.GA17539@adacore.com>
Download mbox | patch
Permalink /patch/67388/
State New
Headers show

Comments

Arnaud Charlet - Oct. 11, 2010, 8:29 a.m.
A component inherited by a formal derived type whose parent is private may
become visible in the generic body if it appears in a child unit of the scope
of the parent type. The component may not be visible in an instance if the
actual is a private extension. In this case the component must be found by
scanning the proper view of the parent type.
The following must compile quietly:

   gcc -c gnattest_p1.adb

---
generic
   type Consumer_Type (<>) is new Gnattest_M.Result_Consumer with private;
   type Result_Data_Type is private;
   type Result_Message_Type is new Gnattest_M.Rpc_Result_Message with private;
   with function Get_Data(Message : Result_Message_Type'Class) return Result_Data_Type;
package Gnattest_M.Remote_Handling is

   procedure Put_Command_And_Wait_For_Result
     (Device     : access Consumer_Type;
      Command    : in out Gnattest_M.Rpc_Command_Message'Class);

end Gnattest_M.Remote_Handling;
---
package Gnattest_M is
   type Consumer is abstract tagged limited private;
   type Consumer_Acc is access all Consumer'Class;

   type Message is abstract tagged null record;

   type Message_Acc is access all Message'Class;

   procedure Put
     (Consumer     : access Gnattest_M.Consumer;
      Message      : in     Gnattest_M.Message'Class)
   is abstract;

   type Rpc_Message is abstract new Message with record
      Result_Id : Integer := 0;
   end record;

   type Rpc_Command_Message is abstract new Rpc_Message with null record;

   type Rpc_Result_Message is abstract new Rpc_Message with null record;

   type Start_Out is null record;

   type Start_Result is new Rpc_Result_Message with record
      Data : Start_Out;
   end record;

   function Get_Data
     (Message : Start_Result'Class)
       return Start_Out;

   type Result_Consumer
     (Result_Indexer_Capacity : Integer)
     is abstract new Consumer with private;

private
   type Consumer is abstract tagged limited record
      External_Consumer     : Gnattest_M.Consumer_Acc := null;
   end record;

   type Result_Consumer (Result_Indexer_Capacity : Integer)
     is abstract new Consumer with
      record
         Result_Indexer    : Integer;
      end record;

end Gnattest_M;
---
with Gnattest_M;
package Gnattest_P1 is
   type Device is new Gnattest_M.Result_Consumer with private;

   type Device_Ref is access all Device;

private
   type Device is new Gnattest_M.Result_Consumer with record
      Dummy : Integer;
   end record;

   procedure Put
     (Consumer : access Device;
      Message  : in     Gnattest_M.Message'Class);

end Gnattest_P1;
---
package body Gnattest_M.Remote_Handling is
   procedure Put_Command_And_Wait_For_Result
     (Device     : access Consumer_Type;
      Command    : in out Gnattest_M.Rpc_Command_Message'Class)
   is
   begin
      Gnattest_M.Put(Device.External_Consumer, Command);
   end;
end Gnattest_M.Remote_Handling;
---
package body Gnattest_M is
   function Get_Data
     (Message : Start_Result'Class)
      return Start_Out
   is
      R : Start_Out;
   begin
      return R;
   end Get_Data;
end Gnattest_M;
---
with Gnattest_M.Remote_Handling;
package body Gnattest_P1 is
   package Start_Remote
   is new Gnattest_M.Remote_Handling
     (Consumer_Type        => Device,
      Result_Data_Type     => Gnattest_M.Start_Out,
      Result_Message_Type  => Gnattest_M.Start_Result,
      Get_Data             => Gnattest_M.Get_Data);

   procedure Put
     (Consumer : access Device;
      Message  : in     Gnattest_M.Message'Class)
   is
   begin
      null;
   end Put;
end Gnattest_P1;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-11  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_Selected_Component): If the selector is
	invisible in an instantiation, and both the formal and the actual are
	private extensions of the same type, look for the desired component in
	the proper view of the parent type.

Patch

Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 165256)
+++ sem_ch4.adb	(working copy)
@@ -3375,6 +3375,14 @@  package body Sem_Ch4 is
       Is_Single_Concurrent_Object : Boolean;
       --  Set True if the prefix is a single task or a single protected object
 
+      procedure Find_Component_In_Instance (Rec : Entity_Id);
+      --  In an instance, a component of a private extension may not be visible
+      --  while it was visible in the generic. Search candidate scope for a
+      --  component with the proper identifier. This is only done if all other
+      --  searches have failed. When the match is found (it always will be),
+      --  the Etype of both N and Sel are set from this component, and the
+      --  entity of Sel is set to reference this component.
+
       function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean;
       --  It is known that the parent of N denotes a subprogram call. Comp
       --  is an overloadable component of the concurrent type of the prefix.
@@ -3382,6 +3390,31 @@  package body Sem_Ch4 is
       --  conformant. If the parent node is not analyzed yet it may be an
       --  indexed component rather than a function call.
 
+      --------------------------------
+      -- Find_Component_In_Instance --
+      --------------------------------
+
+      procedure Find_Component_In_Instance (Rec : Entity_Id) is
+         Comp : Entity_Id;
+
+      begin
+         Comp := First_Component (Rec);
+         while Present (Comp) loop
+            if Chars (Comp) = Chars (Sel) then
+               Set_Entity_With_Style_Check (Sel, Comp);
+               Set_Etype (Sel, Etype (Comp));
+               Set_Etype (N,   Etype (Comp));
+               return;
+            end if;
+
+            Next_Component (Comp);
+         end loop;
+
+         --  This must succeed because code was legal in the generic
+
+         raise Program_Error;
+      end Find_Component_In_Instance;
+
       ------------------------------
       -- Has_Mode_Conformant_Spec --
       ------------------------------
@@ -3961,33 +3994,31 @@  package body Sem_Ch4 is
             Analyze_Selected_Component (N);
             return;
 
+         --  Similarly, if this is the actual for a formal derived type, the
+         --  component inherited from the generic parent may not be visible
+         --  in the actual, but the selected component is legal.
+
          elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private
            and then Is_Generic_Actual_Type (Prefix_Type)
            and then Present (Full_View (Prefix_Type))
          then
-            --  Similarly, if this the actual for a formal derived type, the
-            --  component inherited from the generic parent may not be visible
-            --  in the actual, but the selected component is legal.
 
-            declare
-               Comp : Entity_Id;
+            Find_Component_In_Instance
+              (Generic_Parent_Type (Parent (Prefix_Type)));
+            return;
 
-            begin
-               Comp :=
-                 First_Component (Generic_Parent_Type (Parent (Prefix_Type)));
-               while Present (Comp) loop
-                  if Chars (Comp) = Chars (Sel) then
-                     Set_Entity_With_Style_Check (Sel, Comp);
-                     Set_Etype (Sel, Etype (Comp));
-                     Set_Etype (N,   Etype (Comp));
-                     return;
-                  end if;
+         --  Finally, the formal and the actual may be private extensions,
+         --  but the generic is declared in a child unit of the parent, and
+         --  an addtional step is needed to retrieve the proper scope.
 
-                  Next_Component (Comp);
-               end loop;
+         elsif In_Instance
+           and then Present (Parent_Subtype (Etype (Base_Type (Prefix_Type))))
+         then
+            Find_Component_In_Instance
+              (Parent_Subtype (Etype (Base_Type (Prefix_Type))));
+            return;
 
-               pragma Assert (Etype (N) /= Any_Type);
-            end;
+         --  Component not found, specialize error message when appropriate
 
          else
             if Ekind (Prefix_Type) = E_Record_Subtype then