From patchwork Thu Jun 11 10:00:09 2020 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: 1307415 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=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 49jKBX4QMCz9sRN for ; Thu, 11 Jun 2020 20:01:24 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 860F43954827; Thu, 11 Jun 2020 10:00:20 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [IPv6:2620:20:4000:0:a9e:1ff:fe9b:1d1]) by sourceware.org (Postfix) with ESMTP id D652A39540ED for ; Thu, 11 Jun 2020 10:00:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org D652A39540ED Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 89E2E117CE2; Thu, 11 Jun 2020 06:00:10 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com 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 bPO8bXYLlt8V; Thu, 11 Jun 2020 06:00:10 -0400 (EDT) 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 EF2EC117CF9; Thu, 11 Jun 2020 06:00:09 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id EE32E15C; Thu, 11 Jun 2020 06:00:09 -0400 (EDT) Date: Thu, 11 Jun 2020 06:00:09 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] Put_Image attribute Message-ID: <20200611100009.GA90763@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-3.2 required=5.0 tests=BAYES_00, JMQ_SPF_NEUTRAL, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=no autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) 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: , Cc: Bob Duff Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" Work around the fact that Put_Image doesn't work for private types whose full type is real. Make Put_Image_Unknown print out the name of the type. Put_Image is still disabled by default for all types. Tested on x86_64-pc-linux-gnu, committed on trunk 2020-06-11 Bob Duff gcc/ada/ * exp_put_image.adb (Build_Elementary_Put_Image_Call): If the underlying type is real, call Put_Image_Unknown. (Build_Unknown_Put_Image_Call): Pass the type name to Put_Image_Unknown. * libgnat/s-putima.ads, libgnat/s-putima.adb (Put_Image_Unknown): Add Type_Name parameter. Remove overly-detailed documentation of what it does; better to leave it open. --- gcc/ada/exp_put_image.adb +++ gcc/ada/exp_put_image.adb @@ -27,6 +27,7 @@ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Exp_Tss; use Exp_Tss; +with Exp_Util; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; @@ -340,26 +341,34 @@ package body Exp_Put_Image is -- -- Note that this is putting a leading space for reals. + -- ???Work around the fact that Put_Image doesn't work for private + -- types whose full type is real. + + if Is_Real_Type (U_Type) then + return Build_Unknown_Put_Image_Call (N); + end if; + declare Image : constant Node_Id := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (U_Type, Loc), Attribute_Name => Name_Wide_Wide_Image, Expressions => New_List (Relocate_Node (Item))); - begin - return + Put_Call : constant Node_Id := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Put_Wide_Wide_String), Loc), Parameter_Associations => New_List (Relocate_Node (Sink), Image)); + begin + return Put_Call; end; end if; -- Unchecked-convert parameter to the required type (i.e. the type of -- the corresponding parameter), and call the appropriate routine. -- We could use a normal type conversion for scalars, but the - -- "unchecked" is needed for access types. + -- "unchecked" is needed for access and private types. declare Libent : constant Entity_Id := RTE (Lib_RE); @@ -800,7 +809,10 @@ package body Exp_Put_Image is Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Libent, Loc), Parameter_Associations => New_List ( - Relocate_Node (Sink))); + Relocate_Node (Sink), + Make_String_Literal (Loc, + Exp_Util.Fully_Qualified_Name_String ( + Entity (Prefix (N)), Append_NUL => False)))); end Build_Unknown_Put_Image_Call; ---------------------- --- gcc/ada/libgnat/s-putima.adb +++ gcc/ada/libgnat/s-putima.adb @@ -212,9 +212,11 @@ package body System.Put_Images is Put_7bit (S, ')'); end Record_After; - procedure Put_Image_Unknown (S : in out Sink'Class) is + procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String) is begin - Put_UTF_8 (S, "{unknown image}"); + Put_UTF_8 (S, "{"); + Put_String (S, Type_Name); + Put_UTF_8 (S, " object}"); end Put_Image_Unknown; end System.Put_Images; --- gcc/ada/libgnat/s-putima.ads +++ gcc/ada/libgnat/s-putima.ads @@ -86,8 +86,8 @@ package System.Put_Images is procedure Record_Between (S : in out Sink'Class); procedure Record_After (S : in out Sink'Class); - procedure Put_Image_Unknown (S : in out Sink'Class); + procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String); -- For Put_Image of types that don't have the attribute, such as type - -- Sink. Prints a canned string. + -- Sink. end System.Put_Images;