From patchwork Fri Dec 13 09:55:01 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: 1209052 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-515851-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="TibBmvlJ"; 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 47Z5dl3sfNz9sPL for ; Fri, 13 Dec 2019 20:55:55 +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=Hv2Tzvp9jEHbabcWVUPtCKXv4+5/I0+Kfb/dQxZFXhhyI+IwAE j7bS0ffvnq770bBjWmFV64Uz1WxD8Np5i8gdq51rYC38/juRanKEFNVtki3Bj+gj 1KrmH+MNp2cgg2o+LDYotWSXnKttrto902BQP0r7EAVeZzVfGfKgmsH4g= 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=uOBDtBw/cXEVoTsbG2pEeKYIung=; b=TibBmvlJd23YyU2+fZtb jLnJCrpHTmmYwj6TIAwNStBTKJIeaOvaoRkPfQsd+5xGrvlfN6FFpVoX+zw5L1LJ wHwwOLLdovs6SMuQSdJk1+5qHe55KrtMerMWBp7LcGXkqOJpIdQo3b3d2QDjnEq0 ZSYDfUUC2b0iO/pnN2hnOYI= Received: (qmail 36625 invoked by alias); 13 Dec 2019 09:55:08 -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 36486 invoked by uid 89); 13 Dec 2019 09:55:06 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=incremental, Alternatives, sem_res, sk:check_a 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; Fri, 13 Dec 2019 09:55:03 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 9C2E1560C9; Fri, 13 Dec 2019 04:55:01 -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 NrmzGZILbjlU; Fri, 13 Dec 2019 04:55:01 -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 7F9DE560A7; Fri, 13 Dec 2019 04:55:01 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id 7ECC3157; Fri, 13 Dec 2019 04:55:01 -0500 (EST) Date: Fri, 13 Dec 2019 04:55:01 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Justin Squirek Subject: [Ada] Missing accessibility checks on conditionals Message-ID: <20191213095501.GA13899@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes This is an incremental patch which fixes a compiler error whereby accessbility checks on if and case expressions used to set access discriminants within allocators were not performed. It also corrects an issue where dynamic accessibility levels are not passed correctly when a conditional expression is used as an actual of an anonymous access formal in the limited case that it is constant folded. Further work is needed for the general case of dynamic accessbility. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-12-13 Justin Squirek gcc/ada/ * sem_res.adb (Resolve_Allocator): Add calls to Check_Cond_Expr_Accessibility when a conditional expression is found. (Check_Allocator_Discrim_Accessibility_Exprs): Created to recursively traverse a potentially compound conditional expression and perform accessibility checks for each alternative. * sem_util.adb (Dynamic_Accessibility_Level): Avoid use of original node of the expression in question so we can handle dynamic accessibility in the limited case of a constant folded conditional expression. --- gcc/ada/sem_res.adb +++ gcc/ada/sem_res.adb @@ -4965,6 +4965,12 @@ package body Sem_Res is -- the cases of a constraint expression which is an access attribute or -- an access discriminant. + procedure Check_Allocator_Discrim_Accessibility_Exprs + (Curr_Exp : Node_Id; + Alloc_Typ : Entity_Id); + -- Dispatch checks performed by Check_Allocator_Discrim_Accessibility + -- across all expressions within a given conditional expression. + function In_Dispatching_Context return Boolean; -- If the allocator is an actual in a call, it is allowed to be class- -- wide when the context is not because it is a controlling actual. @@ -5016,6 +5022,62 @@ package body Sem_Res is end if; end Check_Allocator_Discrim_Accessibility; + ------------------------------------------------- + -- Check_Allocator_Discrim_Accessibility_Exprs -- + ------------------------------------------------- + + procedure Check_Allocator_Discrim_Accessibility_Exprs + (Curr_Exp : Node_Id; + Alloc_Typ : Entity_Id) + is + Alt : Node_Id; + Expr : Node_Id; + Disc_Exp : constant Node_Id := Original_Node (Curr_Exp); + begin + -- When conditional expressions are constant folded we know at + -- compile time which expression to check - so don't bother with + -- the rest of the cases. + + if Nkind (Curr_Exp) = N_Attribute_Reference then + Check_Allocator_Discrim_Accessibility (Curr_Exp, Alloc_Typ); + + -- Non-constant-folded if expressions + + elsif Nkind (Disc_Exp) = N_If_Expression then + -- Check both expressions if they are still present in the face + -- of expansion. + + Expr := Next (First (Expressions (Disc_Exp))); + if Present (Expr) then + Check_Allocator_Discrim_Accessibility_Exprs (Expr, Alloc_Typ); + Expr := Next (Expr); + if Present (Expr) then + Check_Allocator_Discrim_Accessibility_Exprs + (Expr, Alloc_Typ); + end if; + end if; + + -- Non-constant-folded case expressions + + elsif Nkind (Disc_Exp) = N_Case_Expression then + -- Check all alternatives + + Alt := First (Alternatives (Disc_Exp)); + while Present (Alt) loop + Check_Allocator_Discrim_Accessibility_Exprs + (Expression (Alt), Alloc_Typ); + + Next (Alt); + end loop; + + -- Base case, check the accessibility of the original node of the + -- expression. + + else + Check_Allocator_Discrim_Accessibility (Disc_Exp, Alloc_Typ); + end if; + end Check_Allocator_Discrim_Accessibility_Exprs; + ---------------------------- -- In_Dispatching_Context -- ---------------------------- @@ -5167,7 +5229,8 @@ package body Sem_Res is while Present (Discrim) and then Present (Disc_Exp) loop if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then - Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + Check_Allocator_Discrim_Accessibility_Exprs + (Disc_Exp, Typ); end if; Next_Discriminant (Discrim); @@ -5225,12 +5288,13 @@ package body Sem_Res is while Present (Discrim) and then Present (Constr) loop if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then if Nkind (Constr) = N_Discriminant_Association then - Disc_Exp := Original_Node (Expression (Constr)); + Disc_Exp := Expression (Constr); else - Disc_Exp := Original_Node (Constr); + Disc_Exp := Constr; end if; - Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + Check_Allocator_Discrim_Accessibility_Exprs + (Disc_Exp, Typ); end if; Next_Discriminant (Discrim); --- gcc/ada/sem_util.adb +++ gcc/ada/sem_util.adb @@ -6612,6 +6612,13 @@ package body Sem_Util is end if; end if; + -- Handle a constant-folded conditional expression by avoiding use of + -- the original node. + + if Nkind_In (Expr, N_Case_Expression, N_If_Expression) then + Expr := N; + end if; + -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? case Nkind (Expr) is