From patchwork Thu Apr 25 10:24:35 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 239466 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 6A4562C010E for ; Thu, 25 Apr 2013 20:24:49 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=RDHtI/6LtyHsTNrI4rHsgm19OGVw8Mkxyxzo+BR4zrvfe17OGy Ntb8M21RJJPugDgd1O5pZjotn73xt9su+gB/XO6mxWuP/ZYrakI/hMWgTQ7abf3G puvv+eAMWL54Rt/I/IrpMXLHce6G1d7wkPBwz/QU62oW/GzLs0rrrWWQ8= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=W5+2jVDbRMU3i0vwDjckrv2k3kk=; b=qRPam1Ri5WT1fMyRxDN8 xB2fK9NuJeCuP7GTvIZInZ8KA0SkmJ13tlezj5TR5Q+97NlG108hb5ZRE3aIcjpz Bdctr39aEebxHgiwECbkNBo3wX6Px/+YJzoif1W4iWTqqanJKSGgZGt/3sDd8M4l Z6e21uFS5CZ7SnzizeSMhLw= Received: (qmail 19167 invoked by alias); 25 Apr 2013 10:24:38 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 19133 invoked by uid 89); 25 Apr 2013 10:24:38 -0000 X-Spam-SWARE-Status: No, score=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO autolearn=ham version=3.3.1 Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Thu, 25 Apr 2013 10:24:37 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id CC7242E890; Thu, 25 Apr 2013 06:24:35 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id Yq3+-DiNmeEH; Thu, 25 Apr 2013 06:24:35 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 8DFE92ED6A; Thu, 25 Apr 2013 06:24:35 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 8BE493FF09; Thu, 25 Apr 2013 06:24:35 -0400 (EDT) Date: Thu, 25 Apr 2013 06:24:35 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Illegal selected components of types derived from private types Message-ID: <20130425102435.GA5034@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) X-Virus-Found: No 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 * 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