From patchwork Wed Dec 1 10:26:08 2021 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: 48347 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 7F327385800D for ; Wed, 1 Dec 2021 10:51:01 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 7F327385800D DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1638355861; bh=n8492vHHCCVYxuTRzoxzVoQ3+s+W3oXclt4ptOarUaw=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=AC9CJo425vHk4Kt1b98iLTsWCYs6ymbQ6nJiMFtF6jj3b+h62ZgmSoHecg2dKMpQs NcDHUcCp8ErR1a013BIgGkeNe6YiItH2EDyE2aqd9Suh5SX32MqByeqt6xumoRPIvj rWIE3Op/DRypSOg3WaWW8poDdGzftvjrpjfhZhfA= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42a.google.com (mail-wr1-x42a.google.com [IPv6:2a00:1450:4864:20::42a]) by sourceware.org (Postfix) with ESMTPS id B20DB3858003 for ; Wed, 1 Dec 2021 10:26:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org B20DB3858003 Received: by mail-wr1-x42a.google.com with SMTP id q3so28214339wru.5 for ; Wed, 01 Dec 2021 02:26:11 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=n8492vHHCCVYxuTRzoxzVoQ3+s+W3oXclt4ptOarUaw=; b=vVE1911sRoEhaqzyruzWLc0s3kTjkPO2/j9v0PvdRDjdoUxd04GpEtpP5iXcyC+KnD 7tkD0Ap3pxGWLI2SsTHrF/3gu/RNUx6/ItIrFjdNbycbuiUxYWuWQVhHrZFhx+MY3dSI RNfASp0fzPtqROdZs0j6snCkc5jbug2oipGvriwLsGJES9bQvJuYrImrWKwCHkrx0crQ ggCnWxYPcSlZWZHwGTxBZWsm/XByUc5heIANSBWTuS2DFIbNG7f1JHshHZ5RrYSPpGWI MrUD7l+FHyoZTtFOnldK5vVjDJVtGKkZqs48OeUTohkGApEcoi1PVo8HZS3IpcinCUJy gXRQ== X-Gm-Message-State: AOAM530XQ/EEHGW35TNJJ8bUbC0FKsMz4EZImhCm2plnuNR/MarUrZuE dJF87PonpuKUJrXyxgKLT7QM3RFlsg5IxXpk X-Google-Smtp-Source: ABdhPJwvI1B9OZkaF1YERIdSTRP02xGZVnFLf8LQkbsQ2Xq9pLfTOt0ITFWYS3lEVULaaDw4YoZjUA== X-Received: by 2002:adf:f542:: with SMTP id j2mr5499676wrp.616.1638354370738; Wed, 01 Dec 2021 02:26:10 -0800 (PST) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id k37sm673439wms.21.2021.12.01.02.26.09 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 01 Dec 2021 02:26:09 -0800 (PST) Date: Wed, 1 Dec 2021 10:26:08 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Fix incorrect fixed-point computation in expression function Message-ID: <20211201102608.GA1635750@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-13.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Eric Botcazou Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This fixes a couple of issues pertaining to (ordinary) fixed-point types declared with a Small aspect whose value is not equal to the default one. The processing of this aspect is delayed until the freeze point of the type, which means that the Small_Value of the entity for the type does not have the right value until after the freeze point is encountered. The first issue is that Resolve_Real_Literal could use the Small_Value of the entity for an unfrozen type, for example during the pre-analysis of a default expression or of an expression function. The second issue is that Freeze_Fixed_Point_Type could still use the old value of Small_Value even after it has set the field to its final value. It could also overwrite a correct Small_Value with garbage in the case of the subtype of a private fixed-point type. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * einfo.ads (E_Decimal_Fixed_Point_Subtype): Fix pasto. * freeze.adb (Freeze_Fixed_Point_Type): Retrieve the underlying type of the first subtype and do not use a stale value of Small_Value. * sem_res.adb (Resolve_Real_Literal): In the case of a fixed-point type, make sure that the base type is frozen and use its Small_Value to compute the corresponding integer value of the literal. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -5353,7 +5353,7 @@ package Einfo is -- Size_Clause (synth) -- E_Decimal_Fixed_Point_Type - -- E_Decimal_Fixed_Subtype$$$no such thing + -- E_Decimal_Fixed_Point_Subtype -- Scale_Value -- Digits_Value -- Scalar_Range diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -8997,8 +8997,9 @@ package body Freeze is Brng : constant Node_Id := Scalar_Range (Btyp); BLo : constant Node_Id := Low_Bound (Brng); BHi : constant Node_Id := High_Bound (Brng); - Par : constant Entity_Id := First_Subtype (Typ); - Small : constant Ureal := Small_Value (Typ); + Ftyp : constant Entity_Id := Underlying_Type (First_Subtype (Typ)); + + Small : Ureal; Loval : Ureal; Hival : Ureal; Atype : Entity_Id; @@ -9037,7 +9038,7 @@ package body Freeze is function Larger (A, B : Ureal) return Boolean is begin - return A > B and then A - Small > B; + return A > B and then A - Small_Value (Typ) > B; end Larger; ------------- @@ -9046,7 +9047,7 @@ package body Freeze is function Smaller (A, B : Ureal) return Boolean is begin - return A < B and then A + Small < B; + return A < B and then A + Small_Value (Typ) < B; end Smaller; -- Start of processing for Freeze_Fixed_Point_Type @@ -9057,9 +9058,15 @@ package body Freeze is -- so that all characteristics of the type (size, bounds) can be -- computed and validated in the call to Minimum_Size that follows. - if Has_Delayed_Aspects (First_Subtype (Typ)) then - Analyze_Aspects_At_Freeze_Point (First_Subtype (Typ)); - Set_Has_Delayed_Aspects (First_Subtype (Typ), False); + if Has_Delayed_Aspects (Ftyp) then + Analyze_Aspects_At_Freeze_Point (Ftyp); + Set_Has_Delayed_Aspects (Ftyp, False); + end if; + + -- Inherit the Small value from the first subtype in any case + + if Typ /= Ftyp then + Set_Small_Value (Typ, Small_Value (Ftyp)); end if; -- If Esize of a subtype has not previously been set, set it now @@ -9074,16 +9081,6 @@ package body Freeze is end if; end if; - -- The 'small attribute may have been specified with an aspect, - -- in which case it is processed after a subtype declaration, so - -- inherit now the specified value. - - if Typ /= Par - and then Present (Find_Aspect (Par, Aspect_Small)) - then - Set_Small_Value (Typ, Small_Value (Par)); - end if; - -- Immediate return if the range is already analyzed. This means that -- the range is already set, and does not need to be computed by this -- routine. @@ -9100,6 +9097,7 @@ package body Freeze is return; end if; + Small := Small_Value (Typ); Loval := Realval (Lo); Hival := Realval (Hi); @@ -9137,7 +9135,6 @@ package body Freeze is Size_Excl_EP : Int; Model_Num : Ureal; - First_Subt : Entity_Id; Actual_Lo : Ureal; Actual_Hi : Ureal; @@ -9279,10 +9276,8 @@ package body Freeze is -- to get a base type whose size is smaller than the specified -- size of the first subtype. - First_Subt := First_Subtype (Typ); - - if Has_Size_Clause (First_Subt) - and then Size_Incl_EP <= Esize (First_Subt) + if Has_Size_Clause (Ftyp) + and then Size_Incl_EP <= Esize (Ftyp) then Actual_Size := Size_Incl_EP; Actual_Lo := Loval_Incl_EP; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -10765,17 +10765,23 @@ package body Sem_Res is begin -- Special processing for fixed-point literals to make sure that the - -- value is an exact multiple of small where this is required. We skip - -- this for the universal real case, and also for generic types. + -- value is an exact multiple of the small where this is required. We + -- skip this for the universal real case, and also for generic types. if Is_Fixed_Point_Type (Typ) and then Typ /= Universal_Fixed and then Typ /= Any_Fixed and then not Is_Generic_Type (Typ) then + -- We must freeze the base type to get the proper value of the small + + if not Is_Frozen (Base_Type (Typ)) then + Freeze_Fixed_Point_Type (Base_Type (Typ)); + end if; + declare Val : constant Ureal := Realval (N); - Cintr : constant Ureal := Val / Small_Value (Typ); + Cintr : constant Ureal := Val / Small_Value (Base_Type (Typ)); Cint : constant Uint := UR_Trunc (Cintr); Den : constant Uint := Norm_Den (Cintr); Stat : Boolean;