This patch fixes a gap in the visibility machinery, that allowed the use
of selected component notation on objects of a private type derived from
other private types with a private full view.
Compiling foo.adb must yield:
foo.adb:7:29: no selector "Exists"
for type "Optional_Rate_Of_Turn_T" defined at fee.ads:29
foo.adb:9:53: no selector "Value"
for type "Optional_Rate_Of_Turn_Value_T" defined at fee.ads:16
---
package Foo is
function F return Boolean;
function F return Float;
end Foo;
---
with Fee;
package body Foo is
O : Fee.Optional_Rate_Of_Turn_T;
B1 : constant Boolean := O.Exists;
V1 : constant Fee.Si_Float := Fee.Value (Fee.Value (O).Value); -- OK
V2 : constant Fee.Si_Float := Fee.Value (O).Value.Value; -- Not OK
function F return Boolean is
begin
return True; -- B1;
end F;
function F return Float is
begin
return V2;
end F;
end Foo;
---
package body Apre_Optional is
function Exists (V : T) return Boolean is
begin
return V.Exists;
end Exists;
function No_Value return T is
begin
return (Exists => False);
end No_Value;
function Value (V : T) return Value_Type_T is
begin
return V.Value;
end Value;
function Value (V : Value_Type_T) return T is
begin
return (Exists => True, Value => V);
end Value;
function Evaluate (V : T) return Value_Type_T is
begin
if V.Exists then
return V.Value;
else
return Default_Value;
end if;
end Evaluate;
end Apre_Optional;
generic
-- The type of value that might exist.
--
type Value_Type_T is private;
-- The value is return from the function Value if exists is false.
--
Default_Value : Value_Type_T;
package Apre_Optional is
type T is private;
function Exists (V : T) return Boolean;
function No_Value return T;
function Value (V : Value_Type_T) return T;
function Value (V : T) return Value_Type_T;
function Evaluate (V : T) return Value_Type_T;
private
package Fix is
type T (Exists : Boolean := False) is
record
case Exists is
when False =>
null;
when True =>
Value : Value_Type_T;
end case;
end record;
end Fix;
type T is new Fix.T;
end Apre_Optional;
---
with Apre_Optional;
package Fee is
subtype Si_Float is Float;
package Optional_Float is new Apre_Optional (Si_Float, Si_Float'Last);
type Optional_Float_T is new Optional_Float.T;
type Rate_Of_Turn_T is
(Left,
Right,
Straight,
Not_Availible);
type Optional_Rate_Of_Turn_Value_T is new Optional_Float_T;
type Rate_Of_Turn_Fields_T is
record
Rate_Of_Turn : Rate_Of_Turn_T := Not_Availible;
Value : Optional_Rate_Of_Turn_Value_T := No_Value;
end record;
Null_Rate_Of_Turn_Fields : constant Rate_Of_Turn_Fields_T :=
(Rate_Of_Turn => Not_Availible,
Value => No_Value);
package Optional_Rate_Of_Turn is new
Apre_Optional (Rate_Of_Turn_Fields_T, Null_Rate_Of_Turn_Fields);
type Optional_Rate_Of_Turn_T is new Optional_Rate_Of_Turn.T;
end Fee;
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-04-25 Ed Schonberg <schonb...@adacore.com>
* einfo.ads: Extend documentation on use of Is_Private_Ancestor
for untagged types.
* sem_ch3.adb (Is_Visible_Component): Refine predicate for the
case of untagged types derived from private types, to reject
illegal selected components.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 198244)
+++ sem_ch3.adb (working copy)
@@ -16468,10 +16468,15 @@
Type_Scope := Scope (Base_Type (Scope (C)));
end if;
- -- This test only concerns tagged types
+ -- For an untagged type derived from a private type, the only
+ -- visible components are new discriminants.
if not Is_Tagged_Type (Original_Scope) then
- return True;
+ return not Has_Private_Ancestor (Original_Scope)
+ or else In_Open_Scopes (Scope (Original_Scope))
+ or else
+ (Ekind (Original_Comp) = E_Discriminant
+ and then Original_Scope = Type_Scope);
-- If it is _Parent or _Tag, there is no visibility issue
@@ -17383,8 +17388,6 @@
-- now. We have to create a new entity with the same name, Thus we
-- can't use Create_Itype.
- -- This is messy, should be fixed ???
-
Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
Set_Is_Itype (Full);
Set_Associated_Node_For_Itype (Full, Related_Nod);
Index: einfo.ads
===================================================================
--- einfo.ads (revision 198283)
+++ einfo.ads (working copy)
@@ -1753,12 +1753,14 @@
-- is defined for the type.
-- Has_Private_Ancestor (Flag151)
--- Applies to type extensions. True if some ancestor is derived from a
--- private type, making some components invisible and aggregates illegal.
--- This flag is set at the point of derivation. The legality of the
--- aggregate must be rechecked because it also depends on the visibility
--- at the point the aggregate is resolved. See sem_aggr.adb.
--- This is part of AI05-0115.
+-- Applies to untagged derived types and to type extensions. True when
+-- some ancestor is derived from a private type, making some components
+-- invisible and aggregates illegal. Used to check the legality of
+-- selected components and aggregates. The flag is set at the point of
+-- derivation.
+-- The legality of an aggregate of a type with a private ancestor must
+-- be checked because it also depends on the visibility at the point the
+-- aggregate is resolved. See sem_aggr.adb. This is part of AI05-0115.
-- Has_Private_Declaration (Flag155)
-- Defined in all entities. Returns True if it is the defining entity
