From patchwork Thu Jan 11 09:14:51 2018 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: 858961 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-470807-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="XhFEFsAi"; 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 3zHKw70zt7z9t3F for ; Thu, 11 Jan 2018 20:15:02 +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=DtXeug7WtEa/qdY2i6wLlLdBkSdJN4V1MlZ5PmdzM9b6Ek/xO+ qYzE28BNad9+stJYyFIUEmwBss9ue5LlTPO2At0jjRxmsVXKbAZCTyl1ggyPRFhS 7w/EfuyTHLVcNEpuu9gnJ/zHQf5JElLvSC8/28Q077VGr2IUPnr55TXNI= 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=rsQxY402nQRSh5NzXTG4XzSGtaw=; b=XhFEFsAiPbj8g2jPrAer LqCDWZUg/xr7lJbBe7TUIgm4zhXIxSKOdrFE74ULp+woNhpbuQsbD6C2F8/3tok5 bCJBklZGYOR0aTqgiMmZb4qAR4mAImrudX5VHzO4+qMBz/y9B+Liof2bw43L/auX n75HPddWO5fgW++/sz2MSjY= Received: (qmail 87062 invoked by alias); 11 Jan 2018 09:14:55 -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 85921 invoked by uid 89); 11 Jan 2018 09:14:54 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=adapts, Hx-languages-length:3433 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, 11 Jan 2018 09:14:53 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id E1FA3117BC3; Thu, 11 Jan 2018 04:14:51 -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 ijQST+cT+K2O; Thu, 11 Jan 2018 04:14:51 -0500 (EST) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id D00AA117BBE; Thu, 11 Jan 2018 04:14:51 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id CEC6D50B; Thu, 11 Jan 2018 04:14:51 -0500 (EST) Date: Thu, 11 Jan 2018 04:14:51 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [Ada] Allow uses of range utility routines on private types Message-ID: <20180111091451.GA105384@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes Frontend only calls Is_Null_Range and Not_Null_Range routines on full views of types, but backends (for example GNATprove) might call them also on private types. This patch adapts those routines to transparently retrieve the full type when called on a private type. No frontend test, because only external backends are affected. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-01-11 Piotr Trojanek gcc/ada/ * sem_eval.adb (Is_Null_Range): Retrieve the full view when called on a private (sub)type; refactor to avoid early return statement. (Not_Null_Range): Same as above. --- gcc/ada/sem_eval.adb +++ gcc/ada/sem_eval.adb @@ -4755,19 +4755,33 @@ package body Sem_Eval is ------------------- function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is - Typ : constant Entity_Id := Etype (Lo); - begin - if not Compile_Time_Known_Value (Lo) - or else not Compile_Time_Known_Value (Hi) + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) then - return False; - end if; + declare + Typ : Entity_Id := Etype (Lo); + Full_Typ : constant Entity_Id := Full_View (Typ); + begin + -- When called from the frontend, as part of the analysis of + -- potentially static expressions, Typ will be the full view of a + -- type with all the info needed to answer this query. When called + -- from the backend, for example to know whether a range of a loop + -- is null, Typ might be a private type and we need to explicitly + -- switch to its corresponding full view to access the same info. + + if Present (Full_Typ) then + Typ := Full_Typ; + end if; - if Is_Discrete_Type (Typ) then - return Expr_Value (Lo) > Expr_Value (Hi); - else pragma Assert (Is_Real_Type (Typ)); - return Expr_Value_R (Lo) > Expr_Value_R (Hi); + if Is_Discrete_Type (Typ) then + return Expr_Value (Lo) > Expr_Value (Hi); + else pragma Assert (Is_Real_Type (Typ)); + return Expr_Value_R (Lo) > Expr_Value_R (Hi); + end if; + end; + else + return False; end if; end Is_Null_Range; @@ -5330,20 +5344,35 @@ package body Sem_Eval is -------------------- function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is - Typ : constant Entity_Id := Etype (Lo); - begin - if not Compile_Time_Known_Value (Lo) - or else not Compile_Time_Known_Value (Hi) + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) then + declare + Typ : Entity_Id := Etype (Lo); + Full_Typ : constant Entity_Id := Full_View (Typ); + begin + -- When called from the frontend, as part of the analysis of + -- potentially static expressions, Typ will be the full view of a + -- type with all the info needed to answer this query. When called + -- from the backend, for example to know whether a range of a loop + -- is null, Typ might be a private type and we need to explicitly + -- switch to its corresponding full view to access the same info. + + if Present (Full_Typ) then + Typ := Full_Typ; + end if; + + if Is_Discrete_Type (Typ) then + return Expr_Value (Lo) <= Expr_Value (Hi); + else pragma Assert (Is_Real_Type (Typ)); + return Expr_Value_R (Lo) <= Expr_Value_R (Hi); + end if; + end; + else return False; end if; - if Is_Discrete_Type (Typ) then - return Expr_Value (Lo) <= Expr_Value (Hi); - else pragma Assert (Is_Real_Type (Typ)); - return Expr_Value_R (Lo) <= Expr_Value_R (Hi); - end if; end Not_Null_Range; -------------