From patchwork Thu Dec 12 10:04:31 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1208340 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-515785-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="okstEzFW"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 47YTw331Gzz9sPf for ; Thu, 12 Dec 2019 21:06:04 +1100 (AEDT) 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=hBv7cqXDWROCYQ6/m7QAoha7dN3qv1egMYdJVlOnOX2Vk8Vw1D MKlKapgDlt8TKdAiZniqadJbqnY3AaBfOp2Pg0hYMJr+m5NnSABsUQ7ZD0wy9HCD vL6COtbynU49ltgxUiEeBmf2ySuD10t6h9TRQrTElhak4TYZEjZJ45fac= 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=bW0qZIDzC3o6xmEKknq3vn693Ic=; b=okstEzFW80eaI8ST3iUu VrGjjAkGjKbMwFvG004KITTEwJ2pSGhbCC5FtYMRPV+tjywvptXOAprNwF9+Fmvg 5f15orkyH7if96NUs6fGKZO6Lj2lwrVeL3Ma3z0fcTWofyLBvYy+zOSJRVNpi61f c1WHGZO0D+FHVbgJM9Z++34= Received: (qmail 37099 invoked by alias); 12 Dec 2019 10:04:37 -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 37022 invoked by uid 89); 12 Dec 2019 10:04:37 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=resolves X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 12 Dec 2019 10:04:35 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 5DA2D560DB; Thu, 12 Dec 2019 05:04:31 -0500 (EST) 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 wRge6Zyklaz9; Thu, 12 Dec 2019 05:04:31 -0500 (EST) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 358B9560D4; Thu, 12 Dec 2019 05:04:31 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id 3459213B; Thu, 12 Dec 2019 05:04:31 -0500 (EST) Date: Thu, 12 Dec 2019 05:04:31 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Justin Squirek Subject: [Ada] Broken privacy on Controlled type extensions Message-ID: <20191212100431.GA114793@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes This patch fixes an issue whereby the compiler incorrectly resolves non-visible controlled primitives such as the case where predefined controlled operations get called on a type extension whose parent is a private extension completed with a controlled extension. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-12-12 Justin Squirek gcc/ada/ * sem_ch4.adb (Analyze_One_Call): Add condition to check for incorrectly resolved hidden controlled primitives. --- gcc/ada/sem_ch4.adb +++ gcc/ada/sem_ch4.adb @@ -3249,6 +3249,7 @@ package body Sem_Ch4 is -- is already known to be compatible, and because this may be an -- indexing of a call with default parameters. + First_Form : Entity_Id; Formal : Entity_Id; Actual : Node_Id; Is_Indexed : Boolean := False; @@ -3581,8 +3582,9 @@ package body Sem_Ch4 is -- Normalize_Actuals has chained the named associations in the -- correct order of the formals. - Actual := First_Actual (N); - Formal := First_Formal (Nam); + Actual := First_Actual (N); + Formal := First_Formal (Nam); + First_Form := Formal; -- If we are analyzing a call rewritten from object notation, skip -- first actual, which may be rewritten later as an explicit @@ -3742,6 +3744,54 @@ package body Sem_Ch4 is end if; end loop; + -- Due to our current model of controlled type expansion we may + -- have resolved a user call to a non-visible controlled primitive + -- since these inherited subprograms may be generated in the current + -- scope. This is a side-effect of the need for the expander to be + -- able to resolve internally generated calls. + + -- Specifically, the issue appears when predefined controlled + -- operations get called on a type extension whose parent is a + -- private extension completed with a controlled extension - see + -- below: + + -- package X is + -- type Par_Typ is tagged private; + -- private + -- type Par_Typ is new Controlled with null record; + -- end; + -- ... + -- procedure Main is + -- type Ext_Typ is new Par_Typ with null record; + -- Obj : Ext_Typ; + -- begin + -- Finalize (Obj); -- Will improperly resolve + -- end; + + -- To avoid breaking privacy, Is_Hidden gets set elsewhere on such + -- primitives, but we still need to verify that Nam is indeed a + -- controlled subprogram. So, we do that here and issue the + -- appropriate error. + + if Is_Hidden (Nam) + and then not In_Instance + and then not Comes_From_Source (Nam) + and then Comes_From_Source (N) + + -- Verify Nam is a controlled primitive + + and then Nam_In (Chars (Nam), Name_Adjust, + Name_Finalize, + Name_Initialize) + and then Ekind (Nam) = E_Procedure + and then Is_Controlled (Etype (First_Form)) + and then No (Next_Formal (First_Form)) + then + Error_Msg_Node_2 := Etype (First_Form); + Error_Msg_NE ("call to non-visible controlled primitive & on type" + & " &", N, Nam); + end if; + -- On exit, all actuals match Indicate_Name_And_Type;