From patchwork Fri May 26 07:36:43 2023 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: 70145 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 3AF52382DEB6 for ; Fri, 26 May 2023 07:44:28 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 3AF52382DEB6 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1685087068; bh=t9uVl6wO6DH4BfkyIh7CDyOWoJ9DKURTHbfz9HzsGBY=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=gCTnCYIabsuzAnpLNK0Nnorpm6FliNTD1ihcTDvQNxjVcWkT+RHQ7rq3bXWTY23QK qBmkkR3auZCA2WnRgQH6xVdcRqKXRSsupOCn2Z/ppxhnu3JBcOIn5W5KeOFjFxzVba dJcAKZhH3GxKo4FlNCi73lLAOXA+QXuxR58Cj2YQ= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42c.google.com (mail-wr1-x42c.google.com [IPv6:2a00:1450:4864:20::42c]) by sourceware.org (Postfix) with ESMTPS id 619453857437 for ; Fri, 26 May 2023 07:36:45 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 619453857437 Received: by mail-wr1-x42c.google.com with SMTP id ffacd0b85a97d-3090d3e9c92so337305f8f.2 for ; Fri, 26 May 2023 00:36:45 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1685086605; x=1687678605; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=t9uVl6wO6DH4BfkyIh7CDyOWoJ9DKURTHbfz9HzsGBY=; b=ar9K0dCLP7Da40P1qlhIcCMeobZrD8Xj4NgwTrZbvlynPUjAIpsvG7Jd2wxic09bBV iGm59p0z6wXdQRyZVqhjEkAkydMrLd0LbjfdEUAl9qMo6Mk8KmJRhy0nCgAYtXo28VyG VIxf2HP/TfmVj/49j8P+S2KFTp4PT3cjUqoFq40oZWAazrrjgrivQQ+eP3CKju7omNIt mUWgY2+mx2Hi3K/KxUL0GWC4NoZ+kQRDQ3pOilsMg0xvy8zdLhKZi5E/ko8YA4Facu7Y uD27eKDWEoAHwh/3765sqTI87LkulLvxMGVyB6kjLE343vpCZ3lOi9IpXo7lkSMImMZC GcQA== X-Gm-Message-State: AC+VfDweDVjTryx+7cqIZc4zob+kds8rRfnZwDwAp04sEOyuMFgRR5Uz J2DdflNyMgJV5wotFpgn2Lo2ky3DXCWfcARNZIvYLg== X-Google-Smtp-Source: ACHHUZ5CRtsOvRtNajEzMQuYH+VjS9+Qx87xr6WNhUbdMTmm7hGZQMkbOTEz9dG+zpU6J+kMRLBp7w== X-Received: by 2002:a05:6000:9:b0:304:79c1:725d with SMTP id h9-20020a056000000900b0030479c1725dmr746969wrx.45.1685086605006; Fri, 26 May 2023 00:36:45 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:777b:eef4:6f79:f26f]) by smtp.gmail.com with ESMTPSA id d8-20020adffd88000000b003012030a0c6sm4180269wrr.18.2023.05.26.00.36.44 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 26 May 2023 00:36:44 -0700 (PDT) To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [COMMITTED] ada: Fix crash on 'Img as generic actual function Date: Fri, 26 May 2023 09:36:43 +0200 Message-Id: <20230526073643.2069660-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 X-Spam-Status: No, score=-13.6 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, T_SCC_BODY_TEXT_LINE 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.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: =?utf-8?q?Marc_Poulhi=C3=A8s_via_Gcc-patches?= From: =?utf-8?q?Marc_Poulhi=C3=A8s?= Reply-To: =?utf-8?q?Marc_Poulhi=C3=A8s?= Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" From: Bob Duff 'Image is allowed as an actual for a generic formal function. This patch fixes a crash when 'Img is used instead of 'Image in that context. Misc cleanups. gcc/ada/ * exp_put_image.adb (Build_Image_Call): Treat 'Img the same as 'Image. * exp_imgv.adb (Expand_Image_Attribute): If Discard_Names, expand to 'Image instead of 'Img. * snames.ads-tmpl, par-ch4.adb, sem_attr.adb, sem_attr.ads: Cleanups: Rename Attribute_Class_Array to be Attribute_Set. Remove unnecessary qualifications. DRY: Don't repeat "True". Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_imgv.adb | 9 ++++----- gcc/ada/exp_put_image.adb | 4 +++- gcc/ada/par-ch4.adb | 22 +++++++++++----------- gcc/ada/sem_attr.adb | 25 ++++++++++++------------- gcc/ada/sem_attr.ads | 4 ++-- gcc/ada/snames.ads-tmpl | 2 +- 6 files changed, 33 insertions(+), 33 deletions(-) diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 257f65badd0..a31ce1d8c8f 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -762,7 +762,7 @@ package body Exp_Imgv is -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is -- when pragma Discard_Names applies, in which case we replace expr by: - -- (rt'Pos (expr))'Img + -- (rt'Pos (expr))'Image -- So that the result is a space followed by the decimal value for the -- position of the enumeration value in the enumeration type. @@ -1211,8 +1211,8 @@ package body Exp_Imgv is or else No (Lit_Strings (Rtyp)) then -- When pragma Discard_Names applies to the first subtype, build - -- (Long_Long_Integer (Pref'Pos (Expr)))'Img. The conversion is - -- there to avoid applying 'Img directly in Universal_Integer, + -- (Long_Long_Integer (Pref'Pos (Expr)))'Image. The conversion is + -- there to avoid applying 'Image directly in Universal_Integer, -- which can be a very large type. See also the handling of 'Val. Rewrite (N, @@ -1223,8 +1223,7 @@ package body Exp_Imgv is Prefix => Pref, Attribute_Name => Name_Pos, Expressions => New_List (Expr))), - Attribute_Name => - Name_Img)); + Attribute_Name => Name_Image)); Analyze_And_Resolve (N, Standard_String); return; diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index c194237aa20..9eda3231c6b 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -1126,7 +1126,9 @@ package body Exp_Put_Image is -- Attribute names that will be mapped to the corresponding result types -- and functions. - Attribute_Name_Id : constant Name_Id := Attribute_Name (N); + Attribute_Name_Id : constant Name_Id := + (if Attribute_Name (N) = Name_Img then Name_Image + else Attribute_Name (N)); Result_Typ : constant Entity_Id := (case Image_Name_Id'(Attribute_Name_Id) is diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 2505eb629ab..52f2b02361a 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -34,17 +34,17 @@ package body Ch4 is -- Attributes that cannot have arguments - Is_Parameterless_Attribute : constant Attribute_Class_Array := - (Attribute_Base => True, - Attribute_Body_Version => True, - Attribute_Class => True, - Attribute_External_Tag => True, - Attribute_Img => True, - Attribute_Loop_Entry => True, - Attribute_Old => True, - Attribute_Result => True, - Attribute_Stub_Type => True, - Attribute_Version => True, + Is_Parameterless_Attribute : constant Attribute_Set := + (Attribute_Base | + Attribute_Body_Version | + Attribute_Class | + Attribute_External_Tag | + Attribute_Img | + Attribute_Loop_Entry | + Attribute_Old | + Attribute_Result | + Attribute_Stub_Type | + Attribute_Version | Attribute_Type_Key => True, others => False); -- This map contains True for parameterless attributes that return a string diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 39103279fa7..8257d4b3536 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -104,8 +104,8 @@ package body Sem_Attr is -- In Ada 83 mode, these are the only recognized attributes. In other Ada -- modes all these attributes are recognized, even if removed in Ada 95. - Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Address | + Attribute_83 : constant Attribute_Set := + (Attribute_Address | Attribute_Aft | Attribute_Alignment | Attribute_Base | @@ -153,8 +153,8 @@ package body Sem_Attr is -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode, -- but in Ada 95 they are considered to be implementation defined. - Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Machine_Rounding | + Attribute_05 : constant Attribute_Set := + (Attribute_Machine_Rounding | Attribute_Mod | Attribute_Priority | Attribute_Stream_Size | @@ -165,8 +165,8 @@ package body Sem_Attr is -- RM which are not defined in Ada 2005. These are recognized in Ada 95 -- and Ada 2005 modes, but are considered to be implementation defined. - Attribute_12 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_First_Valid | + Attribute_12 : constant Attribute_Set := + (Attribute_First_Valid | Attribute_Has_Same_Storage | Attribute_Last_Valid | Attribute_Max_Alignment_For_Allocation => True, @@ -176,10 +176,10 @@ package body Sem_Attr is -- RM which are not defined in Ada 2012. These are recognized in Ada -- 95/2005/2012 modes, but are considered to be implementation defined. - Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Enum_Rep | - Attribute_Enum_Val => True, - Attribute_Index => True, + Attribute_22 : constant Attribute_Set := + (Attribute_Enum_Rep | + Attribute_Enum_Val | + Attribute_Index | Attribute_Preelaborable_Initialization => True, others => False); @@ -187,9 +187,8 @@ package body Sem_Attr is -- of their prefixes or result in an access value. Such prefixes can be -- considered as lvalues. - Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := - Attribute_Class_Array'( - Attribute_Access | + Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Set := + (Attribute_Access | Attribute_Address | Attribute_Input | Attribute_Read | diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index b7a05713ed1..f383ab50000 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -46,8 +46,8 @@ package Sem_Attr is -- in GNAT, as well as constructing an array of flags indicating which -- attributes these are. - Attribute_Impl_Def : constant Attribute_Class_Array := - Attribute_Class_Array'( + Attribute_Impl_Def : constant Attribute_Set := + ( ------------------ -- Abort_Signal -- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 9868d97b740..9d17b43802e 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1643,7 +1643,7 @@ package Snames is subtype Internal_Attribute_Id is Attribute_Id range Attribute_CPU .. Attribute_Interrupt_Priority; - type Attribute_Class_Array is array (Attribute_Id) of Boolean; + type Attribute_Set is array (Attribute_Id) of Boolean; -- Type used to build attribute classification flag arrays ------------------------------------