From patchwork Thu Sep 11 09:18:41 2025 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: 120033 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 95C193857833 for ; Thu, 11 Sep 2025 09:28:16 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42b.google.com (mail-wr1-x42b.google.com [IPv6:2a00:1450:4864:20::42b]) by sourceware.org (Postfix) with ESMTPS id D56203858D33 for ; Thu, 11 Sep 2025 09:19:23 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D56203858D33 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 D56203858D33 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42b ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1757582364; cv=none; b=RSp1zXeVECJJJFuXfdFTiBJUXWHm3dzAhSttBKQA27wDrnW2wxCh9m1PUTYGUziY1JrPS3uzVRMFWDa9tRf9u3TH5iAYGsXrnoMEkjv39G2UVTBcNyIp9lS7ZKJep2vlMVBvvPgQDa49kKW/S6EOHMOjcT9eSTZsbMvN+G73qdY= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1757582364; c=relaxed/simple; bh=eWLaBRMeggKFO6GdY6Ci1IP/j7z8ciuNtPsiocfVEq4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=S63dZfCNwTIBCzYlt7yureJ4YSnwuGdXASZdF3OtwAWaDtrZt0H5JKXBI3YlZ+OqE4mblneJAcjxSCIXBa5AvkClfgIl7n29cPxqPQcwgc9gG0p1+pyt5QYHja8t6YIwIEt+GsNM5MaeV4WeghEhxco5B9M5acj/T+cbC5RSKLc= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org D56203858D33 Authentication-Results: sourceware.org; dkim=pass (2048-bit key, secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=gg+CMUEI Received: by mail-wr1-x42b.google.com with SMTP id ffacd0b85a97d-3e5190bca95so379048f8f.0 for ; Thu, 11 Sep 2025 02:19:23 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1757582362; x=1758187162; 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=zIZtghP2tbKeAsQi4diD/przVQfiWxfWfGqXT2dDl7Q=; b=gg+CMUEIebkpI0wEqdZ3rSPkpYsb4N70mFu72tT+GDk9fDo8/g7A0jXTSzHhfJO9DW qj7wARURv+Y7rmQAH8F+bO/6DXfi5fB+b6u1j+iColsdc2RB3PL6ejYcbDwKd1wBL65y FdPC0sdxZW96TfmLU10av6KPaKHdXpXKoFHiTI77lJ2p9q207jKn0Ev/ADUB+uNUYtSi WyoCAKBVDrWuil2DgJdqHjNFi5pF1V2M1/GsTJAtKn4bNemb0Rc4pU1URkXHogxuzR3w 5JfUxlNOYAcASM7+TLJFA2dmCHUOqWI+fbOZxnVS9Uw1Fqt4yaKSASnLCubgpQzXRwmZ kRUQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1757582362; x=1758187162; 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=zIZtghP2tbKeAsQi4diD/przVQfiWxfWfGqXT2dDl7Q=; b=VfYMy1349+tkItkmAw1GAwfoxpABJcRWfvAmLEn4siUBaIFTCPD03sW7J76VtdP24w wO/aJDQFuG10ifkkgDfigU3YCyCS1EiEjhysDvk7HXlXcOv2PZTQdMQi1u2D/xv3URLO VhrYAGndxbHBThQoXKqJY6TYFLe+jdSYBUFSmWqY+FGKyPyr/rSqYRlXYQb168ZujW1+ ByCVTbQmKKMd7mZN9Xs0lK6zhaBK90B7e65DiiXoJg7TYYWItb1VbXyatGDr1kqjESjg Q+ES87eAfCi9VBDlFNNnNIdJfghsPOclDt4Ydn1ugU0YOTCEbUVwKEfw4vHAjlcJzsot zdjg== X-Gm-Message-State: AOJu0Yxg7sU0d8/tcl3fXYlKt3p1p798ppL8e5fHQ6lDmWlS+Or0LUSW /+BmWsTAuMpYxpOEan/KsgVq0NVImtLpryD2h5NfuqqOhUNaG56KX5lQNBM6+BOv25dimvvUXkG b2Rk= X-Gm-Gg: ASbGncu8B+WbCwXZmSwu49bvM4DpwsTygySbCHTir0iaEspih1QcYU8Cs0qGCV3vs6O OWHRq9ivJG2L+5uZc/MLqzbaSNJ4qxwt4+/wQqc0GwPMs/gRc5JSLIWbmrdh8gYJCdLbcxBbYYb HqJux3Od0JBu6HHXcJ49UFORvTDA7Xkguv43YF+AYEZ17us4qMmYU02tB43c/6eEjOImLTuurGk Uq/iqmRZAQq5J8gkGezbpmtcL604pB1+N+41tzavXZlLANNx7S7PmM1zd1er0uzOC/EkwPorIyS KK1YQBeY3vU8NzCMsSkm80k0ptNpsVKz/hw/KY6/6E7a47hHBk8J3XigTsCYJ+5ZL678BFiQYFO 0vqoF6BUkVazA9K9kl1PlTJq7stBhk95oVJg22E6yBoaPSSOCcfDdBZkQCEeD5DqJePWh/wGr5Z bb6u8n+ygdqQ1zwR83tIvozGksvcnRaZ5YgUpVWA== X-Google-Smtp-Source: AGHT+IHd1NKH8CQxagsfS27p0Mqxi/n15cPDuW5P6t7cFxkEMjT9O+K4rgtbqt7/w7TU8lsCDeOf3A== X-Received: by 2002:a5d:5f48:0:b0:3de:78c8:1223 with SMTP id ffacd0b85a97d-3e6440ef6cemr15849956f8f.31.1757582362368; Thu, 11 Sep 2025 02:19:22 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3e7607cd27dsm1649971f8f.41.2025.09.11.02.19.21 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 11 Sep 2025 02:19:21 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [COMMITTED 09/31] ada: Make pp and friends more robust (base type only) Date: Thu, 11 Sep 2025 11:18:41 +0200 Message-ID: <20250911091904.1505690-9-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20250911091904.1505690-1-poulhies@adacore.com> References: <20250911091904.1505690-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.4 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: Bob Duff Prior to this fix, if pp(N) tried to print a "base type only" field, and Base_Type(N) was not yet set, it would raise an exception, which was confusing. This patch makes it simply ignore such fields. Similarly for Impl_Base_Type_Only and Root_Type_Only fields. We do this by having alternative versions of Base_Type, Implementation_Base_Type, and Root_Type that return Empty in error cases, and call these alteratives from Treepr. We don't want to Base_Type and friends to return Empty; we want them to blow up when called from anywhere but Treepr. gcc/ada/ChangeLog: * atree.ads (Node_To_Fetch_From_If_Set): Alternative to Node_To_Fetch_From that returns Empty in error cases. For use only in Treepr. * treepr.adb (Print_Entity_Field): Avoid printing field if Node_To_Fetch_From_If_Set returns Empty. * einfo-utils.ads (Base_Type_If_Set): Alternative to Base_Type that returns Empty in error cases. (Implementation_Base_Type_If_Set): Likewise. (Root_Type_If_Set): Likewise. (Underlying_Type): Use more accurate result subtype. * einfo-utils.adb (Base_Type): Add Asserts. (Implementation_Base_Type): Add Assert; minor cleanup. (Root_Type): Add Assert; minor cleanup. Remove Assert that is redundant with predicate. (Base_Type_If_Set): Body of new function. (Implementation_Base_Type_If_Set): Body of new function. (Root_Type_If_Set): Body of new function. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/atree.ads | 14 ++++ gcc/ada/einfo-utils.adb | 167 +++++++++++++++++++++++++++------------- gcc/ada/einfo-utils.ads | 11 ++- gcc/ada/treepr.adb | 6 +- 4 files changed, 141 insertions(+), 57 deletions(-) diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 802db8709338..f14491c2d75b 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -651,6 +651,20 @@ package Atree is -- similarly for the other two cases. This can return something other -- than N only if N is an Entity. + function Node_To_Fetch_From_If_Set + (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) + return Node_Or_Entity_Id is + (case Field_Descriptors (Field).Type_Only is + when No_Type_Only => N, + when Base_Type_Only => Base_Type_If_Set (N), + when Impl_Base_Type_Only => Implementation_Base_Type_If_Set (N), + when Root_Type_Only => Root_Type_If_Set (N)); + -- This is a more permissive version of Node_To_Fetch_From, which + -- returns the same value, except it returns Empty in cases where + -- Node_To_Fetch_From would crash because relevant fields are not yet + -- set. This is used in Treepr, to allow it to print half-baked nodes + -- without crashing. + ----------------------------- -- Private Part Subpackage -- ----------------------------- diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 417da6e828bc..d84e562853cc 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -669,6 +669,8 @@ package body Einfo.Utils is Result := Id; else pragma Assert (Is_Type (Id)); + -- ...because Is_Base_Type returns True for nontypes + Result := Etype (Id); if False then pragma Assert (Is_Base_Type (Result)); @@ -679,9 +681,29 @@ package body Einfo.Utils is -- expect. end if; end if; + + -- pragma Assert (Result = Base_Type_If_Set (Id)); + -- Disabled; too slow end return; end Base_Type; + ---------------------- + -- Base_Type_If_Set -- + ---------------------- + + function Base_Type_If_Set (Id : E) return Opt_N_Entity_Id is + begin + return Result : Opt_N_Entity_Id do + if Is_Base_Type (Id) then + Result := Id; + elsif Field_Is_Initial_Zero (Id, F_Etype) then + Result := Empty; + else + Result := Etype (Id); + end if; + end return; + end Base_Type_If_Set; + ---------------------- -- Declaration_Node -- ---------------------- @@ -1374,30 +1396,43 @@ package body Einfo.Utils is ------------------------------ function Implementation_Base_Type (Id : E) return E is - Bastyp : Entity_Id; Imptyp : Entity_Id; - begin - Bastyp := Base_Type (Id); + return Result : E := Base_Type (Id) do + if Is_Incomplete_Or_Private_Type (Result) then + Imptyp := Underlying_Type (Result); - if Is_Incomplete_Or_Private_Type (Bastyp) then - Imptyp := Underlying_Type (Bastyp); + -- If we have an implementation type, return its Base_Type. - -- If we have an implementation type, then just return it, - -- otherwise we return the Base_Type anyway. This can only - -- happen in error situations and should avoid some error bombs. - - if Present (Imptyp) then - return Base_Type (Imptyp); - else - return Bastyp; + if Present (Imptyp) then + Result := Base_Type (Imptyp); + end if; end if; - else - return Bastyp; - end if; + -- pragma Assert (Result = Implementation_Base_Type_If_Set (Id)); + -- Disabled; too slow + end return; end Implementation_Base_Type; + ------------------------------------- + -- Implementation_Base_Type_If_Set -- + ------------------------------------- + + function Implementation_Base_Type_If_Set (Id : E) return Opt_N_Entity_Id is + Imptyp : Entity_Id; + begin + return Result : Opt_N_Entity_Id := Base_Type_If_Set (Id) do + if Present (Result) and then Is_Incomplete_Or_Private_Type (Result) + then + Imptyp := Underlying_Type (Result); + + if Present (Imptyp) then + Result := Base_Type_If_Set (Imptyp); + end if; + end if; + end return; + end Implementation_Base_Type_If_Set; + ------------------------- -- Invariant_Procedure -- ------------------------- @@ -2540,52 +2575,76 @@ package body Einfo.Utils is --------------- function Root_Type (Id : E) return E is - T, Etyp : Entity_Id; + Etyp : Entity_Id; begin - pragma Assert (Nkind (Id) in N_Entity); + return T : E := Base_Type (Id) do + if Ekind (T) = E_Class_Wide_Type then + T := Etype (T); + else + loop + Etyp := Etype (T); - T := Base_Type (Id); + exit when T = Etyp + or else + (Is_Private_Type (T) and then Etyp = Full_View (T)) + or else + (Is_Private_Type (Etyp) and then Full_View (Etyp) = T); - if Ekind (T) = E_Class_Wide_Type then - return Etype (T); + T := Etyp; - -- Other cases + -- Quit if there is a circularity in the inheritance chain. + -- This happens in some error situations and we do not want + -- to get stuck in this loop. - else - loop - Etyp := Etype (T); + if T = Base_Type (Id) then + Check_Error_Detected; + exit; + end if; + end loop; + end if; - if T = Etyp then - return T; - - -- Following test catches some error cases resulting from - -- previous errors. - - elsif No (Etyp) then - Check_Error_Detected; - return T; - - elsif Is_Private_Type (T) and then Etyp = Full_View (T) then - return T; - - elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then - return T; - end if; - - T := Etyp; - - -- Return if there is a circularity in the inheritance chain. This - -- happens in some error situations and we do not want to get - -- stuck in this loop. - - if T = Base_Type (Id) then - return T; - end if; - end loop; - end if; + -- pragma Assert (T = Root_Type_If_Set (Id)); + -- Disabled; too slow + end return; end Root_Type; + function Root_Type_If_Set (Id : E) return Opt_N_Entity_Id is + Etyp : Entity_Id; + + begin + return T : Opt_N_Entity_Id := Base_Type_If_Set (Id) do + if Ekind (T) = E_Class_Wide_Type then + T := Etype (T); + else + loop + Etyp := Etype (T); + + if No (Etyp) then + T := Empty; + exit; + end if; + + exit when T = Etyp + or else + (Is_Private_Type (T) and then Etyp = Full_View (T)) + or else + (Is_Private_Type (Etyp) and then Full_View (Etyp) = T); + + T := Etyp; + + -- Quit if there is a circularity in the inheritance chain. + -- This happens in some error situations and we do not want + -- to get stuck in this loop. + + if T = Base_Type_If_Set (Id) then + exit; + end if; + end loop; + end if; + end return; + end Root_Type_If_Set; + --------------------- -- Safe_Emax_Value -- --------------------- @@ -3010,7 +3069,7 @@ package body Einfo.Utils is -- Underlying_Type -- --------------------- - function Underlying_Type (Id : E) return Entity_Id is + function Underlying_Type (Id : E) return Opt_N_Entity_Id is begin -- For record_with_private the underlying type is always the direct full -- view. Never try to take the full view of the parent it does not make diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads index 78b49891f609..27cf9e670f0e 100644 --- a/gcc/ada/einfo-utils.ads +++ b/gcc/ada/einfo-utils.ads @@ -161,6 +161,15 @@ package Einfo.Utils is function First_Formal (Id : E) return Entity_Id; function First_Formal_With_Extras (Id : E) return Entity_Id; + function Base_Type_If_Set (Id : E) return Opt_N_Entity_Id; + function Implementation_Base_Type_If_Set (Id : E) return Opt_N_Entity_Id; + function Root_Type_If_Set (Id : E) return Opt_N_Entity_Id; + -- Base_Type_If_Set is a more permissive version of Base_Type, which + -- returns the same value, except it returns Empty in cases where Base_Type + -- would crash because relevant fields are not yet set. Likewise for the + -- other two. These are used in Treepr, to allow it to print half-baked + -- nodes without crashing. + function Float_Rep (N : Entity_Id) return F with Inline, Pre => N in E_Void_Id @@ -238,7 +247,7 @@ package Einfo.Utils is function Stream_Size_Clause (Id : E) return N with Inline; function Type_High_Bound (Id : E) return N with Inline; function Type_Low_Bound (Id : E) return N with Inline; - function Underlying_Type (Id : E) return Entity_Id; + function Underlying_Type (Id : E) return Opt_N_Entity_Id; function Scope_Depth (Id : Scope_Kind_Id) return U with Inline; function Scope_Depth_Set (Id : Scope_Kind_Id) return B with Inline; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 857b9263f012..fbad71a3765a 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -1047,9 +1047,11 @@ package body Treepr is FD : Field_Descriptor; Format : UI_Format := Auto) is - NN : constant Node_Id := Node_To_Fetch_From (N, Field); + NN : constant Node_Id := Node_To_Fetch_From_If_Set (N, Field); + -- If NN is Empty, it means that we cannot compute the + -- Node_To_Fetch_From, so we simply skip this field. begin - if not Field_Is_Initial_Zero (N, Field) then + if Present (NN) and then not Field_Is_Initial_Zero (N, Field) then Print_Field (Prefix, Image (Field), NN, FD, Format); end if; end Print_Entity_Field;