From patchwork Fri Jun 18 09:07:16 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56153 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]) by ozlabs.org (Postfix) with SMTP id 05DD31007D2 for ; Fri, 18 Jun 2010 19:07:07 +1000 (EST) Received: (qmail 17631 invoked by alias); 18 Jun 2010 09:07:05 -0000 Received: (qmail 17612 invoked by uid 22791); 18 Jun 2010 09:07:03 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 18 Jun 2010 09:06:59 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 9C1BDCB01F8; Fri, 18 Jun 2010 11:07:06 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id 1Gkbsex7d2zm; Fri, 18 Jun 2010 11:07:06 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 7918ACB01E2; Fri, 18 Jun 2010 11:07:06 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 959D2D9B31; Fri, 18 Jun 2010 11:07:16 +0200 (CEST) Date: Fri, 18 Jun 2010 11:07:16 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Type compatibility of anonymous access to extensions of constrained types Message-ID: <20100618090716.GA1039@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes 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 If the context is an anonymous access whose designated type is class_wide, the designated type of the expression must be a descendant of the designated type of the context. In the presence of private extensions of constrained types, the type of the expression may be private, and we must examine its full view to determine whether the expression is legal. The predicate Ancestor examined the full view for one of its arguments only. This patch makes this privacy-breaking symmetric. The following must compile quietly: with P; use P; package X is type Child_1_3_Ptr is access all P.Child_1_3; type Child_1_3_Ptr_Class is access all P.Child_1_3'Class; procedure Call; end X; --- package body X is procedure Proc (This : access Child_1_3'Class) is begin null; end Proc; procedure Call is Res : Child_1_3_Ptr_Class := new Child_1_3; Res2 : Child_1_3_Ptr_Class := new Child_1_3'Class'(Res.all); V1 : Child_1_3_Ptr := new Child_1_3; begin Proc (V1); end Call; end X; --- package P is type Root_1 (V : Integer) is tagged record null; end record; type Child_1_3 is new Root_1 (1) with private; private type Child_1_3 is new Root_1 (1) with null record; end P; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-18 Ed Schonberg * sem_type.adb (Is_Ancestor): If either type is private, examine full view. Index: sem_type.adb =================================================================== --- sem_type.adb (revision 160959) +++ sem_type.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2554,9 +2554,9 @@ package body Sem_Type is BT1 := Base_Type (T1); BT2 := Base_Type (T2); - -- Handle underlying view of records with unknown discriminants - -- using the original entity that motivated the construction of - -- this underlying record view (see Build_Derived_Private_Type). + -- Handle underlying view of records with unknown discriminants using + -- the original entity that motivated the construction of this + -- underlying record view (see Build_Derived_Private_Type). if Is_Underlying_Record_View (BT1) then BT1 := Underlying_Record_View (BT1); @@ -2569,12 +2569,20 @@ package body Sem_Type is if BT1 = BT2 then return True; + -- The predicate must look past privacy + elsif Is_Private_Type (T1) and then Present (Full_View (T1)) and then BT2 = Base_Type (Full_View (T1)) then return True; + elsif Is_Private_Type (T2) + and then Present (Full_View (T2)) + and then BT1 = Base_Type (Full_View (T2)) + then + return True; + else Par := Etype (BT2);