Patchwork [Ada] Illegal selected components of types derived from private types

login
register
mail settings
Submitter Arnaud Charlet
Date April 25, 2013, 10:24 a.m.
Message ID <20130425102435.GA5034@adacore.com>
Download mbox | patch
Permalink /patch/239466/
State New
Headers show

Comments

Arnaud Charlet - April 25, 2013, 10:24 a.m.
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  <schonberg@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.

Patch

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