===================================================================
@@ -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
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.