From patchwork Tue Jun 22 16:23:24 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56526 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 ADD3FB6F0E for ; Wed, 23 Jun 2010 02:23:40 +1000 (EST) Received: (qmail 24893 invoked by alias); 22 Jun 2010 16:23:33 -0000 Received: (qmail 24723 invoked by uid 22791); 22 Jun 2010 16:23:29 -0000 X-SWARE-Spam-Status: No, hits=-0.8 required=5.0 tests=AWL, BAYES_20, TW_MG, 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; Tue, 22 Jun 2010 16:23:23 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id C4E48CB0202; Tue, 22 Jun 2010 18:23:24 +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 zO7OAlViuEUJ; Tue, 22 Jun 2010 18:23:24 +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 B2450CB01DB; Tue, 22 Jun 2010 18:23:24 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id AAF0BD9BB4; Tue, 22 Jun 2010 18:23:24 +0200 (CEST) Date: Tue, 22 Jun 2010 18:23:24 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Geert Bosch Subject: [Ada] Improve 'Image accuracy for fixed point types with decimal small Message-ID: <20100622162324.GA25577@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 While generating an image string for ordinary fixed point types may be tricky for cases of an arbitrary small, for common cases with decimal smalls accurate output is straightforward. This patch detects those cases where ordinary fixed point types do in fact have a decimal small, and reuses the 'Image code for decimal fixed point types. -- The following must compile and execute quietly procedure fi2 is begin if Duration'Image (Duration'Last) /= " 9223372036.854775807" then raise Program_Error; end if; end fi2; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-22 Geert Bosch * exp_imgv.adb (Expand_Image_Attribute): Treat ordinary fixed point with decimal small as decimal types, avoiding floating-point arithmetic. (Has_Decimal_Small): New function. * einfo.ads, einfo.adb (Aft_Value): New synthesized attributed for fixed point types. * sem_attr.adb (Eval_Attribute): Remove Aft_Value function and update callers to call the new function in Einfo that takes the entity as parameter. Index: exp_imgv.adb =================================================================== --- exp_imgv.adb (revision 161073) +++ exp_imgv.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -43,9 +43,15 @@ with Stringt; use Stringt; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; +with Urealp; use Urealp; package body Exp_Imgv is + function Has_Decimal_Small (E : Entity_Id) return Boolean; + -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an + -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. + -- Shouldn't this be in einfo.adb or sem_aux.adb??? + ------------------------------------ -- Build_Enumeration_Image_Tables -- ------------------------------------ @@ -330,7 +336,7 @@ package body Exp_Imgv is Tent := RTE (RE_Long_Long_Unsigned); end if; - elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then Imid := RE_Image_Decimal; Tent := Standard_Integer; @@ -451,6 +457,11 @@ package body Exp_Imgv is Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Aft)); + if Has_Decimal_Small (Rtyp) then + Set_Conversion_OK (First (Arg_List)); + Set_Etype (First (Arg_List), Tent); + end if; + -- For decimal, append Scale and also set to do literal conversion elsif Is_Decimal_Fixed_Point_Type (Rtyp) then @@ -1240,4 +1251,16 @@ package body Exp_Imgv is Analyze_And_Resolve (N, Typ); end Expand_Width_Attribute; + ----------------------- + -- Has_Decimal_Small -- + ----------------------- + + function Has_Decimal_Small (E : Entity_Id) return Boolean is + begin + return Is_Decimal_Fixed_Point_Type (E) + or else + (Is_Ordinary_Fixed_Point_Type (E) + and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); + end Has_Decimal_Small; + end Exp_Imgv; Index: einfo.adb =================================================================== --- einfo.adb (revision 161181) +++ einfo.adb (working copy) @@ -570,6 +570,18 @@ package body Einfo is return Flag104 (Id); end Address_Taken; + function Aft_Value (Id : E) return U is + Result : Nat := 1; + Delta_Val : Ureal := Delta_Value (Id); + begin + while Delta_Val < Ureal_Tenth loop + Delta_Val := Delta_Val * Ureal_10; + Result := Result + 1; + end loop; + + return UI_From_Int (Result); + end Aft_Value; + function Alias (Id : E) return E is begin pragma Assert Index: einfo.ads =================================================================== --- einfo.ads (revision 161183) +++ einfo.ads (working copy) @@ -350,6 +350,10 @@ package Einfo is -- make sure that the address can be meaningfully taken, and also in -- the case of subprograms to control output of certain warnings. +-- Aft_Value (synthesized) +-- Applies to fixed and decimal types. Computes a universal integer +-- that holds value of the Aft attribute for the type. + -- Alias (Node18) -- Present in overloaded entities (literals, subprograms, entries) and -- subprograms that cover a primitive operation of an abstract interface @@ -4832,6 +4836,7 @@ package Einfo is -- Small_Value (Ureal21) -- Has_Machine_Radix_Clause (Flag83) -- Machine_Radix_10 (Flag84) + -- Aft_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -5114,6 +5119,7 @@ package Einfo is -- Scalar_Range (Node20) -- Small_Value (Ureal21) -- Has_Small_Clause (Flag67) + -- Aft_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -6113,6 +6119,7 @@ package Einfo is -- so they do not correspond to defined fields in the entity itself. function Address_Clause (Id : E) return N; + function Aft_Value (Id : E) return U; function Alignment_Clause (Id : E) return N; function Base_Type (Id : E) return E; function Declaration_Node (Id : E) return N; Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 161184) +++ sem_attr.adb (working copy) @@ -4805,10 +4805,6 @@ package body Sem_Attr is -- processing, since otherwise gigi might see an attribute which it is -- unprepared to deal with. - function Aft_Value return Nat; - -- Computes Aft value for current attribute prefix (used by Aft itself - -- and also by Width for computing the Width of a fixed point type). - procedure Check_Concurrent_Discriminant (Bound : Node_Id); -- If Bound is a reference to a discriminant of a task or protected type -- occurring within the object's body, rewrite attribute reference into @@ -4880,25 +4876,6 @@ package body Sem_Attr is -- Verify that the prefix of a potentially static array attribute -- satisfies the conditions of 4.9 (14). - --------------- - -- Aft_Value -- - --------------- - - function Aft_Value return Nat is - Result : Nat; - Delta_Val : Ureal; - - begin - Result := 1; - Delta_Val := Delta_Value (P_Type); - while Delta_Val < Ureal_Tenth loop - Delta_Val := Delta_Val * Ureal_10; - Result := Result + 1; - end loop; - - return Result; - end Aft_Value; - ----------------------------------- -- Check_Concurrent_Discriminant -- ----------------------------------- @@ -5786,7 +5763,7 @@ package body Sem_Attr is --------- when Attribute_Aft => - Fold_Uint (N, UI_From_Int (Aft_Value), True); + Fold_Uint (N, Aft_Value (P_Type), True); --------------- -- Alignment -- @@ -7364,7 +7341,8 @@ package body Sem_Attr is -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) Fold_Uint - (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True); + (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), + True); end if; -- Discrete types