From patchwork Fri Oct 25 09:10:34 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 99542 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 5F9223858C41 for ; Fri, 25 Oct 2024 09:16:10 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lf1-x131.google.com (mail-lf1-x131.google.com [IPv6:2a00:1450:4864:20::131]) by sourceware.org (Postfix) with ESMTPS id 304D53858C62 for ; Fri, 25 Oct 2024 09:11:26 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 304D53858C62 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 304D53858C62 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::131 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1729847491; cv=none; b=uux4523WHfGACZhhYbd4EtqcfLmZMWV/B058XjtjG6C1BpsbSBLgea7QfkXqov2gvLERYITs3t2cG5XYDM5fyBzI+JkLTJoUcB3UjKLkhi4KwOp89GlAsahd/OjIDbrolrXzZYcuNPUweQKxQwQPAiSxgpIcDHTj0AAtwIZL2Ao= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1729847491; c=relaxed/simple; bh=uEeFKRUtr76XLjS+XUoi2DqD77gNPbITkApHq56kTiA=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=Iu7phx2lBtrFZW+HPujNREVwgq6zH2hilX1ALr6st4/Hcl9aswPpkKGodKgFYaCYU6S41vUGJDWSCQyjfELBbzh8YbfqFGZgEXOoPMYrgBmMf2fsya4Af1iZvtJohbaO87LEEQ7Q55SS1VL/ZqXyrTI2wyxri0N8w9KSsG0F6Ts= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-lf1-x131.google.com with SMTP id 2adb3069b0e04-539e59dadebso2364080e87.0 for ; Fri, 25 Oct 2024 02:11:26 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1729847484; x=1730452284; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=hJYG/IBkJfNYEGcr75+yNRjkOlwKa12d3/lDbJQCp2Q=; b=d5nBeUBWIUzHmjtS5K4GHwDvS8ICuEln43qWr5lYcndrWPEaQogOY9VADTMNefwQIF CFSRSqIxJQKm4u5M9yqRgPM2DO+uw/tgtRfYMUXLeaZCtIx05ibOiw3ikxZXnuTnIZCt sQtcwhUiiPOiXeWhVVcm0NcFGHKUJ7km/KySNtlsZ0pVP7z38d7Lj3+OJhTn/EE2xDGL GTFG57izypO5QXYuoEqaq0Fdshnl3fMbO7GNV6bxIWmutJ1svUUcEIN5G/DzKqUt3HZq lMN2TerMf5xJwmiBYk/b0VdfuJgYEscQHuWi6XzQYE7+SrOVdT8FWXr1HiU1he34WGR8 VC+Q== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1729847484; x=1730452284; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=hJYG/IBkJfNYEGcr75+yNRjkOlwKa12d3/lDbJQCp2Q=; b=HtV+1sl+hP2syCf1el7nATBuQRUTcUiilu1V/mbG7W1pq1zpX3kocfiAGK30D9lbMS 0hJRe1bfQPnn0n/RvCgQR3l6YjiNO6UvVmrz3odd/IVKe51SVRgAFZxPzJJfytd33anw 8p2lc/kR3AHl3CTK6uBzioKHt1Y6M5wIbmDr4zIXjhmH7kNOK/bUukvUvr2oq1hNgIR3 Ao6/2Q45a4tRC/+RsvkWb+Nq5Imb0b3WqaDpDEyWuyxZP/ZNdcTk1bvZOFOim+jjmWVC LWObYRAegZy2G3G/jocy74DZfaoPikiQ64ufqMqkHtp+wb5SILz5Z0p1YkVV2O0OFJGn MNkQ== X-Gm-Message-State: AOJu0YzJj6P4QX8nqFy1XCdWVRsPzCnclLbTZGV/+1RzNOrPAVYMogbG VgvkVfXfsoPjTdtr6vJ+CZZ6kzzTi2CXFk2G+HzkvaP+N+lbItgAK+MsabsIeJjK/RteoB3dCVM = X-Google-Smtp-Source: AGHT+IGTuyijfGD/jr00ZJwNZg9y/8X1jUyENqYgjo15TDA7JTCwGLU8FiJ+9nTwYnOkKxPVF9qVSA== X-Received: by 2002:a05:6512:31d6:b0:539:96a1:e4cf with SMTP id 2adb3069b0e04-53b23e1dfaamr2892714e87.32.1729847484144; Fri, 25 Oct 2024 02:11:24 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:2626:b78c:6271:6c01]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-38058b47aa8sm1013079f8f.51.2024.10.25.02.11.22 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 25 Oct 2024 02:11:22 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 05/35] ada: Fix fallout of change to 'Wide_Wide_Value for enumeration types Date: Fri, 25 Oct 2024 11:10:34 +0200 Message-ID: <20241025091107.485741-5-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241025091107.485741-1-poulhies@adacore.com> References: <20241025091107.485741-1-poulhies@adacore.com> MIME-Version: 1.0 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, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~patchwork=sourceware.org@gcc.gnu.org From: Eric Botcazou The literals of enumeration types are always normalized, even though they contain wide characters (but the normalization leaves these unchanged), so a normalization routine that is aware of wide characters must be run on the input string for 'Wide_Wide_Value. gcc/ada/ChangeLog: PR ada/115507 * rtsfind.ads (RE_Id): Add RE_Enum_[Wide_]Wide_String_To_String. (RE_Unit_Table): Add entries for the new values. * exp_attr.adb (Is_User_Defined_Enumeration_Type): New predicate. (Expand_N_Attribute_Reference) : Build a call to RE_Enum_Wide_String_To_String for user-defined enumeration types. : Likewise with RE_Enum_Wide_Wide_String_To_String. * exp_imgv.adb (Expand_Value_Attribute): Adjust to above. * libgnat/s-wchwts.ads (Enum_Wide_String_To_String): New function. (Enum_Wide_Wide_String_To_String): Likewise. * libgnat/s-wchwts.adb: Add clauses for System.Case_Util. (Normalize_String): New local procedure. (Enum_Wide_String_To_String): New function body. (Enum_Wide_Wide_String_To_String): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_attr.adb | 29 ++++++- gcc/ada/exp_imgv.adb | 4 +- gcc/ada/libgnat/s-wchwts.adb | 150 ++++++++++++++++++++++++++++++++++- gcc/ada/libgnat/s-wchwts.ads | 12 +++ gcc/ada/rtsfind.ads | 4 + 5 files changed, 193 insertions(+), 6 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 702c4bb120a..cb068c102a2 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -273,6 +273,10 @@ package body Exp_Attr is -- expansion. Typically used for rounding and truncation attributes that -- appear directly inside a conversion to integer. + function Is_User_Defined_Enumeration_Type (Typ : Entity_Id) return Boolean; + -- Returns True if Typ is a user-defined enumeration type, in the sense + -- that its literals are declared in the source. + function Interunit_Ref_OK (Subp_Unit, Attr_Ref_Unit : Node_Id) return Boolean is (In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit) @@ -8107,7 +8111,10 @@ package body Exp_Attr is Expressions => New_List ( Make_Function_Call (Loc, Name => - New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc), + New_Occurrence_Of + (RTE (if Is_User_Defined_Enumeration_Type (Typ) + then RE_Enum_Wide_String_To_String + else RE_Wide_String_To_String), Loc), Parameter_Associations => New_List ( Relocate_Node (First (Exprs)), @@ -8139,7 +8146,9 @@ package body Exp_Attr is Make_Function_Call (Loc, Name => New_Occurrence_Of - (RTE (RE_Wide_Wide_String_To_String), Loc), + (RTE (if Is_User_Defined_Enumeration_Type (Typ) + then RE_Enum_Wide_Wide_String_To_String + else RE_Wide_Wide_String_To_String), Loc), Parameter_Associations => New_List ( Relocate_Node (First (Exprs)), @@ -9458,4 +9467,20 @@ package body Exp_Attr is or else Id = Attribute_Truncation; end Is_Inline_Floating_Point_Attribute; + -------------------------------------- + -- Is_User_Defined_Enumeration_Type -- + -------------------------------------- + + function Is_User_Defined_Enumeration_Type (Typ : Entity_Id) return Boolean + is + Rtyp : constant Entity_Id := Root_Type (Base_Type (Typ)); + + begin + return Is_Enumeration_Type (Rtyp) + and then Rtyp not in Standard_Boolean + | Standard_Character + | Standard_Wide_Character + | Standard_Wide_Wide_Character; + end Is_User_Defined_Enumeration_Type; + end Exp_Attr; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index ef2a3a3250f..20afebc061c 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -1744,9 +1744,9 @@ package body Exp_Imgv is E : constant Entity_Id := Entity (Name (First (Args))); begin - Is_Wide := Is_RTE (E, RE_Wide_String_To_String) + Is_Wide := Is_RTE (E, RE_Enum_Wide_String_To_String) or else - Is_RTE (E, RE_Wide_Wide_String_To_String); + Is_RTE (E, RE_Enum_Wide_Wide_String_To_String); end; else diff --git a/gcc/ada/libgnat/s-wchwts.adb b/gcc/ada/libgnat/s-wchwts.adb index db2fd6a01b7..771e7ddadd0 100644 --- a/gcc/ada/libgnat/s-wchwts.adb +++ b/gcc/ada/libgnat/s-wchwts.adb @@ -29,8 +29,9 @@ -- -- ------------------------------------------------------------------------------ -with System.WCh_Con; use System.WCh_Con; -with System.WCh_Cnv; use System.WCh_Cnv; +with System.Case_Util; use System.Case_Util; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_Cnv; use System.WCh_Cnv; package body System.WCh_WtS is @@ -38,6 +39,14 @@ package body System.WCh_WtS is -- Local Subprograms -- ----------------------- + procedure Normalize_String + (S : in out String; + EM : WC_Encoding_Method); + -- If S does not represent a character literal, then any lower case + -- characters in S are changed to their upper case counterparts, while + -- wide characters are unchanged. EM indicates their encoding method. + -- This is the wide counterpart of System.Val_Util.Normalize_String. + procedure Store_UTF_32_Character (U : UTF_32_Code; S : out String; @@ -48,6 +57,113 @@ package body System.WCh_WtS is -- point to the last character stored. Raises CE if character cannot be -- stored using the given encoding method. + ---------------------- + -- Normalize_String -- + ---------------------- + + procedure Normalize_String + (S : in out String; + EM : WC_Encoding_Method) + is + procedure Skip_Wide (S : String; P : in out Natural); + -- On entry S (P) points to an ESC character for a wide character escape + -- sequence or an upper half character if the encoding method uses the + -- upper bit, or a left bracket if the brackets encoding method is in + -- use. On exit, P is bumped past the wide character sequence. + + --------------- + -- Skip_Wide -- + --------------- + + procedure Skip_Wide (S : String; P : in out Natural) is + function Skip_Char return Character; + -- Function to skip one character of wide character escape sequence + + --------------- + -- Skip_Char -- + --------------- + + function Skip_Char return Character is + begin + P := P + 1; + return S (P - 1); + end Skip_Char; + + function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char); + + Discard : UTF_32_Code; + pragma Warnings (Off, Discard); + + -- Start of processing for Skip_Wide + + begin + -- Capture invalid wide characters errors since we are going to + -- discard the result anyway. We just want to move past it. + + begin + Discard := WC_Skip (Skip_Char, EM); + exception + when Constraint_Error => + null; + end; + end Skip_Wide; + + F, L, Ptr : Natural; + + begin + F := S'First; + L := S'Last; + + -- Case of empty string + + if F > L then + return; + end if; + + -- Scan for leading spaces + + while F < L and then S (F) = ' ' loop + F := F + 1; + end loop; + + -- Case of no nonspace characters found. Decrease L to ensure L < F + -- without risking an overflow if F is Integer'Last. + + if S (F) = ' ' then + L := L - 1; + return; + end if; + + -- Scan for trailing spaces + + while S (L) = ' ' loop + L := L - 1; + end loop; + + -- Convert to upper case if S is not a character literal + + if S (F) /= ''' then + Ptr := F; + + while Ptr <= L loop + -- This mimics the handling of wide characters in a call to + -- Casing.Set_Casing (All_Upper_Case) in the compiler. + + if S (Ptr) = ASCII.ESC + or else S (Ptr) = '[' + or else (EM in WC_Upper_Half_Encoding_Method + and then Character'Pos (S (Ptr)) >= 16#80#) + then + Skip_Wide (S, Ptr); + + else + S (Ptr) := To_Upper (S (Ptr)); + Ptr := Ptr + 1; + end if; + end loop; + end if; + end Normalize_String; + ---------------------------- -- Store_UTF_32_Character -- ---------------------------- @@ -78,6 +194,36 @@ package body System.WCh_WtS is Store_Chars (U, EM); end Store_UTF_32_Character; + -------------------------------- + -- Enum_Wide_String_To_String -- + -------------------------------- + + function Enum_Wide_String_To_String + (S : Wide_String; + EM : WC_Encoding_Method) return String + is + Result : String := Wide_String_To_String (S, EM); + + begin + Normalize_String (Result, EM); + return Result; + end Enum_Wide_String_To_String; + + ------------------------------------- + -- Enum_Wide_Wide_String_To_String -- + ------------------------------------- + + function Enum_Wide_Wide_String_To_String + (S : Wide_Wide_String; + EM : WC_Encoding_Method) return String + is + Result : String := Wide_Wide_String_To_String (S, EM); + + begin + Normalize_String (Result, EM); + return Result; + end Enum_Wide_Wide_String_To_String; + --------------------------- -- Wide_String_To_String -- --------------------------- diff --git a/gcc/ada/libgnat/s-wchwts.ads b/gcc/ada/libgnat/s-wchwts.ads index 63ee804f3ca..549a0b62b7a 100644 --- a/gcc/ada/libgnat/s-wchwts.ads +++ b/gcc/ada/libgnat/s-wchwts.ads @@ -55,9 +55,21 @@ package System.WCh_WtS is -- for characters greater than 16#FF#. The lowest index of the returned -- String is equal to S'First. + function Enum_Wide_String_To_String + (S : Wide_String; + EM : System.WCh_Con.WC_Encoding_Method) return String; + -- Same processing, except that the string is normalized to be usable + -- with the Wide_Value attribute of user-defined enumeration types. + function Wide_Wide_String_To_String (S : Wide_Wide_String; EM : System.WCh_Con.WC_Encoding_Method) return String; -- Same processing, except for Wide_Wide_String + function Enum_Wide_Wide_String_To_String + (S : Wide_Wide_String; + EM : System.WCh_Con.WC_Encoding_Method) return String; + -- Same processing, except that the string is normalized to be usable + -- with the Wide_Wide_Value attribute of user-defined enumeration types. + end System.WCh_WtS; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 8c0c9045360..942c2f712fb 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -2044,6 +2044,8 @@ package Rtsfind is RE_String_To_Wide_String, -- System.WCh_StW RE_String_To_Wide_Wide_String, -- System.WCh_StW + RE_Enum_Wide_String_To_String, -- System.WCh_WtS + RE_Enum_Wide_Wide_String_To_String, -- System.WCh_WtS RE_Wide_String_To_String, -- System.WCh_WtS RE_Wide_Wide_String_To_String, -- System.WCh_WtS @@ -3701,6 +3703,8 @@ package Rtsfind is RE_String_To_Wide_String => System_WCh_StW, RE_String_To_Wide_Wide_String => System_WCh_StW, + RE_Enum_Wide_String_To_String => System_WCh_WtS, + RE_Enum_Wide_Wide_String_To_String => System_WCh_WtS, RE_Wide_String_To_String => System_WCh_WtS, RE_Wide_Wide_String_To_String => System_WCh_WtS,