This patch fixes a spurious visibility error on a selected component in an
instance body, when the type of the prefix of the selected component is an
actual of the instance, and the desired component is inherited through
one or more derivations
The package derived.ads below must compile quietly:
--
package AST is
type AST_Node_Type is abstract tagged private;
type AST_Node_Access is access AST_Node_Type;
type AST_Node is access all AST_Node_Type'Class;
procedure Compute_Indent_Level (Node : access AST_Node_Type) is abstract;
private
type AST_Node_Type is abstract tagged record
Indent_Level : Natural;
end record;
end AST;
---
generic
type Node_Type is abstract new AST_Node_Type with private;
type Node is access all Node_Type'Class;
package AST.List is
type List_Type is new AST_Node_Type with record
N : Node;
end record;
overriding
procedure Compute_Indent_Level (Node : access List_Type);
end AST.List;
package body AST.List is
overriding
procedure Compute_Indent_Level (Node : access List_Type) is
begin
Node.N.Indent_Level := Node.Indent_Level;
end Compute_Indent_Level;
end AST.List;
---
with AST; use AST;
with AST.List;
package Derived is
type Derived_Type is abstract new AST_Node_Type with null record;
type Derived is access all Derived_Type'Class;
package Lists is new AST.List
(Node_Type => Derived_Type,
Node => Derived);
end Derived;
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-05-27 Ed Schonberg <schonb...@adacore.com>
* sem_ch4.adb (Analyze_Selected_Component): If the type to use
is a derived type and is a generic actual, the selected component
appears within an instance body, and the check over the type
has failed, examine ancestor types for the desired component.
(Find_Component_In_Instance): If record type is a derived type,
examine all ancestors in order to locate desired component.
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 223754)
+++ sem_ch4.adb (working copy)
@@ -4102,7 +4102,8 @@
-- searches have failed. If a match is found, the Etype of both N and
-- Sel are set from this component, and the entity of Sel is set to
-- reference this component. If no match is found, Entity (Sel) remains
- -- unset.
+ -- unset. For a derived type that is an actual of the instance, the
+ -- desired component may be found in any ancestor.
function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean;
-- It is known that the parent of N denotes a subprogram call. Comp
@@ -4117,18 +4118,36 @@
procedure Find_Component_In_Instance (Rec : Entity_Id) is
Comp : Entity_Id;
+ Typ : Entity_Id;
begin
- Comp := First_Component (Rec);
- while Present (Comp) loop
- if Chars (Comp) = Chars (Sel) then
- Set_Entity_With_Checks (Sel, Comp);
- Set_Etype (Sel, Etype (Comp));
- Set_Etype (N, Etype (Comp));
+ Typ := Rec;
+ while Present (Typ) loop
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Sel) then
+ Set_Entity_With_Checks (Sel, Comp);
+ Set_Etype (Sel, Etype (Comp));
+ Set_Etype (N, Etype (Comp));
+ return;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- If not found, the component may be declared in the parent
+ -- type or its full view, if any.
+
+ if Is_Derived_Type (Typ) then
+ Typ := Etype (Typ);
+
+ if Is_Private_Type (Typ) then
+ Typ := Full_View (Typ);
+ end if;
+
+ else
return;
end if;
-
- Next_Component (Comp);
end loop;
-- If we fall through, no match, so no changes made
@@ -4789,6 +4808,18 @@
Par := Etype (Par);
end loop;
+ -- Another special case: the type is an extension of a private
+ -- type T, is an actual in an instance, and we are in the body
+ -- of the instance, so the generic body had a full view of the
+ -- type declaration for T or of some ancestor that defines the
+ -- component in question.
+
+ elsif Is_Derived_Type (Type_To_Use)
+ and then Used_As_Generic_Actual (Type_To_Use)
+ and then In_Instance_Body
+ then
+ Find_Component_In_Instance (Parent_Subtype (Type_To_Use));
+
-- In ASIS mode the generic parent type may be absent. Examine
-- the parent type directly for a component that may have been
-- visible in a parent generic unit.
