From patchwork Mon Nov 4 16:10:36 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: 2006294 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=RODmBFWG; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxLX5gTCz1xwF for ; Tue, 5 Nov 2024 03:12:04 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 0B55D3857001 for ; Mon, 4 Nov 2024 16:12:03 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x433.google.com (mail-wr1-x433.google.com [IPv6:2a00:1450:4864:20::433]) by sourceware.org (Postfix) with ESMTPS id 605533857823 for ; Mon, 4 Nov 2024 16:11:28 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 605533857823 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 605533857823 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::433 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736697; cv=none; b=hZz7kXK6MKKhNYJHJp5WY0nD/K58ylp63CB1hSWYSRAa/znbFXen2hf9CHWhwpsVvlUfdo7lYpMzeLp3c2mcqQzx1+vVIXBZFbFJPciv6IZGJ/QmzOB5fLS/VAROnhbAPLosARQ4M/BImxjuENGLpCaZIFTdYmAvIIiZgrNIFSM= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736697; c=relaxed/simple; bh=RH3me882oa7ouNviyZ/24gBdAj+Z8uQByDzLUzLYfas=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=Ex63gGsUc7ZlPnz6X5l+41SGpHz7PhB/agstBhMXvKcbdN2NqxS1e7sE8/ch3yiucY0fsMyIUMw7gPJvqDLsc506z9DCDBwykAz5+vla889+mQ1tkUOXuI7Ueosp2S3UbxsbSqniDYKM46k08swJ/N1fwUGvr9zuRjGfH0O8XjE= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x433.google.com with SMTP id ffacd0b85a97d-37d8901cb98so3354504f8f.0 for ; Mon, 04 Nov 2024 08:11:28 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736687; x=1731341487; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=N/dkCqXzHMWNB7pZ9+GHXq9FBhuzTfsyILAhg1xLXiE=; b=RODmBFWGODqUs6DJW7xUlZSYdSK0oTRsFzGQjBRnQnUiwgqg5MzcmVpc5JX8I8xixi bm6oGCzSgxWGILrGjgqokMGjz1TvdLXxYCaRIzilxiB4SVP8RTO+qaSu8AQb/HMU7rI2 sWwis+f/dhODWXX23KFE4G6iYJt/AItyEFrUS+Y5sOYV2QIW3NRHtgaegaXacjyo+iDp o1tobMJgkX4nI72z2GQyYOpBUMJHsCgCVGzryVH4wlG6ywDxrdCUX3/TSlu8mCNhL45A dVKNQ5c+FRvt2mfTNUwAx6hfCdgVDaQBj+8FubzgwCTK8sGuTFpZCoanYTnA/P1B/AB4 9vhA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736687; x=1731341487; 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=N/dkCqXzHMWNB7pZ9+GHXq9FBhuzTfsyILAhg1xLXiE=; b=S2s2JvUGlJdUSAEzjv6x6TZbJI7VVJlY88lFhthWdcXKjnmjoxqb+gAcmT1SuhcGzF LVwpUxZEkAcTbAFJNi/o9qG6tbJzTxg+7Is+6Meu4263+EI1a59Epbr1Z3BdluI76F96 uYoF3U7Kpat3/nG8xT0HBZTar3UynM31OXHwv2ltbpI9TNERvvYJuPUPHEnTeLkW3+j3 Hudim1rvEl4TPeQXrMpweBmm86tch0ZmmR+N3HCyEKLT2sCXcStYuDdjEUBMiiflkxuk z515hyMu+rXZ18sO913QhX5lBNf/TCrgzOpqE3G+YdSCf/1p1/d9/1KHZg3pG7tqZdVk Q9Ng== X-Gm-Message-State: AOJu0YxxKKYhmoOoq6Ueukl+ZWLfUEq4hSqEBeG/INok/vrHj9D5PB7K btzINJ+HJploDeymEyEjN6xF26zCKcYYBTDk7ell/gqEM3oz/k0V61aI/l8sRAmKVvOsifUqSM0 = X-Google-Smtp-Source: AGHT+IFS2VpXCeBfb/PObivAI6eReyEDFQcF3Ab+QSbw0jlB670X1LQkSo1nt9De/6FPiaMM2ygc1w== X-Received: by 2002:a5d:6c69:0:b0:37e:eee5:80dc with SMTP id ffacd0b85a97d-381c14efbe8mr12833213f8f.28.1730736686801; Mon, 04 Nov 2024 08:11:26 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.26 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:26 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 01/38] ada: Fix asymmetry in resolution of unary intrinsic operators Date: Mon, 4 Nov 2024 17:10:36 +0100 Message-ID: <20241104161116.1431659-1-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek Resolution of binary and unary intrinsic operators differed when expansion was inactive. In particular, this affected GNATprove handling of Ada.Real_Time."abs" operator. This patch makes unary resolution behave like binary resolution. gcc/ada/ChangeLog: * sem_res.adb (Resolve_Intrinsic_Unary_Operator): Disable when expansion is inactive. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 6a2680b6b1d..0abdeee8fbe 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9972,6 +9972,13 @@ package body Sem_Res is Arg2 : Node_Id; begin + -- We must preserve the original entity in a generic setting, so that + -- the legality of the operation can be verified in an instance. + + if not Expander_Active then + return; + end if; + Op := Entity (N); while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); From patchwork Mon Nov 4 16:10:37 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: 2006293 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=ccaEpFK5; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxLQ5pPhz1xyD for ; Tue, 5 Nov 2024 03:11:58 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D98713857739 for ; Mon, 4 Nov 2024 16:11:55 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x430.google.com (mail-wr1-x430.google.com [IPv6:2a00:1450:4864:20::430]) by sourceware.org (Postfix) with ESMTPS id EEE2C3857BA7 for ; Mon, 4 Nov 2024 16:11:28 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org EEE2C3857BA7 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 EEE2C3857BA7 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::430 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736692; cv=none; b=iizDiJXboaiEansE4tkuRVSeLuKaNxGMRmgsgzjm6t8ByFKz4gas4YkXmMiww0w3BZfPr1q3Lyj+yg+neqFdwV9utQarqNmtkqfzkMh9zCyb07vzvAq9BvEvrSgxGeYpbDUfubaPhXQ1xG3P7UbecpDmKvyPwpD4x4rYrHiK1Ek= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736692; c=relaxed/simple; bh=s3pi2lmE629LIpzp2C7/uFRxdWvPrjPAz1+NrpPuA8I=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=ICfiH/Dq/dQkd5pcCxVB7ADTGubkjN1YUSjHRKv9a+54zWOeJGS5PDmsAOzy0cZlyciGL/qArUWehyXLT8BZoQyDpHgQitvo0fMgyo1JIY4VDljDCN8Epahyt3MnwgLgWF+AANbR0//R9MQLLI/mzg1m9f08qS32itrc1uHc+zQ= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x430.google.com with SMTP id ffacd0b85a97d-37d4821e6b4so2702764f8f.3 for ; Mon, 04 Nov 2024 08:11:28 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736687; x=1731341487; 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=YUHvLIAw6dbHf7GtWXeV7PeLwzdm1GgPS0mN+hf9CGM=; b=ccaEpFK5By5cdWo+RFhtm4V/r7UtTwzTNIu+EID0vAMjYmBUCdi+66CqHzZeYzyFEj FXucgznNwdo/7sGQB/0h/jIteY5WcriCyaXz+FwlWORqSe+vY8w2kKZHkwCG2HfpVBEk 4VGNEZ1fKNRCBlC4qooIZNCZcjnhSySR1hv4kZ3SaW75akzdpAeniHLOJTi7XyiX9p11 Qy+U2Vtf7PCIjt2RXzWiNCmT69UayW6mpvzX9zaDfpXFZ03AY/svYuqFUkrqVbBeVKg5 4eKEGBIyZ/+kMNWCMZ5PJyfndbuUq5GywXHpUM+7IOU5Cg05uNieJ889SESayuztCVe/ jB4A== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736687; x=1731341487; 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=YUHvLIAw6dbHf7GtWXeV7PeLwzdm1GgPS0mN+hf9CGM=; b=gyi785/rw3yg1ery1bmFbwhuFK1+9nNUNGVMzG3yk3+WR1xc0rbtTNmzMmSdEORVwQ nzzWuQ32Gc/c3spO8lytJFoKwd9BIDwBu2Aisi81H93R1qMGkYjvS1ny1ICuhdi9JD0G 0YMh8kRRzyK51fNINKQCPTbTrx/9JfR/4+R2fwZBM2XH+TR0RlNXb0MXvD37k7cuRPhl Llywv9W1WCG+etdcd5TaYRcaS12M2IAJuUqaYEcK2A/6ew1l47+mM6RcKr8/qfH6FLR8 Cg2YjU8ClMtFgo4Wy+FBs40XEBSKNqcxALyZN/fDkzC2SNt75L8jbVAH3vt58hg7rzal wj4g== X-Gm-Message-State: AOJu0Yydzk6A6AZpKqQ9ZubYA+0z1UhuQ0tU/xrANGgKTkEAySkGaZI9 suu5nTMJPRY0FXfGxs6DnBSSbR3j50fWrd/cA6MizStYkzuiC22sa47lxAEV/OON88IjW+NlAkY = X-Google-Smtp-Source: AGHT+IH7dIXzQ2CICVjkcjwifpsDOWIsemyD3uLSLDIQcs1Qy0quvywnOMSLW4V67TAqStWlbm+/dg== X-Received: by 2002:a05:6000:1f11:b0:37d:4389:e9de with SMTP id ffacd0b85a97d-380610f3011mr22439572f8f.1.1730736687578; Mon, 04 Nov 2024 08:11:27 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.26 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:27 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 02/38] ada: Resolve intrinsic operators without homonyms Date: Mon, 4 Nov 2024 17:10:37 +0100 Message-ID: <20241104161116.1431659-2-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek Intrinsic operators are resolved by rewriting into a corresponding operator from the Standard package. Traversing homonyms just to find the corresponding operator was not particularly efficient; also, for the binary "-" it was finding the unary "-". There appears to be no difference in compiler behavior, but the new code should be more efficient and finding the correct operator seems to make more sense. gcc/ada/ChangeLog: * sem_res.adb (Resolve_Intrinsic_Operator) (Resolve_Intrinsic_Unary_Operator): Replace traversals of homonyms with a direct lookup. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 47 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 37 insertions(+), 10 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0abdeee8fbe..2ea1ae4a3ae 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9885,11 +9885,30 @@ package body Sem_Res is return; end if; - Op := Entity (N); - while Scope (Op) /= Standard_Standard loop - Op := Homonym (Op); - pragma Assert (Present (Op)); - end loop; + case N_Binary_Op'(Nkind (N)) is + when N_Op_Add => + Op := Standard_Op_Add; + when N_Op_Expon => + Op := Standard_Op_Expon; + when N_Op_Subtract => + Op := Standard_Op_Subtract; + when N_Op_Divide => + Op := Standard_Op_Divide; + when N_Op_Mod => + Op := Standard_Op_Mod; + when N_Op_Multiply => + Op := Standard_Op_Multiply; + when N_Op_Rem => + Op := Standard_Op_Rem; + + -- Non-arithmetic operators are handled elsewhere + + when N_Op_Boolean + | N_Op_Concat + | N_Op_Shift + => + raise Program_Error; + end case; Set_Entity (N, Op); Set_Is_Overloaded (N, False); @@ -9979,11 +9998,19 @@ package body Sem_Res is return; end if; - Op := Entity (N); - while Scope (Op) /= Standard_Standard loop - Op := Homonym (Op); - pragma Assert (Present (Op)); - end loop; + case N_Unary_Op'(Nkind (N)) is + when N_Op_Abs => + Op := Standard_Op_Abs; + when N_Op_Minus => + Op := Standard_Op_Minus; + when N_Op_Plus => + Op := Standard_Op_Plus; + + -- Non-arithmetic operators are handled elsewhere + + when N_Op_Not => + raise Program_Error; + end case; Set_Entity (N, Op); From patchwork Mon Nov 4 16:10:38 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: 2006298 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=UL0n4NxK; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxN61twfz1xwF for ; Tue, 5 Nov 2024 03:13:26 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 4BA203857002 for ; Mon, 4 Nov 2024 16:13:24 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x429.google.com (mail-wr1-x429.google.com [IPv6:2a00:1450:4864:20::429]) by sourceware.org (Postfix) with ESMTPS id C6D88385840F for ; Mon, 4 Nov 2024 16:11:29 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org C6D88385840F 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 C6D88385840F Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::429 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736702; cv=none; b=W/sXshDl6sK7aTGbeDouArFIuCQxSHzVw4OUtSzGqpmj8Qp8mNp9L/T8tstxeDqEjIzQdIzN4Afx/nzHKfHzf9k285FPptUzjFDzAvdmtHDkJtBlfU8B+BcxungJaoZH0iB29ueGmzpcxI+AqnUmmvcfLWLnjwKTdsfDW0hNHyA= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736702; c=relaxed/simple; bh=yA6JLEXHn0ZaNS7MIlSCfPFll0dFmzhb8sqVL7L53jg=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=IYaJkNqrMErmeQldBeUuAzbnaLfP3WuRzeAXDU2WHxlEvJAIBTvxqMNqEkWApyaCqEvoI/XEvKq2HewIdSvwf7p86NyyRGU+m+TOfmQYjFte0TntuJ9Ztp/isYXkLDint+pp70qfyroCdmbX+qm636j4SUwKLASwHBpxTWrsfwg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x429.google.com with SMTP id ffacd0b85a97d-37d808ae924so2436571f8f.0 for ; Mon, 04 Nov 2024 08:11:29 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736688; x=1731341488; 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=7xnaQB3tuTRE7opZ8aJWxl/XcnoF0b8Ww6QMmsM+LiM=; b=UL0n4NxKaVtmMOD6d34fR5928XKi+FMO2yUnaVZH25UCGi4caK6Swqa4i2WshqYjyt tLlWNze2qp9j8kstRxsq3LKmXKVmFyGk9l+MCeOweW3x+KFagpVd/+OL+jfLDT+qOm86 A7u3a+3O26bR4ryTt9fv5ksCvbF5sviE5Xei6iqF8fyCpkrlqnl0k6vUGu/flxSu5hUy nItz7ZrkntEsbFwE4osq07Js4DDk1G6RDWfIOQDvcNQcyU6MARa4I6D2t/maoHj2ZpfY /zNZWQosaJrkLhnCWthjuoyota6jVBPiJh9oCwoSi3lS2dwedRHgMHZjIc238rJ9JfqW TUtA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736688; x=1731341488; 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=7xnaQB3tuTRE7opZ8aJWxl/XcnoF0b8Ww6QMmsM+LiM=; b=Ii6h/JXPKN6yilSlzynaVdQUMQJgWeUnPKVpY+fY7HsSw6cd5OFs58VjkHZntQjvkn 1D/7P7VwtEwrVBw7yTYwyHsdPYKkorN5svEGT0IxHhizJRkTxR4K2rAfV3EzxYf2DZTm 4RB26NPXlFa6N3gLFFIqrxKDnqWQ4o9h8SastIbR7RZHf2MNkxTu7bA1p64xPfahDs+V zLi/A8jEXDgnXEvCSZTWqIU0IJoPet4pftQ0Jtg48HFGg4XjW+gRgRpN+r5rVqfok5vI EV/p3mS/IMdv9YhZoYPqFDQc7B98yW23quRPkzwEwrAxDNwQ3GE7Jjz3GHtqBZelsUZZ yvYQ== X-Gm-Message-State: AOJu0YwOhl517VPaAwUYl2uokNml3lXkQ1jKIVgRKn3En6vGIrTGFcYK 4t+nVX6uNGZVrsBZj9Jm6rUAKUzbKmQBcyjN/NG0eJHFgr3mT1pC3+hfCCsvg1DCscMG0wkKJg0 = X-Google-Smtp-Source: AGHT+IHoBwYSsbhf/zk/ZXdInMV3T4uk84BNYQRe0tAst7a5Q1nnfPVdzX0xML2TgiltHk9xAMc5EQ== X-Received: by 2002:adf:e6cc:0:b0:374:c640:8596 with SMTP id ffacd0b85a97d-38061172331mr21412258f8f.32.1730736688350; Mon, 04 Nov 2024 08:11:28 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.27 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:27 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 03/38] ada: Add null exclusion to avoid run-time checks Date: Mon, 4 Nov 2024 17:10:38 +0100 Message-ID: <20241104161116.1431659-3-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek By declaring access parameter with non-null qualifier, the compiler should avoid generating run-time checks in debug builds, resulting in a tiny performance improvement. Code cleanup; semantics is unaffected. gcc/ada/ChangeLog: * sem_res.adb (Type_In_P): Add non-null qualifier. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 2ea1ae4a3ae..4c92b562944 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1589,7 +1589,7 @@ package body Sem_Res is -- expanded name, verify that the operand has an interpretation with a -- type defined in the given scope of the operator. - function Type_In_P (Test : Kind_Test) return Entity_Id; + function Type_In_P (Test : not null Kind_Test) return Entity_Id; -- Find a type of the given class in package Pack that contains the -- operator. @@ -1624,7 +1624,7 @@ package body Sem_Res is -- Type_In_P -- --------------- - function Type_In_P (Test : Kind_Test) return Entity_Id is + function Type_In_P (Test : not null Kind_Test) return Entity_Id is E : Entity_Id; function In_Decl return Boolean; From patchwork Mon Nov 4 16:10:39 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: 2006292 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=BYQP+IJw; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxLP5MZPz1xwF for ; Tue, 5 Nov 2024 03:11:57 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id B51313857021 for ; Mon, 4 Nov 2024 16:11:55 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42f.google.com (mail-wr1-x42f.google.com [IPv6:2a00:1450:4864:20::42f]) by sourceware.org (Postfix) with ESMTPS id 6EBE93858415 for ; Mon, 4 Nov 2024 16:11:30 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 6EBE93858415 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 6EBE93858415 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736694; cv=none; b=Ybhjr8xaN3PHN1DoxkEsrDSsWm9BzByaqA04bPGh72rs+tbWjIl3elwCLekxh16lzRIGyefUfSbMTtE0U/HImiNZh11UwWmJl4eaiO9B1GhlgyPsDOuSBElrWj+bV9yAFJTqMox4Hiwj02gbjQIshvFl2gObERfbD8L+muySglk= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736694; c=relaxed/simple; bh=EKkCb/crspnlrg0a2FHDxdbyC5k99Gv6hr5Rc0BSzN0=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=xDEQRQfh99DqRVV5zrww8HCRQf5pPoZGJ5y3212VaCjgG6JjpsviEx4M9RqnOp2cJNED3287+E2Wuykco/UGOMH5OUcZ0a92fEqCJXt4/eoRhaiSlphf8Te6Kgvx3eNbhwaWf3U0aFCOjY2rZvcVvSKfZfQ3vTUHlyvyutHSARo= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42f.google.com with SMTP id ffacd0b85a97d-37ec4e349f4so2790998f8f.0 for ; Mon, 04 Nov 2024 08:11:30 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736689; x=1731341489; 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=Jt+A668cjogu7R6pRVEaO0q3JEsxMv3t+Yi1ZnGoF5E=; b=BYQP+IJwNd/bT0AZLI6BR2P1+HmVvPIkRBJo/9EhQ2NGhLfvkXQ12YrSwvbYoMG5H+ p79tXagkhOzKN04OysB7e0thtPS7oHYNijy1s6eUMYmtUQcfApq+VDISXK8WnJLPoVMu DTbJoGPaa1VjH/SFNLwRXSSGtJrH4DpjC1zp+IXQHncXUQKsUVgIZZbqQAlg2eLgQqS3 hN1NRHSBzSGdXcY5aNlLpusR0DCjPQ+S6UCT46d0dKdLaKL9XLfZ7WDmoWsI36vS5oFx jK9DLuWX1UyidehgOy2482EMz3ZstwEEpqhbT/+xEqklN6BrTvl/nhfbLyDA1yPKxUEH kAng== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736689; x=1731341489; 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=Jt+A668cjogu7R6pRVEaO0q3JEsxMv3t+Yi1ZnGoF5E=; b=rj6m8S4rB9YNlGYplcGUhomkieuct53pz2fcYGVY1YwCn9i3ZrTz1c+7g+R/Q/CkE2 hxQU2eUJMeEfcuIbTFiG7NoOnOCXuU7/7TkwW0dZKHEeXJUBzTyO0KpCD8H1/rU7U/p7 QbOSxXPc+UqoGcPOi/b3zfrTlzknw0E7aMLYiatHUMwhCZ+racWK9Z7OE8G24OjGzAWP wDIQThm81//L8LeR7b9KlREorRdAAZevu/ZLsxd6CYhGppCDCvPwR91VvctsjmXmnhlS Pdf1vd38ArXUzheY9OMPaiHwKR2ePl9jTqVb9Sn/AJgnq0CKVsZJbdr2TWfio4VDCE6m 6ZSw== X-Gm-Message-State: AOJu0YzHJjQ+PY1ASk9RXH9A2pkrkQWb3SRHT+K5gWtDnh57gAYf2Hoz vEf5oPN2l/bflm7jBrygmR0itWaN5z4XciTWGJpBnkprjUGgqB8aYTGfGR0diZrfV5vwlAR3hMQ = X-Google-Smtp-Source: AGHT+IHZKOPCYw9tZ+noaUclfcufFdrpqEYvocB5rxk1VITaz3uQnRDX4hxkCVxBOYFh2QSNop+jsg== X-Received: by 2002:a05:6000:18a8:b0:37d:5046:571 with SMTP id ffacd0b85a97d-381c7a5e109mr10588762f8f.22.1730736689111; Mon, 04 Nov 2024 08:11:29 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.28 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:28 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 04/38] ada: Assignment local variable only when it is used Date: Mon, 4 Nov 2024 17:10:39 +0100 Message-ID: <20241104161116.1431659-4-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek Code cleanup; semantics is unaffected. gcc/ada/ChangeLog: * sem_res.adb (In_Decl): Rename and move local variable where it is used. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4c92b562944..d28e724e882 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1637,11 +1637,9 @@ package body Sem_Res is function In_Decl return Boolean is Decl_Node : constant Node_Id := Parent (E); - N2 : Node_Id; + Context : Node_Id; begin - N2 := N; - if Etype (E) = Any_Type then return True; @@ -1649,13 +1647,15 @@ package body Sem_Res is return False; else - while Present (N2) - and then Nkind (N2) /= N_Compilation_Unit + Context := N; + + while Present (Context) + and then Nkind (Context) /= N_Compilation_Unit loop - if N2 = Decl_Node then + if Context = Decl_Node then return True; else - N2 := Parent (N2); + Context := Parent (Context); end if; end loop; @@ -1912,7 +1912,7 @@ package body Sem_Res is end if; end if; - Set_Chars (Op_Node, Op_Name); + Set_Chars (Op_Node, Op_Name); if not Is_Private_Type (Etype (N)) then Set_Etype (Op_Node, Base_Type (Etype (N))); From patchwork Mon Nov 4 16:10:40 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: 2006302 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=dPWj1j5r; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxPJ5Czgz1xwF for ; Tue, 5 Nov 2024 03:14:28 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 252393857719 for ; Mon, 4 Nov 2024 16:14:26 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x329.google.com (mail-wm1-x329.google.com [IPv6:2a00:1450:4864:20::329]) by sourceware.org (Postfix) with ESMTPS id 34AB13858C5F for ; Mon, 4 Nov 2024 16:11:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 34AB13858C5F 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 34AB13858C5F Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::329 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736702; cv=none; b=Se8+TV+AuK3vAkirWaYfiF5MjH+vPyrzL8zGwt698zWP4qJc1BaT/A7QGj1nc98mbYXQCIt+u7vkLCOMvDdz9g3OPJcUbi/BakYarLu+pFJ9okQK+2d3Om0NLvtneAHItVARNB6u+5rlpYTr7zwMKagUdjfpvFiFsQhhxMgYsP8= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736702; c=relaxed/simple; bh=/CTSttKx3Xj9bVKLTzEezIGjgKX2MNPeccmd4eqtxus=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=dUkx1OVx4+Oyh05JEvmv19gXAvzQdgmdfdN4mqqsU0rlk6EATbWjLYqOlvi2PeyzA5c5utHUPuYjq3XoVpts15n4qeUapbDHKAZ+zaEFcRUhp24XTltm8qCNy5bY1L0FU9Kpym56TGTYA/rtwiPU3hKdfX6c0o8lCb/Q/whWqMk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x329.google.com with SMTP id 5b1f17b1804b1-43169902057so34631825e9.0 for ; Mon, 04 Nov 2024 08:11:31 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736690; x=1731341490; 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=ojzB4VlRvfhIy5sNx12nudomrTw3NjEZbfaC4iGLJpk=; b=dPWj1j5rGilzPABIsw1zuUNEJu5osSUW3Zhh60zgPoP0z1P7zwVYKAdK7yf3zolRbE +ZlfKb3CQ03Sd4Z9XxevaFhM+Lkbd6FPu/DBwndguvLtUMh7HnrOjiDxR6+SI20ErHEe ij5/bQBkIkDAJW4BCR/Vtxl+GTptFG7jAAp73MjQ3tNKVOUoUAIsCWOF4PPpEajIfJu4 RJmacOgcjPfpfEMeAlF2wt7XBZfKeR/jYZUVngqO9/dgLME1aVZABVCxvJxOqOVY+4Je BCDqGo5KqimF/OgLxEseYm9XlQFVkXMyfsUUSn/m4RwqjS2oK0VM1btM+LlEIb8kizPk BDFQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736690; x=1731341490; 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=ojzB4VlRvfhIy5sNx12nudomrTw3NjEZbfaC4iGLJpk=; b=PES32SFx8jrPs30bqClTm+X6COWNsYm39TGtE9Y0FWOEoH1Vwmdlzo7WDbkZXmKHuQ v7bSGSqRfnCCjX79aN5n5WdCwgBNaJcmFE82uPI5iZ2/4DDagz2M4EjDR+ljQqp+gvjl oZ0D1H3P5vRD0/iCg6OxzRBk2b6H9RXqsOXej/KcerBMSwyOw/8IiRwK8IT/ZglBc+mh c20uCLE0mO2MxFiIWUbnKhff7SjamD+8unYUAwo09hqhX+uDXVKGvkwCTwxwEFEb3hEP kYsAhamUMXx8Av9Bk2eJGpZbZ6aO3+3sQ9mD1ktdChZZQ9pea6gcF5XoIsKCkxkoKmzn B/OA== X-Gm-Message-State: AOJu0YxVsEGrojWXcBtyBPFdcLWR7dIb4DLN2G+u9D5QiYQ6OMk2y3lS KJYJgndebCuylyyCDN1I8ZzjVBBct1FCggrHZwig9CiwiC42WY7hZwqCYEGjGAoRUlstAVgk9XE = X-Google-Smtp-Source: AGHT+IE8/3R9SW97I4qdtCDIReZNXh+JObwC+WGwnXqM2i+TkyKK2kftuu7TNIkTfifvTrc/VADe4Q== X-Received: by 2002:a05:6000:1b08:b0:378:89be:1825 with SMTP id ffacd0b85a97d-381b710fbb0mr13707612f8f.49.1730736689829; Mon, 04 Nov 2024 08:11:29 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.29 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:29 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 05/38] ada: Avoid run-time conversion of 0 from Int to Uint Date: Mon, 4 Nov 2024 17:10:40 +0100 Message-ID: <20241104161116.1431659-5-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek Code cleanup and tiny performance improvement; semantics is unaffected. gcc/ada/ChangeLog: * exp_ch4.adb (Expand_N_Op_Subtract): Replace numeric literal with universal integer constant, just like it is done in expansion of addition operator. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 9024c1aebb2..b2cc672579f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -10031,7 +10031,7 @@ package body Exp_Ch4 is if Is_Integer_Type (Typ) and then Compile_Time_Known_Value (Right_Opnd (N)) - and then Expr_Value (Right_Opnd (N)) = 0 + and then Expr_Value (Right_Opnd (N)) = Uint_0 then Rewrite (N, Left_Opnd (N)); return; From patchwork Mon Nov 4 16:10:41 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: 2006297 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=G/4JRuZQ; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxMj6CLKz1xwF for ; Tue, 5 Nov 2024 03:13:05 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 113A2385773F for ; Mon, 4 Nov 2024 16:13:04 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x332.google.com (mail-wm1-x332.google.com [IPv6:2a00:1450:4864:20::332]) by sourceware.org (Postfix) with ESMTPS id E16343857B90 for ; Mon, 4 Nov 2024 16:11:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org E16343857B90 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 E16343857B90 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::332 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736703; cv=none; b=BOFF8XEv8bGdXwJb0q7o0r9WLXkxCcurOvFGPQlmHUgwDofHWgUSQUzxff+XlxFtuOhIhvpJiI/12hZExPd085/WQ2sFayTJjdJbVCO85SxI/7Hx1zzQhyvznwCeXeby48utBJzJqAAKfuakXF2W+I6Qyd/tYJrOuMtg6PLEZN8= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736703; c=relaxed/simple; bh=X/bpkKUcxwGd9gp7x2lM8XL/RmKNZsBY4c2sTniRST4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=vIsvSvBmfJrl270TfIGMZyNN2CnKiLQ2rAgWjPN62qKy4/iAp9PIni+GImMDK77+R2Dst1qbhbHYmS6SnnxakaVw6dR4ucHvsiFVJ918X2v5H2GKaOVR+EE04dy3xvBk27VW/6ce2e/i7kfruHZVmaB+q0Id7S50jmyCtmCTjvg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x332.google.com with SMTP id 5b1f17b1804b1-4315c1c7392so38245765e9.1 for ; Mon, 04 Nov 2024 08:11:31 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736690; x=1731341490; 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=5A2tbpXhzNBbTfzK+WT3mXlfYJIMUJp4GMSCnwCzVFU=; b=G/4JRuZQp2WF3cbwHe8mRsLx2ODTXIquteaoM/xTz740oEt3F3wpdZ4ycPxa4Vs0ur 1OhfGLenxojeNlPqRxsOOpWX4G1ZsPWHnjGG8aCbGB+Rqw1GrtruPoAe4+KFQUCnraoQ GrCP0zADg1rJUub2gvM3+EU3Tznx2Be5Ng6XGn4zvxCkW24b9C3kmGiHbrgFOGjm1y7+ WcVCkp22Tmu71HMIVQxtaWs6oK6MOE4SKVp5zC6EmMQodsq3JevppKPvmxYcV5ApHLVb 8kGCQ2jL7hKZ0yXPiXqtvqtxIM0lXH9NlN6N+uU3kz8GJz8F7yy5hW1r1OJQDWBJPKuJ Y+vg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736690; x=1731341490; 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=5A2tbpXhzNBbTfzK+WT3mXlfYJIMUJp4GMSCnwCzVFU=; b=h5vr1koC1QogERRZgYqcqbETKdmg2txOPvbPQ3ZRPRViaaKaUp/r8rAOSGnfMWolvy n1k3EDUeGZh+WUDyYb25+Es45/SK7K8bwUkGYGryT2l8be1W7qJwSX+TVj4mh7QqOwta o9xvn8ozaSHfY2sabR68KNnhu0WKHlNdUMUTAtfDtJwT4iKzbeeXeI4H3wZaYGBF9FRN Bi5PFxe+TUIWai94TRM61SKyNy+da9BeziDBDovTJ+aEcKq3Xkq6KCIiR07dRMfDMkVV MZxHxJKSv8pXICxmvLSzGlG1mold00TdSGSGFN8ZtpWzgErlHO3q+O9CGhNruQ28y7vv sLVg== X-Gm-Message-State: AOJu0Yzj3MqC6boR7k+xn2GXEtM5vhowOvYlLtY51gfHUnOmvlf0Qo08 /DF4OAxUp8/SGh+OL/jeJ2nfGhsz1guVMdR2A9AH2ZGzykaJyR6419JudBta+/nUE9oXKyFgWKI = X-Google-Smtp-Source: AGHT+IGGtILdEAQAsry5C52GaPceHZLpllefLfZFYXVAaTrpZTugV8KQGeUNpukiM1mntx+VqbZ8Qg== X-Received: by 2002:a5d:588b:0:b0:374:fa0a:773c with SMTP id ffacd0b85a97d-381c7aa4349mr9462679f8f.47.1730736690526; Mon, 04 Nov 2024 08:11:30 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.29 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:30 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 06/38] ada: Minor whitespace tuning Date: Mon, 4 Nov 2024 17:10:41 +0100 Message-ID: <20241104161116.1431659-6-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek Code cleanup. gcc/ada/ChangeLog: * exp_ch4.adb (Expand_N_Op_Multiply): Remove extra whitespace. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b2cc672579f..3817997c836 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -9271,9 +9271,9 @@ package body Exp_Ch4 is Rp2 : constant Boolean := Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop); - Ltyp : constant Entity_Id := Etype (Lop); - Rtyp : constant Entity_Id := Etype (Rop); - Typ : Entity_Id := Etype (N); + Ltyp : constant Entity_Id := Etype (Lop); + Rtyp : constant Entity_Id := Etype (Rop); + Typ : Entity_Id := Etype (N); begin Binary_Op_Validity_Checks (N); From patchwork Mon Nov 4 16:10:42 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: 2006306 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=FKEorHnd; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxQf52bDz1xxW for ; Tue, 5 Nov 2024 03:15:38 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 082BE3857BA5 for ; Mon, 4 Nov 2024 16:15:36 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x332.google.com (mail-wm1-x332.google.com [IPv6:2a00:1450:4864:20::332]) by sourceware.org (Postfix) with ESMTPS id 8ADDC3858023 for ; Mon, 4 Nov 2024 16:11:32 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 8ADDC3858023 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 8ADDC3858023 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::332 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736705; cv=none; b=JvTspzW1tlbDBNw41r/0t+3AuDgUQoUfA1A06RRNqUW+bD465VSdqj5/R5VChDwO9Mm5pgHJ4uh0yzAbAZRENHxi1xTY1rWwM2r5YYFyQqiFnESVpQVzNRgYrwWecVT1ZxF219ZWMnoVWEzL1xz4P5uQPUISnbTkZiXvHv0Kw4Q= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736705; c=relaxed/simple; bh=vpqROlVyQz4RAQUHrkz4Ge5MLFS6M9+a7Q586iSU928=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=aq98RjzI2400Luy1fC5DPAOeTvGi4ZiTXFKGlMetQbjvpDyaLEDLDcaM4yXvge800YkA2h4HcjmYxAGuIutbdi7+ti0AIn43pTo+9e+3MSGZSfmFHawsehwaptio69kDuPWY/RZoQ2A/+u8kB7KawwW8p6+QsSnbau86Btw8UFk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x332.google.com with SMTP id 5b1f17b1804b1-4314f38d274so53608335e9.1 for ; Mon, 04 Nov 2024 08:11:32 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736691; x=1731341491; 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=CLdyKH23OI4ZpQOhjQ2gkXELCj++Gv/7UabWb9Nv0cw=; b=FKEorHndQTVsdL6pKP9aertea1/zjkG4BYlZKqnlJpcK8LQpFm8zNUkaRUpZvzVMsB cEasf1xCAIvPDfAGr1ENErMex9hjtJNReU+7N08Egunh56zUqWbIPLKC7p30eqqMLtO+ hyzQeBrvkRkJQpaI3ysub0/8OtgEhPo87JLrUvZk6Iogmd5phMpSiCCaka+GKzwBVbgt vX5+lUG0L9LpCzI2L/wyWY0U/gDeh1Gxs/Mj89aO4dbBoouSBFcjOiCLze2jRNLkIBCE xcI94xLR1nsaI/slh0U14Ptf8JXViWkHnJ5Zu7kAgOB8zR5tIPBZknfe7GFMfTnBoPo+ a8vQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736691; x=1731341491; 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=CLdyKH23OI4ZpQOhjQ2gkXELCj++Gv/7UabWb9Nv0cw=; b=NQequWkUlz+gnIvtWhAUhX+RxSLow/lxEMORznWIW1Wph+qhn6NSHkH0c/nrZGKzNw zyYLFDlZz5jlU8sakvaFrhTraE9hl9OlqOUpPvqO9/9Lef/MnwnDwlaRfdE5adieOfrh xwMNFn2Dk5jdeJgFFpd0t9D9MB+4oEHQXBdXNy0l4Pz6bzI7YnbLdDAiLNW1AAxcbzVH E2uKZ+T2Z4YkmNP00kRP59GdWH2tTRUurF/XqYANeGAKN9cVRG0zKGEsVOHUcT4RFNnM CAO7UCJHbf4hn41y9y5sETziOBv/fslDPQOXEM2RbOuuySoikIHAVQQllFksqIqJTBvH KBpQ== X-Gm-Message-State: AOJu0YwfeuoCKI+orYeESpMa681mivWEtcvn2KQU5Kojop6GhVccpwUh X/sCqqfJBljqHBk3XeGHbHlTYFfOhA4y3omFNXrg5xto/YIRZUijfyTEamK1W+Ia5wa5cdyhm+g = X-Google-Smtp-Source: AGHT+IGhEf6IbuxYPVHevEUDwzbxCUH1pXaSU9rN0DFzQubUT1JPiD8A2VjSRWihqXG26z+Aq3i7Jw== X-Received: by 2002:a05:6000:2c3:b0:37d:4eeb:7366 with SMTP id ffacd0b85a97d-381c7a461e4mr16227970f8f.4.1730736691234; Mon, 04 Nov 2024 08:11:31 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.30 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:30 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 07/38] ada: Fix visibility of Taft amendment types Date: Mon, 4 Nov 2024 17:10:42 +0100 Message-ID: <20241104161116.1431659-7-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek When uninstalling private package declarations we must mark Taft amendment types hidden, just like we mark other types. Looking at previous revisions of this code, it is quite clear that this bug comes from a code evolution and marking types should happen in all ELSE branches of the enclosing IF statement. gcc/ada/ChangeLog: * sem_ch7.adb (Uninstall_Declarations): Mark Taft amendment types like we mark other types declared in private package declarations. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch7.adb | 3 +++ 1 file changed, 3 insertions(+) diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 28031b5dbc2..07a88fee0ec 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -3375,6 +3375,9 @@ package body Sem_Ch7 is end loop; end; + Set_Is_Hidden (Id); + Set_Is_Potentially_Use_Visible (Id, False); + -- For subtypes of private types the frontend generates two entities: -- one associated with the partial view and the other associated with -- the full view. When the subtype declaration is public the frontend From patchwork Mon Nov 4 16:10:43 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: 2006295 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=P+Yf/G5r; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxM40BFNz1xwF for ; Tue, 5 Nov 2024 03:12:31 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 711E6385703B for ; Mon, 4 Nov 2024 16:12:29 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x333.google.com (mail-wm1-x333.google.com [IPv6:2a00:1450:4864:20::333]) by sourceware.org (Postfix) with ESMTPS id 77CAD3857BAF for ; Mon, 4 Nov 2024 16:11:33 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 77CAD3857BAF 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 77CAD3857BAF Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::333 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736713; cv=none; b=TJ8PEq6bFuhXs5TPIyIsVIV6nC6eNVmRY1D+3tk7wsSpd+CO546EyPh/9WvuSAbhWDrXQhaoiuzQCnWYQyD3wFg0v6SWQCtK+KzZP/5vszKPfKWWn5SJe0v/485oFzaHgY7taUvQgMtGhpKr6Pz/tYXcT5fO6k+PSoSpBf1wkh8= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736713; c=relaxed/simple; bh=4F+zo5HWMFZTiYmIvArLckB5ly+pT9+a8+z0Z/MZyU4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=eOW0UDH7AS86d/rBX1S5M/Rw2cxyoDoedf6vstNuybjmPR6HZKu1naQnHKfgNZQs84KlkjjJybZakRRTKBSaFrErcpnCPtooNnoxuSCInJ+njAzei00cH27LXCivZj8cMSbcrBYQsgFSfMcsHn05j4FmlGPIur/e0/HFnBWuEDE= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x333.google.com with SMTP id 5b1f17b1804b1-43155abaf0bso38333665e9.0 for ; Mon, 04 Nov 2024 08:11:33 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736692; x=1731341492; 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=C6K7JRuV5f5H6BsgpWnvlLD7+a/JVKhaddz+xLQZ1gw=; b=P+Yf/G5rnDm20NRZPW2Liu3EmedNi7G0t1o+oQLuhMyysFPzVpLEWfFE1St3P3sbp2 ZHumw7Q92caiVH11lQllBRGyzyeHS/El3rPsMQ1SAIhIqeTHf4dwsMLSw/f4ERPkW3Ku 8vnWg3jqIJ1RfirfQTUDr4Ttr7Nf8RCzv70vqTOiycBu1tvjyk9ETQPhh9ioyfQHlWxc p0RJxfErYtdnxYpi1+KbAENRCGEr/LSB+9n/zLynHdBBM5SQRpALU85aIznFcZH5ZHYe F/6mHdvCfzMLcKHNcd3ON7m5HicMjpOBE6N79u4O2ou8BxNz0A5pHtclEouIoOFSMRxC CgbQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736692; x=1731341492; 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=C6K7JRuV5f5H6BsgpWnvlLD7+a/JVKhaddz+xLQZ1gw=; b=rap13J2Gk7yQFUmXWLa8IRQeeFYr38dx04oXxbAa+Ealzg28pN3rB86pSqE6wawOVe 68/IhVwigk/hBHYLrMbOFTnKlFIB5Ta56m4g84IbbnIY23wmsr2qRXlutSQmJvOVAGd+ 6R9F9JP/7nELtODNkHvJWNBPO0TEklBQ58qIJOFjjarsUi954t4nA3DOYdWNrIofk6iV 1SROd9tduXy76GuUCCY9ep2NeY61ErfBhKoMDoxzcgChPLW8HyKKXpusNZcYojM1SDGV iG1kXm034KdnLK1727UPgMErDdJ0BpmGFcva/6hNHl0oUbK55P2Gxa8koTXk3aPpt8DK dYDg== X-Gm-Message-State: AOJu0YwyOJfxkO6utmTN98kTjNJ0Qh6uiHT0yA2xIxacKLRoedt0I5Uo KRU2HFhcn1v8rvXgjM4z15hAvtp91FZQ13pM/Q2nQU7ovbCf8OuimW3+b/IGLd/FIpDpKWsJx0Y = X-Google-Smtp-Source: AGHT+IGie4+auxP64Dg9wtIQjRAYKHXsqe1cgOQePjk2PrGLLt3KunjjbFOZxfbQ7P9bcLipmvpsQw== X-Received: by 2002:a5d:588b:0:b0:374:fa0a:773c with SMTP id ffacd0b85a97d-381c7aa4349mr9462723f8f.47.1730736691990; Mon, 04 Nov 2024 08:11:31 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.31 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:31 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [COMMITTED 08/38] ada: Missing precondition runtime check in inherited primitive Date: Mon, 4 Nov 2024 17:10:43 +0100 Message-ID: <20241104161116.1431659-8-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Javier Miranda When a derived tagged type implements interface types in addition to deriving from its parent type, and a primitive inherited from its parent type corresponds to an inherited primitive that has class-wide preconditions, then the generated code fails to check the class-wide preconditions inherited from the interface primitive. gcc/ada/ChangeLog: * einfo.ads (Is_Dispatch_Table_Wrapper): Complete documentation. * exp_ch6.adb (Install_Class_Preconditions_Check): Dispatch table wrappers do not require installing the check since it is performed by the caller. (Class_Preconditions_Subprogram): Use new predicate Is_LSP_Wrapper. * freeze.adb (Check_Inherited_Conditions): Rename Postcond_Wrappers to Condition_Wrappers to handle implicitly inherited subprograms that implement pre-/postconditions inherited from interface primitives. Use new predicate Is_LSP_Wrapper. * sem_disp.adb (Check_Dispatching_Operation): Complete assertion to handle functions returning class-wide types. * exp_util.ads (Is_LSP_Wrapper): New subprogram. * exp_util.adb (Is_LSP_Wrapper): New subprogram. * contracts.adb (Process_Spec_Postconditions): Use Is_LSP_Wrapper. (Process_Inherited_Conditions): Use Is_LSP_Wrapper. * sem_ch6.adb (New_Overloaded_Entity): Use Is_LSP_Wrapper. * sem_util.adb (Nearest_Class_Condition_Subprogram): Use Is_LSP_Wrapper. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 8 +--- gcc/ada/einfo.ads | 9 +++-- gcc/ada/exp_ch6.adb | 33 ++++++++++++++-- gcc/ada/exp_util.adb | 10 +++++ gcc/ada/exp_util.ads | 5 +++ gcc/ada/freeze.adb | 91 +++++++++++++++++++++++++------------------ gcc/ada/sem_ch6.adb | 4 +- gcc/ada/sem_disp.adb | 7 ++++ gcc/ada/sem_util.adb | 4 +- 9 files changed, 115 insertions(+), 56 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index a93bf622aa1..7e66a54b675 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -2934,9 +2934,7 @@ package body Contracts is -- Wrappers of class-wide pre/postconditions reference the -- parent primitive that has the inherited contract. - if Is_Wrapper (Subp_Id) - and then Present (LSP_Subprogram (Subp_Id)) - then + if Is_LSP_Wrapper (Subp_Id) then Subp_Id := LSP_Subprogram (Subp_Id); end if; @@ -4602,9 +4600,7 @@ package body Contracts is -- parent primitive that has the inherited contract and help -- us to climb fast. - if Is_Wrapper (Subp_Id) - and then Present (LSP_Subprogram (Subp_Id)) - then + if Is_LSP_Wrapper (Subp_Id) then Subp_Id := LSP_Subprogram (Subp_Id); end if; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 2fb45703a4f..2aae60afae5 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2576,9 +2576,12 @@ package Einfo is -- entity is associated with a dispatch table. -- Is_Dispatch_Table_Wrapper --- Applies to all entities. Set on wrappers built when the subprogram has --- class-wide preconditions or class-wide postconditions affected by --- overriding (AI12-0195). +-- Applies to all entities. Set on wrappers built when a subprogram has +-- class-wide preconditions or postconditions affected by overriding +-- (AI12-0195). Also set on wrappers built when an inherited subprogram +-- implements an interface primitive that has class-wide preconditions +-- or postconditions. In the former case, the entity also has its +-- LSP_Subprogram attribute set. -- Is_Dispatching_Operation -- Defined in all entities. Set for procedures, functions, generic diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c550b1c8c1f..38432449229 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7748,9 +7748,7 @@ package body Exp_Ch6 is -- Wrappers of class-wide pre/postconditions reference the -- parent primitive that has the inherited contract. - if Is_Wrapper (Subp_Id) - and then Present (LSP_Subprogram (Subp_Id)) - then + if Is_LSP_Wrapper (Subp_Id) then Subp_Id := LSP_Subprogram (Subp_Id); end if; @@ -7796,6 +7794,35 @@ package body Exp_Ch6 is elsif Is_Thunk (Current_Scope) then return; + + -- The call to the inherited primitive in a dispatch table wrapper must + -- not have the class-wide precondition check since it is installed in + -- the caller of the wrapper. This is also required to avoid the wrong + -- evaluation of class-wide preconditions in Condition_Wrappers (ie. + -- wrappers of inherited primitives that implement additional interface + -- primitives that have preconditions). + + -- For example: + -- type Typ is tagged null record; + -- procedure Prim (X : T) with Pre'Class => False; + + -- type Iface is interface; + -- procedure Prim (X : Iface) is abstract with Pre'Class => True; + + -- type DT is new Typ and Iface with null record; + -- + + -- The class-wide preconditions of the wrapper must not fail due to the + -- disjunction of the class-wide preconditions of subprograms Typ.Prim + -- and Iface.Prim. If the precondition check were placed in the + -- wrapper's call to the inherited parent primitive, its class-wide + -- condition would incorrectly be reported as failed at runtime. + + elsif Is_Dispatch_Table_Wrapper (Current_Scope) + or else (Chars (Current_Scope) = Name_uWrapped_Statements + and then Is_Dispatch_Table_Wrapper (Scope (Current_Scope))) + then + return; end if; Subp := Entity (Name (Call_Node)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 400d5d86fba..4029ea6263c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9193,6 +9193,16 @@ package body Exp_Util is return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ); end Is_Library_Level_Tagged_Type; + -------------------- + -- Is_LSP_Wrapper -- + -------------------- + + function Is_LSP_Wrapper (E : Entity_Id) return Boolean is + begin + return Is_Dispatch_Table_Wrapper (E) + and then Present (LSP_Subprogram (E)); + end Is_LSP_Wrapper; + -------------------------- -- Is_Non_BIP_Func_Call -- -------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 49e75c79d35..898d712f049 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -789,6 +789,11 @@ package Exp_Util is -- Return True if Typ is a library level tagged type. Currently we use -- this information to build statically allocated dispatch tables. + function Is_LSP_Wrapper (E : Entity_Id) return Boolean; + -- Return True if E is a wrapper built when a subprogram has class-wide + -- preconditions or postconditions affected by overriding (AI12-0195). + -- LSP stands for Liskov Substitution Principle. + function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; -- Determine whether node Expr denotes a non build-in-place function call diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 9c14e1f1a70..c7e3be028a7 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1463,7 +1463,7 @@ package body Freeze is Par_Prim : Entity_Id; Prim : Entity_Id; - type Wrapper_Kind is (No_Wrapper, LSP_Wrapper, Postcond_Wrapper); + type Wrapper_Kind is (No_Wrapper, LSP_Wrapper, Condition_Wrapper); Wrapper_Needed : Wrapper_Kind; -- Kind of wrapper needed by a given inherited primitive of tagged @@ -1471,8 +1471,9 @@ package body Freeze is -- * No_Wrapper: No wrapper is needed. -- * LSP_Wrapper: Wrapper that handles inherited class-wide pre/post -- conditions that call overridden primitives. - -- * Postcond_Wrapper: Wrapper that handles postconditions of interface - -- primitives. + -- * Condition_Wrapper: Wrapper of inherited subprogram that implements + -- additional interface primitives of the derived type that have + -- class-wide pre-/postconditions. function Build_DTW_Body (Loc : Source_Ptr; @@ -1855,9 +1856,9 @@ package body Freeze is -- List containing identifiers of built wrappers. Used to defer building -- and analyzing their class-wide precondition subprograms. - Postcond_Candidates_List : Elist_Id := No_Elist; + Condition_Candidates_List : Elist_Id := No_Elist; -- List containing inherited primitives of tagged type R that implement - -- interface primitives that have postconditions. + -- interface primitives that have pre-/postconditions. -- Start of processing for Check_Inherited_Conditions @@ -1907,9 +1908,7 @@ package body Freeze is -- When the primitive is an LSP wrapper we climb to the parent -- primitive that has the inherited contract. - if Is_Wrapper (Par_Prim) - and then Present (LSP_Subprogram (Par_Prim)) - then + if Is_LSP_Wrapper (Par_Prim) then Par_Prim := LSP_Subprogram (Par_Prim); end if; @@ -1943,7 +1942,7 @@ package body Freeze is end loop; -- Collect inherited primitives that may need a wrapper to handle - -- postconditions of interface primitives; done to improve the + -- pre-/postconditions of interface primitives; done to improve the -- performance when checking if postcondition wrappers are needed. Op_Node := First_Elmt (Prim_Ops); @@ -1952,13 +1951,16 @@ package body Freeze is if Present (Interface_Alias (Prim)) and then not Comes_From_Source (Alias (Prim)) - and then Present (Class_Postconditions (Interface_Alias (Prim))) + and then + (Present (Class_Preconditions (Interface_Alias (Prim))) + or else + Present (Class_Postconditions (Interface_Alias (Prim)))) then - if No (Postcond_Candidates_List) then - Postcond_Candidates_List := New_Elmt_List; + if No (Condition_Candidates_List) then + Condition_Candidates_List := New_Elmt_List; end if; - Append_Unique_Elmt (Alias (Prim), Postcond_Candidates_List); + Append_Unique_Elmt (Alias (Prim), Condition_Candidates_List); end if; Next_Elmt (Op_Node); @@ -1986,9 +1988,7 @@ package body Freeze is -- When the primitive is an LSP wrapper we climb to the parent -- primitive that has the inherited contract. - if Is_Wrapper (Par_Prim) - and then Present (LSP_Subprogram (Par_Prim)) - then + if Is_LSP_Wrapper (Par_Prim) then Par_Prim := LSP_Subprogram (Par_Prim); end if; @@ -2014,12 +2014,12 @@ package body Freeze is -- implements additional interface types, and this inherited -- primitive covers an interface primitive of these additional -- interface types that has class-wide postconditions, then it - -- requires a postconditions wrapper. + -- requires a pre-/postconditions wrapper. if Wrapper_Needed = No_Wrapper and then Present (Interfaces (R)) - and then Present (Postcond_Candidates_List) - and then Contains (Postcond_Candidates_List, Prim) + and then Present (Condition_Candidates_List) + and then Contains (Condition_Candidates_List, Prim) then declare Elmt : Elmt_Id; @@ -2029,7 +2029,8 @@ package body Freeze is begin Elmt := First_Elmt (Prim_Ops); - while Present (Elmt) loop + + Search : while Present (Elmt) loop Ent := Node (Elmt); -- Perform the search relying on the internal entities @@ -2039,7 +2040,9 @@ package body Freeze is if Present (Interface_Alias (Ent)) and then (Alias (Ent)) = Prim and then - Present (Class_Postconditions (Interface_Alias (Ent))) + (Present (Class_Preconditions (Interface_Alias (Ent))) + or else Present (Class_Postconditions + (Interface_Alias (Ent)))) then Iface := Find_Dispatching_Type (Interface_Alias (Ent)); @@ -2052,8 +2055,8 @@ package body Freeze is Iface_Elmt := First_Elmt (Interfaces (R)); while Present (Iface_Elmt) loop if Node (Iface_Elmt) = Iface then - Wrapper_Needed := Postcond_Wrapper; - exit; + Wrapper_Needed := Condition_Wrapper; + exit Search; end if; Next_Elmt (Iface_Elmt); @@ -2061,7 +2064,7 @@ package body Freeze is end if; Next_Elmt (Elmt); - end loop; + end loop Search; end; end if; end if; @@ -2108,7 +2111,8 @@ package body Freeze is -- LSP wrappers reference the parent primitive that has the -- the class-wide pre/post condition that calls overridden - -- primitives. + -- primitives. Condition wrappers do not have this attribute + -- (see predicate Is_LSP_Wrapper). if Wrapper_Needed = LSP_Wrapper then Set_LSP_Subprogram (DTW_Id, Par_Prim); @@ -2124,11 +2128,12 @@ package body Freeze is Set_Sloc (DTW_Id, Sloc (Prim)); - -- For inherited class-wide preconditions the DTW wrapper - -- reuses the ICW of the parent (which checks the parent - -- interpretation of the class-wide preconditions); the - -- interpretation of the class-wide preconditions for the - -- inherited subprogram is checked at the caller side. + -- For LSP_Wrappers of subprograms that inherit class-wide + -- preconditions the DTW wrapper reuses the ICW of the parent + -- (which checks the parent interpretation of the class-wide + -- preconditions); the interpretation of the class-wide + -- preconditions for the inherited subprogram is checked + -- at the caller side. -- When the subprogram inherits class-wide postconditions -- the DTW also checks the interpretation of the class-wide @@ -2137,12 +2142,14 @@ package body Freeze is -- the class-wide postconditions. -- procedure Prim (F1 : T1; ...) is - -- [ pragma Check (Postcondition, Expr); ] + -- [ pragma Postcondition (check => Expr); ] -- begin -- Par_Prim_ICW (Par_Type (F1), ...); -- end; - if Present (Indirect_Call_Wrapper (Par_Prim)) then + if Wrapper_Needed = LSP_Wrapper + and then Present (Indirect_Call_Wrapper (Par_Prim)) + then DTW_Body := Build_DTW_Body (Loc, DTW_Spec => DTW_Spec, @@ -2150,19 +2157,27 @@ package body Freeze is Par_Prim => Par_Prim, Wrapped_Subp => Indirect_Call_Wrapper (Par_Prim)); - -- For subprograms that only inherit class-wide postconditions - -- the DTW wrapper calls the parent primitive (which on its - -- body checks the interpretation of the class-wide post- - -- conditions for the parent subprogram), and the DTW checks - -- the interpretation of the class-wide postconditions for the + -- For LSP_Wrappers of subprograms that only inherit class-wide + -- postconditions, and also for Condition_Wrappers (wrappers of + -- inherited subprograms that implement additional interface + -- primitives that have class-wide pre-/postconditions), the + -- DTW wrapper calls the parent primitive (which on its body + -- checks the interpretation of the class-wide post-conditions + -- for the parent subprogram), and the DTW checks the + -- interpretation of the class-wide postconditions for the -- inherited subprogram. -- procedure Prim (F1 : T1; ...) is - -- pragma Check (Postcondition, Expr); + -- pragma Postcondition (check => Expr); -- begin -- Par_Prim (Par_Type (F1), ...); -- end; + -- No class-wide preconditions runtime check is generated for + -- this wrapper call to the parent primitive, since the check + -- is performed by the caller of the DTW wrapper (see routine + -- Install_Class_Preconditions_Check). + else DTW_Body := Build_DTW_Body (Loc, diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8cf191d751b..944f5ca365a 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -12651,9 +12651,7 @@ package body Sem_Ch6 is -- chain of ancestor primitives (see Map_Primitives). They -- don't inherit contracts. - if Is_Wrapper (S) - and then Present (LSP_Subprogram (S)) - then + if Is_LSP_Wrapper (S) then Set_Overridden_Operation (S, Ultimate_Alias (E)); -- For entities generated by Derive_Subprograms the diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 203e9141624..971192ca64a 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1458,8 +1458,15 @@ package body Sem_Disp is pragma Assert ((Ekind (Subp) = E_Function and then Is_Dispatching_Operation (Old_Subp) + and then not Is_Class_Wide_Type (Etype (Subp)) and then Is_Null_Extension (Base_Type (Etype (Subp)))) + or else + (Ekind (Subp) = E_Function + and then Is_Dispatching_Operation (Old_Subp) + and then Is_Class_Wide_Type (Etype (Subp)) + and then Is_Null_Extension (Root_Type (Etype (Subp)))) + or else (Ekind (Subp) = E_Procedure and then Is_Dispatching_Operation (Old_Subp) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5c32b0ba9b2..5d3a4e68c84 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -22246,9 +22246,7 @@ package body Sem_Util is -- Wrappers of class-wide pre/postconditions reference the -- parent primitive that has the inherited contract. - if Is_Wrapper (Subp_Id) - and then Present (LSP_Subprogram (Subp_Id)) - then + if Is_LSP_Wrapper (Subp_Id) then Subp_Id := LSP_Subprogram (Subp_Id); end if; From patchwork Mon Nov 4 16:10:44 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: 2006296 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=EgZjA0nn; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxMc06Cqz1xwF for ; Tue, 5 Nov 2024 03:13:00 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 32FF03857836 for ; Mon, 4 Nov 2024 16:12:58 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x330.google.com (mail-wm1-x330.google.com [IPv6:2a00:1450:4864:20::330]) by sourceware.org (Postfix) with ESMTPS id 30C793857836 for ; Mon, 4 Nov 2024 16:11:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 30C793857836 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 30C793857836 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::330 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736710; cv=none; b=XZQU/g4rtTRE/qZxSr/lnahRT+n6JxyRDH/5dZAsAmyM+v6cchDon7+YwKZQ0kciXoIBVbQEL/3WUtML5v2x4oCH3UxelNP78MF7Q5+KE1o5SHPCapMvW0BiiMioycUflGtIRCRjaKgmKR8Pvo0N674oOS3Zklwi/RTTJzPuVB4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736710; c=relaxed/simple; bh=NNIWVYEdVQhmD7YHW7LbcMcuZhNsOkuGpLsJZ++Jnj4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=QAFNbBUZwwOeswsxDIsfazN/wq1YxzwQpA/hkjzzul8onbcuj/Gb1Zls2ZJ848TzBvwlAZUJ6CYJadesPYrtLlMb/ePtwbPqvBao1ODrqrKZ82urBs7R64uSyvjDQwFt1EnbTqCW00TmoVwv9toFRsi2vTqTTNAd+buOaoiVN3M= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x330.google.com with SMTP id 5b1f17b1804b1-4315839a7c9so38361355e9.3 for ; Mon, 04 Nov 2024 08:11:34 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736693; x=1731341493; 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=12c6B+MWjd77kJOACaeTZzSuMMl/QCIB7e105imYz8U=; b=EgZjA0nnEpMQtdd7RXegbN4HyjCelddpJheQUNFUX7ZPve4kDYJm6tQ/iIteoS4fDo sqcNSBQOb2zR8RjqVWptjE1RRXKRH6p+pPULmaDt2bJJ3Tsp4AAvoGz1gG/X8U+3JskD pVOaBU2kcg0ySpblUzLGegjceeUJyXNOzyl9sH+19SbooQV5uwgWqKPQIUvD+Cu3/r43 zVkp6MzZcN2eINyDorVvnH3l6/aNLJ1DIGn4eB/d4aBKgE4Id/Sl9NOrVG6NCVxaH/Mh pm/fAcU964YTQqtgqQxeO3VuXx3MyaqApKsb9BDSqcf72REeSpkcNwbPKtJ6P9fWUlV0 ex3g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736693; x=1731341493; 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=12c6B+MWjd77kJOACaeTZzSuMMl/QCIB7e105imYz8U=; b=Xr4pGhFggtgZeYRAvywObcMNoYRFFbFjv/VCpBifZBxfU9r7hHYeHIEfXVI7EUxt9x xYYbUgi1xkvtsLB2o8uGowUAqVrz/sdDP0PA5lnv+ao3Qb3Mfc5QY4zhV90l/Bk6A+Is oaf1/UqEj0E/eXgyKcmVlJUHTUPzq21PZ+nkhLn1oZaZdh9qGg0IR98sTGFsOHNnhkl6 2qLwl+urj+PWJfYTH/6An6RNVUnz5b+KOlcNblGxMTK9twb2K1IQuww0g/qp3IGuPU/w vgKsIAP1n3XHK9XvIghBvx49nnhIFTWgKH/X//m9PYcAlSNQ1mNNFq4WYNXQcPzdyDDB ZoFw== X-Gm-Message-State: AOJu0YxKH0vp3YWDn84LaNClB1t8Frx0Z6g7myxuGcV3r4gPucs3WV8Z KXqfJ/8ePVSSL/z1f71pHhf/5Dw+DKXhxmGxIZvNcGtjumC5fEgA0Jigqduxgtogd0ySL1n721A = X-Google-Smtp-Source: AGHT+IE8z40CtDiPEFI3vAEcd8kWvrfihlYxjitrkOUiaCZ8mEM3uyLqWNfLKd4MUgcgF5ib3gS5PA== X-Received: by 2002:a05:6000:eca:b0:37d:4a16:81d6 with SMTP id ffacd0b85a97d-38061141921mr23255716f8f.24.1730736692709; Mon, 04 Nov 2024 08:11:32 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.32 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:32 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [COMMITTED 09/38] ada: Correction to disable self-referential with_clauses Date: Mon, 4 Nov 2024 17:10:44 +0100 Message-ID: <20241104161116.1431659-9-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Bob Duff Follow-on to previous change "Disable self-referential with_clauses", which caused some regressions. Remove useless use clauses referring to useless self-referential with'ed packages. This is necessary because in some cases, such use clauses cause the compiler to crash or give spurious errors. In addition, enable the warning on self-referential with_clauses. gcc/ada/ChangeLog: * sem_ch10.adb (Analyze_With_Clause): In the case of a self-referential with clause, if there is a subsequent use clause for the same package (which is necessarily useless), remove it from the context clause. Reenable the warning. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch10.adb | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 202a44eb87c..4e582440c40 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -3039,11 +3039,32 @@ package body Sem_Ch10 is -- Self-referential withs are always useless, so warn - if Warn_On_Redundant_Constructs and then False then -- ??? - -- Disable for now, because it breaks SPARK builds + if Warn_On_Redundant_Constructs then Error_Msg_N ("unnecessary with of self?r?", N); end if; + declare + This : Node_Id := Next (N); + begin + -- Remove subsequent use clauses for the same package + + while Present (This) loop + declare + Nxt : constant Node_Id := Next (This); + begin + if Nkind (This) = N_Use_Package_Clause + and then Same_Name (Name (N), Name (This)) + then + if not More_Ids (This) and not Prev_Ids (This) then + Remove (This); + end if; + end if; + + This := Nxt; + end; + end loop; + end; + -- Normal (non-self-referential) case else From patchwork Mon Nov 4 16:10:45 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: 2006300 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=bmRpJLLF; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxNt3FGCz1xwF for ; Tue, 5 Nov 2024 03:14:06 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 7608D3857719 for ; Mon, 4 Nov 2024 16:14:04 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x430.google.com (mail-wr1-x430.google.com [IPv6:2a00:1450:4864:20::430]) by sourceware.org (Postfix) with ESMTPS id C3916385770A for ; Mon, 4 Nov 2024 16:11:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org C3916385770A 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 C3916385770A Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::430 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736710; cv=none; b=gCK8W+pLJnIjk7YspVuvSMixV9WZOSySlyng7Bk6Cbn6fLPrk3W+3Zj/R6CCVikvYwVX9QVm2VzZaSKlGBsf61dBFuV7CymJBOWGFGEla2xTpbf+IT2WvkWJUFPe9PpJd3DdoiwtqBfjDKrM8SS50W4ChJKhcC5PCDwAE8r8O5g= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736710; c=relaxed/simple; bh=WdhXPPj4NLlGhrZayaEiQnnOUJOXJlxWuyoYQ9ZeOkY=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=lnNI9Tlol8mE052iMMabnWf7dvm2d5WR3BN5DKYwQZbzI2Tl02ZO8OiiI2KzvE4avo/BvUFqsXNULLNXDlgP7B+Iy1bqG6/3IYvhGU/5ry7fdLUeA8IBw+pGpBac1tZBmEv0Et1JF+xdlbfkH2u6P9xHLeoyj6dXNb/7L+C4RGg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x430.google.com with SMTP id ffacd0b85a97d-37ec4e349f4so2791052f8f.0 for ; Mon, 04 Nov 2024 08:11:34 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736693; x=1731341493; 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=wQbYCO2nVsecuYw9P203ycf2Tw+DUW7Oy1I9ldRaZeQ=; b=bmRpJLLFRLFxunzwX0eF7YRG4A1o3xpecrMykL2AsKNXyWq7m9p3NhfBQwetf2OIpK ptBiPN/SPo/zaaR9Yhr+IL+4YSa64Z2SK7vSQuVMoBoVAmT1So4hd8Nf3qbIvWUMb7PP zAF8BTLjyHaJ86jipYNg1cJeGs9YFv+nA8aKLGW3tunfNFXaSVHXHSa1dF+Cnsjm0S8g vYB+dlcmWAudxvlRda3QYT3qoKYUuP/cUz7Vg/P9meFhE39il3/8VALbiJ5rfs2X8KZm Knc95LyyJBWsUDFU/BIc9gBO4r+/M/ItOQacdoA+Br15Z4XeREiPSb35kQGC83ll8DH7 6eUQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736693; x=1731341493; 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=wQbYCO2nVsecuYw9P203ycf2Tw+DUW7Oy1I9ldRaZeQ=; b=tNExQ0fnabl1h3uF2Sw+HvPJNvDCsz3jDpiZlpPpSvztQIyhK4oVKlljQOY2zCozmO ZswFleLtTP7fzOVWMQ+eemlzOdSZ8F+PIkctSLV6sPrSwmcbw41NemeXZF9MiW9AiCqH 0sjjOmsnKpmJ4CiTEcoWfMF8oXNDkSLdMnNO1kZ7G1cADgqOnoVel5oicssaXyit2qKo AerSg3TgTzVGE1qPYoToAH9U4kH1a+hgA7RjXmzLhP/cMEkpjr5IJ+H6H4lcqOeKvlS9 dAo7kzw4ZoXrAzu8lVu5kEVPnJrK3aOiYn1nppFE1IHuJhgd6tODvWzBdjpMxCmz4Ybb TeGA== X-Gm-Message-State: AOJu0YxO5YB8l8srHf1J2K6J0MrxoWokzUGduZ4S931+aGBVcF4ktyHA EsuD9sOkpuBUqlLpAD7Hi65OM5M97pc3xTyLnA8wb7xCpH1e0KqNJH06jBNDJZ57kQkj/MTCuS0 = X-Google-Smtp-Source: AGHT+IHWr+3gZWvoTWs0YoOxQx5rp5cbQz3C+9Ic5WJSZDVNok7koY3Xh5jXoJkcRdzCpdScqWUm5w== X-Received: by 2002:a5d:6c68:0:b0:374:af19:7992 with SMTP id ffacd0b85a97d-381c7a47487mr8123776f8f.7.1730736693467; Mon, 04 Nov 2024 08:11:33 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.32 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:33 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 10/38] ada: Minor tweaks in comments Date: Mon, 4 Nov 2024 17:10:45 +0100 Message-ID: <20241104161116.1431659-10-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou They are related to the special support for text encoding on Windows. gcc/ada/ChangeLog: * adaint.c: Replace initialize.c with rtinit.c in comment. * sysdep.c (__gnat_set_mode): Fix reference in comment. * libgnat/i-cstrea.ads (Content_Encoding): Adjust comment. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/adaint.c | 2 +- gcc/ada/libgnat/i-cstrea.ads | 2 +- gcc/ada/sysdep.c | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index f26d69a1a2a..9ccac305dde 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -175,7 +175,7 @@ extern "C" { #include "mingw32.h" -/* Current code page and CCS encoding to use, set in initialize.c. */ +/* Current code page and CCS encoding to use, set in rtinit.c. */ UINT __gnat_current_codepage; UINT __gnat_current_ccs_encoding; diff --git a/gcc/ada/libgnat/i-cstrea.ads b/gcc/ada/libgnat/i-cstrea.ads index 756db48e75c..ba75c21b231 100644 --- a/gcc/ada/libgnat/i-cstrea.ads +++ b/gcc/ada/libgnat/i-cstrea.ads @@ -235,9 +235,9 @@ package Interfaces.C_Streams is -- In this mode we are eventually using the system-wide -- translation if activated. -- Text : Text encoding activated + -- U8text : Unicode UTF-8 encoding -- Wtext : Unicode mode -- U16text : Unicode UTF-16 encoding - -- U8text : Unicode UTF-8 encoding -- -- This encoding is system dependent and only used on Windows systems. -- diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 254c736bec4..1f65f433f50 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -177,8 +177,8 @@ __gnat_set_text_mode (int handle) void __gnat_set_mode (int handle, int mode) { - /* the values here must be synchronized with - System.File_Control_Block.Content_Encodding: + /* The values here must be synchronized with + Interfaces.C_Streams.Content_Encoding: None = 0 Default_Text = 1 @@ -200,8 +200,8 @@ __gnat_set_mode (int handle, int mode) void __gnat_set_mode (int handle, int mode) { - /* the values here must be synchronized with - System.File_Control_Block.Content_Encodding: + /* The values here must be synchronized with + Interfaces.C_Streams.Content_Encoding: None = 0 Default_Text = 1 From patchwork Mon Nov 4 16:10:46 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: 2006304 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=PlaJnfQ9; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxQB5WL7z1xwF for ; Tue, 5 Nov 2024 03:15:14 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 99DD53857348 for ; Mon, 4 Nov 2024 16:15:12 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x436.google.com (mail-wr1-x436.google.com [IPv6:2a00:1450:4864:20::436]) by sourceware.org (Postfix) with ESMTPS id B6BE73857833 for ; Mon, 4 Nov 2024 16:11:35 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B6BE73857833 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 B6BE73857833 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::436 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736713; cv=none; b=P029VVGoU0QRlc35AiKNdLBi3BXHsEJcR4rg/Jxsxu0gUJMGEmggo9/KInaG/lrNALmFqw4iOnbA8mfNEIQ0SmxWdO+f34F3XSahX60Wmh/RkesnBVpNxOFS9pZIS2dL5IndSy5MQIVndSYiGTk1RN0Q6v4Ar5Cch5H6xDvmck4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736713; c=relaxed/simple; bh=xDqOdrwWcVc1TWmvvXtRGYL36qbhTwkQSMHmV94LYvE=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=DizEP6aRf2vvDvQfPTFmGP5IFuPpda9sRCmKfcUEHx7O3wQn7Pd4ymYj0GyqCASnlNISY/3M408wB/VFaYnx9NYFVONix5Qk19PVIrSr2VJQe/lpyDOH9kxGBNpyDSzCdUN8l0aKRcivoZtOmerObAAI2xh4vmvAGcOZ9TM69RI= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x436.google.com with SMTP id ffacd0b85a97d-37d47eff9acso2825594f8f.3 for ; Mon, 04 Nov 2024 08:11:35 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736694; x=1731341494; 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=dnLVQRg9kLgfwahI4JY5EWtQt5SKfceacNR9j57rNKk=; b=PlaJnfQ9peTKw/+NBCcbGds8HmbivJ0dJ9D6dYPHX4diVrP3tcmtCqGoSyHfKyAfjG JbQCeTNpEJd8XgyunPKYGU48jkjfGPKmHe53AL8vDEahxf5s13o7QiCewMPMw/2rFlFM ZdwohdcGz8KWHrfVC2elMplBzHfAjgHfWA5uXX/vwzFdiIJGFRwRlxw+1dynBVfeyBki +DJNkny8dG1m7Cdqh0KGU2rTMjRxVedzMq6B9GtjVinzaVIkGU1wYMAus5SL+WKiIY9b Z/Xkub+ZW4GpjIl4f1sm4M+vpF/Y9M4S4MnlAopc8ZNjHTTFNK9jgKNkLNnziLUB6E2U GV8Q== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736694; x=1731341494; 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=dnLVQRg9kLgfwahI4JY5EWtQt5SKfceacNR9j57rNKk=; b=JHHgYEtMszbbHbqN7TGM2UVLjPxeLevIJWZmc/9SuQ//Dcj1vnJ4MqsLRxMIh5cP33 I+X25Nhz52E9xPYsyBRe2hfCud1pmBCe04zOJnc/+ZeVVmhvoxuy2YKAE86lj59iwipX S8WPNOmM7LzNFfq8/xVlLcwCR8WjcIQC85+BZsvy8pYniSqVFejo4BYSUZ4bnax9ybtX KBkpYARIwNFRzVpHZwn5+BfZvru1EBWaDAa/smQ/qCrxUUQl2rJfh05I7H48rj43uZRd A48mwUaGuVM34Az83wms6KFgOoZcnLviPz4LlofiOo/SEuD4gTsR58UQ5qJ1Z8T/E1Jg pNcQ== X-Gm-Message-State: AOJu0YzSJB/UNGlJyv7uV7mtBEA2drL3Jpm208S7nh/L0prt3Xu5UvpJ swo1OYBwpLcor3eKumunNtuQ3JSRUQVcPFSiG81K75FOuvdZcI9XJZm6oorQ/HPn8FnQvF2JVqQ = X-Google-Smtp-Source: AGHT+IH/UzqMFXURaPTJBLDim+9Z15cZkspb+3EaEdZTNv/NRMtyCuBL6lEvoqA+tTIHvqQjBUTMCg== X-Received: by 2002:a5d:6c63:0:b0:37d:3973:cb8d with SMTP id ffacd0b85a97d-381c7a5e9d5mr9935152f8f.24.1730736694356; Mon, 04 Nov 2024 08:11:34 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.33 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:33 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 11/38] ada: Fix internal error on alignment clause for type declared in generic unit Date: Mon, 4 Nov 2024 17:10:46 +0100 Message-ID: <20241104161116.1431659-11-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou The front-end raises Program_Error on an alignment clause for a type in a generic unit that references the alignment of another type in the unit. gcc/ada/ChangeLog: PR ada/117051 * freeze.adb (Freeze_Entity): Call the layout procedure on subtypes declared in a generic unit when they are static. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/freeze.adb | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c7e3be028a7..9a862176c30 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -8022,9 +8022,11 @@ package body Freeze is -- generation, and so the size and alignment values for such types -- are irrelevant. Ditto for types declared within a generic unit, -- which may have components that depend on generic parameters, and - -- that will be recreated in an instance. + -- that will be recreated in an instance, except for static subtypes + -- because they may be referenced in the static expressions of the + -- generic unit, which need to be evaluated during its processing. - if Inside_A_Generic then + if Inside_A_Generic and then not Is_Static_Subtype (E) then null; -- Otherwise we call the layout procedure From patchwork Mon Nov 4 16:10:47 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 2006314 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=igOXb9mp; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxSj22DNz1xxW for ; Tue, 5 Nov 2024 03:17:25 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D52283857034 for ; Mon, 4 Nov 2024 16:17:17 +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 25B913857729 for ; Mon, 4 Nov 2024 16:11:37 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 25B913857729 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 25B913857729 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=1730736714; cv=none; b=syCEUZdNeZ1/qWKAn4UtbWZyo+b4xfFwey2TGtDOSwJz/M9y2xomEhQcXdHTMCbq5fT2zEFkSFHSDQRUhrjyh//7iFjatzt1txekTRHVvHj4Q1yytMTsVDFHabLxDj9O/m7v80LyNhJ5QsaCP//I3TGhWR+eoo73DQuVjJdOuyg= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736714; c=relaxed/simple; bh=OzsVJ8sQx1771Sz1KCiFHSnV6WMuOwnBpv3S0BxZYmY=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=l8dwx+lFBFuPSI3WDy+29DqTbJaOLP3xNHukFeVtDtYZRNKvvPJFUTpQgb8Cp8+PRPHoaYGL/BbLsItF1f5FYpPshbVLWcM5Bnh80EDDi6cazLgERQle/3vpYFseZCtbdx5sLarJBuu8wkKdtjPTegVrqcC4tw32I2eWt2C8w6U= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42b.google.com with SMTP id ffacd0b85a97d-37d518f9abcso3015181f8f.2 for ; Mon, 04 Nov 2024 08:11:37 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736696; x=1731341496; 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=gFO3NrOqrRKoaAr+O/rcWXwcURkCXXxwp4IWw7dIsp4=; b=igOXb9mpAXiXzGbf8f6HqVO8AjwJ9QgCk2SNqiM+9SyyuXI1WNf1J86QPdauDjTHS1 0ZIKhWLFzxO6gZHetoaswt9SFfjx8upYrYlz7L81bG4xSAfz8gD3b6Cr1cXajPIQi0mP NWk9iiYRt+wAa9J4qcauv0CWulRfpwHI66XlRQZbu8RX0mMzAfOXFox6fCk6X8omGrfL auoGCZeqGm/25ERbgQDNe6Su81hb3ikNLLCYpm1vhNAxn666+no4s5XKdAWOvAGKDAP9 1gObppvOEf2bMzQwaZk3dGy8PXe7AtJmZ0eogdkA8/H36QEN8OmVXdbDeNoAdrThsSR+ lPeg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736696; x=1731341496; 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=gFO3NrOqrRKoaAr+O/rcWXwcURkCXXxwp4IWw7dIsp4=; b=jmSzjckWVtU0O+pZet2Wj6advY9jhJ++FHrPcWnC9Qh09ZPBE1x4I9RlPtNVnlxKKG I5CyKktXDDzO/3fAX/TTA20cr3M2YsG56qgzebAT6/0QmrSOl2DJPUXFkvX5beYs4qxN QPPZjPnXzA1g2+5OlUHPRcPBMSsP9chyVo+uXxL3A1R1GW8HT4mBMDjlgsVPLbjuEx7s 9d3/BkjiGbYx6AB8pd2eGgzpJN9nmcHGdO8Mc4AG1pCJjs/Nivf+R5JEPU3/hEhBoIlY cNJU8wz3Kg90PozG90qgsvkI4OdZ7THqqrw6TbG7X+WN4/GsKei2mZhoHizyJCaUtMEU RLmw== X-Gm-Message-State: AOJu0Yxu1r6rkJWDfh6qiLuoutVOKaiDAXkbBIxgCghUsu2fSlUgSnxK M2bv7xAZa4Sb18R5tqR2GC0cHVVQR3ZZl3KZGectz3MXDBXdayWtOy4bHMqlLpXJHrc9b4gTlC4 = X-Google-Smtp-Source: AGHT+IH5ddSBSXmE8TemGQaAAYLHvQH7ncvgiBN1pOsnzWKJ5HgUsaU+q13TjB/LYxx7ytO+ZS/PSw== X-Received: by 2002:adf:f18c:0:b0:374:c621:3d67 with SMTP id ffacd0b85a97d-38061137930mr24096685f8f.24.1730736695222; Mon, 04 Nov 2024 08:11:35 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.34 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:34 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: =?utf-8?q?Rapha=C3=ABl_AMIARD?= Subject: [COMMITTED 12/38] ada: Add doc for deep delta aggregates Date: Mon, 4 Nov 2024 17:10:47 +0100 Message-ID: <20241104161116.1431659-12-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Raphaël AMIARD gcc/ada/ChangeLog: * doc/gnat_rm/gnat_language_extensions.rst: Adjust documentation. * gnat_rm.texi: Regenerate. * gnat_ugn.texi: Regenerate. Tested on x86_64-pc-linux-gnu, committed on master. --- .../doc/gnat_rm/gnat_language_extensions.rst | 148 ++++++++ gcc/ada/gnat_rm.texi | 325 ++++++++++++++---- gcc/ada/gnat_ugn.texi | 4 +- 3 files changed, 412 insertions(+), 65 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst index 088d289f35f..9b3de825aca 100644 --- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -131,6 +131,154 @@ handler would be visible in this handler. And as such the second ``A`` declaration is hiding the first one. +Deep delta Aggregates +--------------------- + +Ada 2022's delta aggregates are extended to allow deep updates. + +A delta aggregate may be used to specify new values for subcomponents of the +copied base value, instead of only new values for direct components of the +copied base value. This allows a more compact expression of updated values with +a single delta aggregate, instead of multiple nested delta aggregates. + +The syntax of delta aggregates in the extended version is the following: + +Syntax +^^^^^^ + +.. code:: + + delta_aggregate ::= record_delta_aggregate | array_delta_aggregate + + record_delta_aggregate ::= + ( base_expression with delta record_subcomponent_association_list ) + + record_subcomponent_association_list ::= + record_subcomponent_association {, record_subcomponent_association} + + record_subcomponent_association ::= + record_subcomponent_choice_list => expression + + record_subcomponent_choice_list ::= + record_subcomponent_choice {'|' record_subcomponent_choice} + + record_subcomponent_choice ::= + component_selector_name + | record_subcomponent_choice (expression) + | record_subcomponent_choice . component_selector_name + + array_delta_aggregate ::= + ( base_expression with delta array_component_association_list ) + | '[' base_expression with delta array_component_association_list ']' + | ( base_expression with delta array_subcomponent_association_list ) + | '[' base_expression with delta array_subcomponent_association_list ']' + + array_subcomponent_association_list ::= + array_subcomponent_association {, array_subcomponent_association} + + array_subcomponent_association ::= + array_subcomponent_choice_list => expression + + array_subcomponent_choice_list ::= + array_subcomponent_choice {'|' array_subcomponent_choice} + + array_subcomponent_choice ::= + ( expression ) + | array_subcomponent_choice (expression) + | array_subcomponent_choice . component_selector_name + +Legality Rules +^^^^^^^^^^^^^^ + +1. For an ``array_delta_aggregate``, the discrete_choice shall not be **others**. + +2. For an ``array_delta_aggregate``, the dimensionality of the type of the + ``delta_aggregate`` shall be 1. + +3. For an ``array_delta_aggregate``, the ``base_expression`` and each + expression in every ``array_component_association`` or + ``array_subcomponent_association`` shall be of a nonlimited type. + +4. For a ``record_delta_aggregate``, no ``record_subcomponent_choices`` that + consists of only ``component_selector_names`` shall be the same or a prefix + of another record_subcomponent_choice. + +5. For an ``array_subcomponent_choice`` or a ``record_subcomponent_choice`` the + ``component_selector_name`` shall not be a subcomponent that depends on + discriminants of an unconstrained record subtype with defaulted + discriminants unless its prefix consists of only + ``component_selector_names``. + + [Rationale: As a result of this rule, accessing the subcomponent can only + lead to a discriminant check failure if the subcomponent was not present in + the object denoted by the base_expression, prior to any update.] + +Dynamic Semantics +^^^^^^^^^^^^^^^^^ + +The evaluation of a ``delta_aggregate`` begins with the evaluation of the +``base_expression`` of the delta_aggregate; then that value is used to create +and initialize the anonymous object of the aggregate. The bounds of the +anonymous object of an ``array_delta_aggregate`` and the discriminants (if any) +of the anonymous object of a ``record_delta_aggregate`` are those of the +``base_expression``. + +If a ``record_delta_aggregate`` is of a specific tagged type, its tag is that +of the specific type; if it is of a class-wide type, its tag is that of the +base_expression. + +For a ``delta_aggregate``, for each ``discrete_choice`` or each subcomponent +associated with a ``record_subcomponent_associated``, +``array_component_association`` or ``array_subcomponent_association`` (in the +order given in the enclosing ``discrete_choice_list`` or +``subcomponent_association_list``, respectively): + +- if the associated subcomponent belongs to a variant, a check is made that the + values of the governing discriminants are such that the anonymous object has + this component. The exception ``Constraint_Error`` is raised if this check fails. + +- if the associated subcomponent is a subcomponent of an array, then for each + represented index value (in ascending order, if the ``discrete_choice`` + represents a range): + + * the index value is converted to the index type of the array type. + + * a check is made that the index value belongs to the index range of the + corresponding array part of the anonymous object; ``Constraint_Error`` is + raised if this check fails. + + * the expression of the ``record_subcomponent_association``, + ``array_component_association`` or ``array_subcomponent_association`` is + evaluated, converted to the nominal subtype of the associated subcomponent, + and assigned to the corresponding subcomponent of the anonymous object. + +Examples +^^^^^^^^ + +.. code-block:: ada + :linenos: + + declare + type Point is record + X, Y : Integer; + end record; + + type Segment is array (1 .. 2) of Point; + type Triangle is array (1 .. 3) of Segment; + + S : Segment := (1 .. 2 => (0, 0)); + T : Triangle := (1 .. 3 => (1 .. 2 => (0, 0))); + begin + S := (S with delta (1).X | (2).Y => 12, (1).Y => 15); + + pragma Assert (S (1).X = 12); + pragma Assert (S (2).Y = 12); + pragma Assert (S (1).Y = 15); + + T := (T with delta (2)(1).Y => 18); + pragma Assert (T (2)(1).Y = 18); + end; + Fixed lower bounds for array types and subtypes ----------------------------------------------- diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 647207f89e9..ff55de54d7d 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Oct 17, 2024 +GNAT Reference Manual , Nov 04, 2024 AdaCore @@ -895,6 +895,7 @@ GNAT language extensions Curated Extensions * Local Declarations Without Block:: +* Deep delta Aggregates:: * Fixed lower bounds for array types and subtypes:: * Prefixed-view notation for calls to primitive subprograms of untagged types:: * Expression defaults for generic formal functions:: @@ -903,6 +904,13 @@ Curated Extensions * Static aspect on intrinsic functions:: * First Controlling Parameter:: +Deep delta Aggregates + +* Syntax:: +* Legality Rules:: +* Dynamic Semantics:: +* Examples:: + Experimental Language Extensions * Conditional when constructs:: @@ -28967,6 +28975,7 @@ Features activated via @code{-gnatX} or @menu * Local Declarations Without Block:: +* Deep delta Aggregates:: * Fixed lower bounds for array types and subtypes:: * Prefixed-view notation for calls to primitive subprograms of untagged types:: * Expression defaults for generic formal functions:: @@ -28977,7 +28986,7 @@ Features activated via @code{-gnatX} or @end menu -@node Local Declarations Without Block,Fixed lower bounds for array types and subtypes,,Curated Extensions +@node Local Declarations Without Block,Deep delta Aggregates,,Curated Extensions @anchor{gnat_rm/gnat_language_extensions local-declarations-without-block}@anchor{445} @subsection Local Declarations Without Block @@ -29070,8 +29079,198 @@ And as such the second `@w{`}A`@w{`} declaration is hiding the first one. @end quotation @end cartouche -@node Fixed lower bounds for array types and subtypes,Prefixed-view notation for calls to primitive subprograms of untagged types,Local Declarations Without Block,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{446} +@node Deep delta Aggregates,Fixed lower bounds for array types and subtypes,Local Declarations Without Block,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions deep-delta-aggregates}@anchor{446} +@subsection Deep delta Aggregates + + +Ada 2022’s delta aggregates are extended to allow deep updates. + +A delta aggregate may be used to specify new values for subcomponents of the +copied base value, instead of only new values for direct components of the +copied base value. This allows a more compact expression of updated values with +a single delta aggregate, instead of multiple nested delta aggregates. + +The syntax of delta aggregates in the extended version is the following: + +@menu +* Syntax:: +* Legality Rules:: +* Dynamic Semantics:: +* Examples:: + +@end menu + +@node Syntax,Legality Rules,,Deep delta Aggregates +@anchor{gnat_rm/gnat_language_extensions syntax}@anchor{447} +@subsubsection Syntax + + +@example +delta_aggregate ::= record_delta_aggregate | array_delta_aggregate + +record_delta_aggregate ::= + ( base_expression with delta record_subcomponent_association_list ) + +record_subcomponent_association_list ::= + record_subcomponent_association @{, record_subcomponent_association@} + +record_subcomponent_association ::= + record_subcomponent_choice_list => expression + +record_subcomponent_choice_list ::= + record_subcomponent_choice @{'|' record_subcomponent_choice@} + +record_subcomponent_choice ::= + component_selector_name + | record_subcomponent_choice (expression) + | record_subcomponent_choice . component_selector_name + +array_delta_aggregate ::= + ( base_expression with delta array_component_association_list ) + | '[' base_expression with delta array_component_association_list ']' + | ( base_expression with delta array_subcomponent_association_list ) + | '[' base_expression with delta array_subcomponent_association_list ']' + +array_subcomponent_association_list ::= + array_subcomponent_association @{, array_subcomponent_association@} + +array_subcomponent_association ::= + array_subcomponent_choice_list => expression + +array_subcomponent_choice_list ::= + array_subcomponent_choice @{'|' array_subcomponent_choice@} + +array_subcomponent_choice ::= + ( expression ) + | array_subcomponent_choice (expression) + | array_subcomponent_choice . component_selector_name +@end example + +@node Legality Rules,Dynamic Semantics,Syntax,Deep delta Aggregates +@anchor{gnat_rm/gnat_language_extensions legality-rules}@anchor{448} +@subsubsection Legality Rules + + + +@enumerate + +@item +For an @code{array_delta_aggregate}, the discrete_choice shall not be `others'. + +@item +For an @code{array_delta_aggregate}, the dimensionality of the type of the +@code{delta_aggregate} shall be 1. + +@item +For an @code{array_delta_aggregate}, the @code{base_expression} and each +expression in every @code{array_component_association} or +@code{array_subcomponent_association} shall be of a nonlimited type. + +@item +For a @code{record_delta_aggregate}, no @code{record_subcomponent_choices} that +consists of only @code{component_selector_names} shall be the same or a prefix +of another record_subcomponent_choice. + +@item +For an @code{array_subcomponent_choice} or a @code{record_subcomponent_choice} the +@code{component_selector_name} shall not be a subcomponent that depends on +discriminants of an unconstrained record subtype with defaulted +discriminants unless its prefix consists of only +@code{component_selector_names}. + +[Rationale: As a result of this rule, accessing the subcomponent can only +lead to a discriminant check failure if the subcomponent was not present in +the object denoted by the base_expression, prior to any update.] +@end enumerate + +@node Dynamic Semantics,Examples,Legality Rules,Deep delta Aggregates +@anchor{gnat_rm/gnat_language_extensions dynamic-semantics}@anchor{449} +@subsubsection Dynamic Semantics + + +The evaluation of a @code{delta_aggregate} begins with the evaluation of the +@code{base_expression} of the delta_aggregate; then that value is used to create +and initialize the anonymous object of the aggregate. The bounds of the +anonymous object of an @code{array_delta_aggregate} and the discriminants (if any) +of the anonymous object of a @code{record_delta_aggregate} are those of the +@code{base_expression}. + +If a @code{record_delta_aggregate} is of a specific tagged type, its tag is that +of the specific type; if it is of a class-wide type, its tag is that of the +base_expression. + +For a @code{delta_aggregate}, for each @code{discrete_choice} or each subcomponent +associated with a @code{record_subcomponent_associated}, +@code{array_component_association} or @code{array_subcomponent_association} (in the +order given in the enclosing @code{discrete_choice_list} or +@code{subcomponent_association_list}, respectively): + + +@itemize - + +@item +if the associated subcomponent belongs to a variant, a check is made that the +values of the governing discriminants are such that the anonymous object has +this component. The exception @code{Constraint_Error} is raised if this check fails. + +@item +if the associated subcomponent is a subcomponent of an array, then for each +represented index value (in ascending order, if the @code{discrete_choice} +represents a range): + +@quotation + + +@itemize * + +@item +the index value is converted to the index type of the array type. + +@item +a check is made that the index value belongs to the index range of the +corresponding array part of the anonymous object; @code{Constraint_Error} is +raised if this check fails. + +@item +the expression of the @code{record_subcomponent_association}, +@code{array_component_association} or @code{array_subcomponent_association} is +evaluated, converted to the nominal subtype of the associated subcomponent, +and assigned to the corresponding subcomponent of the anonymous object. +@end itemize +@end quotation +@end itemize + +@node Examples,,Dynamic Semantics,Deep delta Aggregates +@anchor{gnat_rm/gnat_language_extensions examples}@anchor{44a} +@subsubsection Examples + + +@example +declare + type Point is record + X, Y : Integer; + end record; + + type Segment is array (1 .. 2) of Point; + type Triangle is array (1 .. 3) of Segment; + + S : Segment := (1 .. 2 => (0, 0)); + T : Triangle := (1 .. 3 => (1 .. 2 => (0, 0))); +begin + S := (S with delta (1).X | (2).Y => 12, (1).Y => 15); + + pragma Assert (S (1).X = 12); + pragma Assert (S (2).Y = 12); + pragma Assert (S (1).Y = 15); + + T := (T with delta (2)(1).Y => 18); + pragma Assert (T (2)(1).Y = 18); +end; +@end example + +@node Fixed lower bounds for array types and subtypes,Prefixed-view notation for calls to primitive subprograms of untagged types,Deep delta Aggregates,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{44b} @subsection Fixed lower bounds for array types and subtypes @@ -29122,7 +29321,7 @@ lower bound of unconstrained array formals when the formal’s subtype has index ranges with static fixed lower bounds. @node Prefixed-view notation for calls to primitive subprograms of untagged types,Expression defaults for generic formal functions,Fixed lower bounds for array types and subtypes,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{447} +@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{44c} @subsection Prefixed-view notation for calls to primitive subprograms of untagged types @@ -29172,7 +29371,7 @@ pragma Assert (V.Nth_Element(1) = 42); @end example @node Expression defaults for generic formal functions,String interpolation,Prefixed-view notation for calls to primitive subprograms of untagged types,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{448} +@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{44d} @subsection Expression defaults for generic formal functions @@ -29203,7 +29402,7 @@ If the default is used (i.e. there is no actual corresponding to Copy), then calls to Copy in the instance will simply return Item. @node String interpolation,Constrained attribute for generic objects,Expression defaults for generic formal functions,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{449} +@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{44e} @subsection String interpolation @@ -29370,7 +29569,7 @@ a double quote is " and an open brace is @{ @end example @node Constrained attribute for generic objects,Static aspect on intrinsic functions,String interpolation,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{44a} +@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{44f} @subsection Constrained attribute for generic objects @@ -29378,7 +29577,7 @@ The @code{Constrained} attribute is permitted for objects of generic types. The result indicates whether the corresponding actual is constrained. @node Static aspect on intrinsic functions,First Controlling Parameter,Constrained attribute for generic objects,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{44b} +@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{450} @subsection @code{Static} aspect on intrinsic functions @@ -29387,7 +29586,7 @@ and the compiler will evaluate some of these intrinsics statically, in particular the @code{Shift_Left} and @code{Shift_Right} intrinsics. @node First Controlling Parameter,,Static aspect on intrinsic functions,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions first-controlling-parameter}@anchor{44c} +@anchor{gnat_rm/gnat_language_extensions first-controlling-parameter}@anchor{451} @subsection First Controlling Parameter @@ -29487,7 +29686,7 @@ The result of a function is never a controlling result. @end itemize @node Experimental Language Extensions,,Curated Extensions,GNAT language extensions -@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{6a}@anchor{gnat_rm/gnat_language_extensions id2}@anchor{44d} +@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{6a}@anchor{gnat_rm/gnat_language_extensions id2}@anchor{452} @section Experimental Language Extensions @@ -29509,7 +29708,7 @@ Features activated via @code{-gnatX0} or @end menu @node Conditional when constructs,Storage Model,,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{44e} +@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{453} @subsection Conditional when constructs @@ -29578,7 +29777,7 @@ end; @end example @node Storage Model,Attribute Super,Conditional when constructs,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions storage-model}@anchor{44f} +@anchor{gnat_rm/gnat_language_extensions storage-model}@anchor{454} @subsection Storage Model @@ -29595,7 +29794,7 @@ memory models, in particular to support interactions with GPU. @end menu @node Aspect Storage_Model_Type,Aspect Designated_Storage_Model,,Storage Model -@anchor{gnat_rm/gnat_language_extensions aspect-storage-model-type}@anchor{450} +@anchor{gnat_rm/gnat_language_extensions aspect-storage-model-type}@anchor{455} @subsubsection Aspect Storage_Model_Type @@ -29729,7 +29928,7 @@ end CUDA_Memory; @end example @node Aspect Designated_Storage_Model,Legacy Storage Pools,Aspect Storage_Model_Type,Storage Model -@anchor{gnat_rm/gnat_language_extensions aspect-designated-storage-model}@anchor{451} +@anchor{gnat_rm/gnat_language_extensions aspect-designated-storage-model}@anchor{456} @subsubsection Aspect Designated_Storage_Model @@ -29807,7 +30006,7 @@ begin @end example @node Legacy Storage Pools,,Aspect Designated_Storage_Model,Storage Model -@anchor{gnat_rm/gnat_language_extensions legacy-storage-pools}@anchor{452} +@anchor{gnat_rm/gnat_language_extensions legacy-storage-pools}@anchor{457} @subsubsection Legacy Storage Pools @@ -29858,7 +30057,7 @@ type Acc is access Integer_Array with Storage_Pool => My_Pool; can still be accepted as a shortcut for the new syntax. @node Attribute Super,Simpler Accessibility Model,Storage Model,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions attribute-super}@anchor{453} +@anchor{gnat_rm/gnat_language_extensions attribute-super}@anchor{458} @subsection Attribute Super @@ -29893,7 +30092,7 @@ end; @end example @node Simpler Accessibility Model,Case pattern matching,Attribute Super,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{454} +@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{459} @subsection Simpler Accessibility Model @@ -29924,7 +30123,7 @@ All of the refined rules are compatible with the [use of anonymous access types @end menu @node Stand-alone objects,Subprogram parameters,,Simpler Accessibility Model -@anchor{gnat_rm/gnat_language_extensions stand-alone-objects}@anchor{455} +@anchor{gnat_rm/gnat_language_extensions stand-alone-objects}@anchor{45a} @subsubsection Stand-alone objects @@ -29972,7 +30171,7 @@ of the RM 4.6 rule “The accessibility level of the operand type shall not be statically deeper than that of the target type …”. @node Subprogram parameters,Function results,Stand-alone objects,Simpler Accessibility Model -@anchor{gnat_rm/gnat_language_extensions subprogram-parameters}@anchor{456} +@anchor{gnat_rm/gnat_language_extensions subprogram-parameters}@anchor{45b} @subsubsection Subprogram parameters @@ -30065,7 +30264,7 @@ end; @end example @node Function results,,Subprogram parameters,Simpler Accessibility Model -@anchor{gnat_rm/gnat_language_extensions function-results}@anchor{457} +@anchor{gnat_rm/gnat_language_extensions function-results}@anchor{45c} @subsubsection Function results @@ -30193,7 +30392,7 @@ end; @end example @node Case pattern matching,Mutably Tagged Types with Size’Class Aspect,Simpler Accessibility Model,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{458} +@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{45d} @subsection Case pattern matching @@ -30323,7 +30522,7 @@ message generated in such cases is usually “Capacity exceeded in compiling case statement with composite selector type”. @node Mutably Tagged Types with Size’Class Aspect,Generalized Finalization,Case pattern matching,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{459} +@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{45e} @subsection Mutably Tagged Types with Size’Class Aspect @@ -30454,7 +30653,7 @@ parameter exists (that is, before leaving the corresponding callable construct). @node Generalized Finalization,No_Raise aspect,Mutably Tagged Types with Size’Class Aspect,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{45a} +@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{45f} @subsection Generalized Finalization @@ -30525,7 +30724,7 @@ hence `not' be deallocated either. The result is simply that memory will be leaked in those cases. @item -The @code{Finalize} procedure should have have the @ref{45b,,No_Raise aspect} specified. +The @code{Finalize} procedure should have have the @ref{460,,No_Raise aspect} specified. If that’s not the case, a compilation error will be raised. @end itemize @@ -30545,7 +30744,7 @@ heap-allocated objects @end itemize @node No_Raise aspect,Inference of Dependent Types in Generic Instantiations,Generalized Finalization,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions id3}@anchor{45c}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{45b} +@anchor{gnat_rm/gnat_language_extensions id3}@anchor{461}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{460} @subsection No_Raise aspect @@ -30562,7 +30761,7 @@ this subpropgram, @code{Program_Error} is raised. @end menu @node New specification for Ada Finalization Controlled,Finalized tagged types,,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions new-specification-for-ada-finalization-controlled}@anchor{45d} +@anchor{gnat_rm/gnat_language_extensions new-specification-for-ada-finalization-controlled}@anchor{462} @subsubsection New specification for @code{Ada.Finalization.Controlled} @@ -30629,7 +30828,7 @@ private @end example @node Finalized tagged types,Composite types,New specification for Ada Finalization Controlled,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions finalized-tagged-types}@anchor{45e} +@anchor{gnat_rm/gnat_language_extensions finalized-tagged-types}@anchor{463} @subsubsection Finalized tagged types @@ -30642,7 +30841,7 @@ However note that for simplicity, it is forbidden to change the value of any of those new aspects in derived types. @node Composite types,Interoperability with controlled types,Finalized tagged types,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{45f} +@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{464} @subsubsection Composite types @@ -30659,7 +30858,7 @@ are called on the composite object, but @code{Finalize} is called on the compos object first. @node Interoperability with controlled types,,Composite types,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{460} +@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{465} @subsubsection Interoperability with controlled types @@ -30680,7 +30879,7 @@ component @end itemize @node Inference of Dependent Types in Generic Instantiations,External_Initialization Aspect,No_Raise aspect,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{461} +@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{466} @subsection Inference of Dependent Types in Generic Instantiations @@ -30757,7 +30956,7 @@ package Int_Array_Operations is new Array_Operations @end example @node External_Initialization Aspect,,Inference of Dependent Types in Generic Instantiations,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{462} +@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{467} @subsection External_Initialization Aspect @@ -30798,7 +30997,7 @@ The maximum size of loaded files is limited to 2@w{^31} bytes. @end cartouche @node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top -@anchor{gnat_rm/security_hardening_features doc}@anchor{463}@anchor{gnat_rm/security_hardening_features id1}@anchor{464}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@anchor{gnat_rm/security_hardening_features doc}@anchor{468}@anchor{gnat_rm/security_hardening_features id1}@anchor{469}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} @chapter Security Hardening Features @@ -30820,7 +31019,7 @@ change. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{465} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{46a} @section Register Scrubbing @@ -30856,7 +31055,7 @@ programming languages, see @cite{Using the GNU Compiler Collection (GCC)}. @c Stack Scrubbing: @node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{466} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{46b} @section Stack Scrubbing @@ -31000,7 +31199,7 @@ Bar_Callable_Ptr. @c Hardened Conditionals: @node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{467} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{46c} @section Hardened Conditionals @@ -31090,7 +31289,7 @@ be used with other programming languages supported by GCC. @c Hardened Booleans: @node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{468} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{46d} @section Hardened Booleans @@ -31151,7 +31350,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection @c Control Flow Redundancy: @node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features -@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{469} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{46e} @section Control Flow Redundancy @@ -31319,7 +31518,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}. These options can be used with other programming languages supported by GCC. @node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top -@anchor{gnat_rm/obsolescent_features doc}@anchor{46a}@anchor{gnat_rm/obsolescent_features id1}@anchor{46b}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} +@anchor{gnat_rm/obsolescent_features doc}@anchor{46f}@anchor{gnat_rm/obsolescent_features id1}@anchor{470}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -31338,7 +31537,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{46c}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{46d} +@anchor{gnat_rm/obsolescent_features id2}@anchor{471}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{472} @section pragma No_Run_Time @@ -31351,7 +31550,7 @@ preferred usage is to use an appropriately configured run-time that includes just those features that are to be made accessible. @node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id3}@anchor{46e}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{46f} +@anchor{gnat_rm/obsolescent_features id3}@anchor{473}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{474} @section pragma Ravenscar @@ -31360,7 +31559,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma is part of the new Ada 2005 standard. @node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id4}@anchor{470}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{471} +@anchor{gnat_rm/obsolescent_features id4}@anchor{475}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{476} @section pragma Restricted_Run_Time @@ -31370,7 +31569,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for this kind of implementation dependent addition. @node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id5}@anchor{472}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{473} +@anchor{gnat_rm/obsolescent_features id5}@anchor{477}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{478} @section pragma Task_Info @@ -31396,7 +31595,7 @@ in the spec of package System.Task_Info in the runtime library. @node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features -@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{474}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{475} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{479}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{47a} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -31406,7 +31605,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package standard replacement for GNAT’s @code{Task_Info} functionality. @node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top -@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{476}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{477} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{47b}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{47c} @chapter Compatibility and Porting Guide @@ -31428,7 +31627,7 @@ applications developed in other Ada environments. @end menu @node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{478}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{479} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{47d}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{47e} @section Writing Portable Fixed-Point Declarations @@ -31550,7 +31749,7 @@ If you follow this scheme you will be guaranteed that your fixed-point types will be portable. @node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{47a}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{47b} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{47f}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{480} @section Compatibility with Ada 83 @@ -31578,7 +31777,7 @@ following subsections treat the most likely issues to be encountered. @end menu @node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{47c}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{47d} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{481}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{482} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -31678,7 +31877,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration. @end itemize @node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{47e}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{47f} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{483}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{484} @subsection More deterministic semantics @@ -31706,7 +31905,7 @@ which open select branches are executed. @end itemize @node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{480}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{481} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{485}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{486} @subsection Changed semantics @@ -31748,7 +31947,7 @@ covers only the restricted range. @end itemize @node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{482}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{483} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{488} @subsection Other language compatibility issues @@ -31781,7 +31980,7 @@ include @code{pragma Interface} and the floating point type attributes @end itemize @node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{484}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{485} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{48a} @section Compatibility between Ada 95 and Ada 2005 @@ -31853,7 +32052,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{486}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{487} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{48c} @section Implementation-dependent characteristics @@ -31876,7 +32075,7 @@ transition from certain Ada 83 compilers. @end menu @node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{488}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{489} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{48e} @subsection Implementation-defined pragmas @@ -31898,7 +32097,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not relevant in a GNAT context and hence are not otherwise implemented. @node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{48a}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{48b} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{48f}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{490} @subsection Implementation-defined attributes @@ -31912,7 +32111,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and @code{Type_Class}. @node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{48c}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{48d} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{492} @subsection Libraries @@ -31941,7 +32140,7 @@ be preferable to retrofit the application using modular types. @end itemize @node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{48e}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{48f} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{494} @subsection Elaboration order @@ -31977,7 +32176,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{490}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{491} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{495}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{496} @subsection Target-specific aspects @@ -31990,10 +32189,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus Ada 2005 and Ada 2012) are sometimes incompatible with typical Ada 83 compiler practices regarding implicit packing, the meaning of the Size attribute, and the size of access values. -GNAT’s approach to these issues is described in @ref{492,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{497,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{494} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{498}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{499} @section Compatibility with Other Ada Systems @@ -32036,7 +32235,7 @@ far beyond this minimal set, as described in the next section. @end itemize @node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{495}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{492} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{49a}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{497} @section Representation Clauses @@ -32129,7 +32328,7 @@ with thin pointers. @end itemize @node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{496}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{497} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{49b}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{49c} @section Compatibility with HP Ada 83 @@ -32159,7 +32358,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license doc}@anchor{498}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{499} +@anchor{share/gnu_free_documentation_license doc}@anchor{49d}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{49e} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 7ce413a519f..8bf72eceb7b 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Oct 17, 2024 +GNAT User's Guide for Native Platforms , Nov 04, 2024 AdaCore @@ -29726,8 +29726,8 @@ to permit their use in free software. @printindex ge -@anchor{d1}@w{ } @anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } +@anchor{d1}@w{ } @c %**end of body @bye From patchwork Mon Nov 4 16:10:48 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: 2006301 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=FxohL8+A; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxNy4CHFz1xwF for ; Tue, 5 Nov 2024 03:14:10 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id B9AC13857719 for ; Mon, 4 Nov 2024 16:14:08 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42e.google.com (mail-wr1-x42e.google.com [IPv6:2a00:1450:4864:20::42e]) by sourceware.org (Postfix) with ESMTPS id D74993857810 for ; Mon, 4 Nov 2024 16:11:37 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D74993857810 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 D74993857810 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42e ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736720; cv=none; b=kysH6ERyjZRUoLtxC9EUBSJ/LqSWhgQe4x1sMZyXX4+jRxm0JbIYvA/9/LsbM42JDxbejgbKakBXRDSM0herTd2oTWwTnSgE6ZwaN5isrE/fh9Tpmyok7IxxgjOiCmgL91DtSDCHmYQGVppvk1/uXgI5x9Jp4K5tU0sqpuez+5E= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736720; c=relaxed/simple; bh=KfqD6UtZ0D6VjIeIQPfRwXUK/wRuAPYDOhvyM9FE+cs=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=nyEJ9lyFmm+9R2SdCBlC9CkmJlsAn2X9wcoziRWL6AuIxL6SND2h3zzQdADUPzIOHCcQXtMLocSpgGA2pJ04fqigqi/MQlwny1KBb5cbTDxdRr0yh5vGyF8stMmNzpisurxl0pk3xF9ABSxDEgTbpotAV1wenOn/0DG9kGfMPIY= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42e.google.com with SMTP id ffacd0b85a97d-37d4fd00574so2787407f8f.0 for ; Mon, 04 Nov 2024 08:11:37 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736696; x=1731341496; 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=riqAzyl/qA5ta0eV787d0d4V6x2cWruegjiLvV44M0Q=; b=FxohL8+AKKyA12Z0dZbTzac/BwF8BPa9U8FqklyD8qaI5f4gz0GHOzrrwn4mIe8BZh Gu9yPzUDWduF+1EpbZCqbECrDX6nonf+pSC+7LRWa1pjYEQ7n5Vj7m45/C13oSuonjPF 4iyZXrKZvjaIfcftmCW+EBuOyJ07VuqIhuc92oll2Ioe20Cua2ivNeeZbecZ2+2evssT GApU2o+3KGKscJYKjP6DfOLdG8VRa0I2tQzC97JOqTQ2utIyMjWndxyuto6S0qATgGl6 FzUUpaypnsy+criVGX7wtfd1k43XJn4cIPwUlFglqecHBLH+wjljf3BaNBCQShTrBtom P9gQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736696; x=1731341496; 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=riqAzyl/qA5ta0eV787d0d4V6x2cWruegjiLvV44M0Q=; b=Mst4SSeB3nmm3H9PEhiFwebP6bElDbpDx0O0n0egoJj8ZHq2a9xMI9XQW+/f7Y4ru9 TvbnQxppW3n6h/CEZHe66CpTFCK4YkhSMPntMaWl1GiYLvtCRVaNpn/J2O8NcDIhojaO QiZmhbBc1q7N8lRPydJqhCC5agK/4m7cKFSRr1WuWe4fkw0Kxke0Oh3cRwo8FetSIPeb 5AI2sIgry0iEV0M6jrD91h9vk8UY2YSr3eIXrvOJhBSOBefLsUc1MK/lPhYFizb9jzjE w8a+YWom2UOaNlTAAfecZUil4SydydBupe5h2/abkYBEmYcz3Eddpc7BfiRQFxFcdYq4 SSsQ== X-Gm-Message-State: AOJu0YwY+ecUgqhH7QIVm0dWiiUejVJlPzonaf2GwDlUi8tjM2dv8/8v ZQmr0qwkehM5V456k2B9haGKV/6MiQppxhhNm3oxySwaSPboPuQLPL3L3QHRj42i5Q/Gh+8cI1g = X-Google-Smtp-Source: AGHT+IHSdeCHq6d5LUp0cneuxfH+Ukk/doRUSgIXTbecBGBThiv3K275iAgDrullBb4/4edi3/xDSw== X-Received: by 2002:a05:6000:401f:b0:37e:d942:f4bf with SMTP id ffacd0b85a97d-381c145e473mr14185922f8f.12.1730736696171; Mon, 04 Nov 2024 08:11:36 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.35 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:35 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Claire Dross Subject: [COMMITTED 13/38] ada: Move formal hash tables from gnat repository to the SPARK library Date: Mon, 4 Nov 2024 17:10:48 +0100 Message-ID: <20241104161116.1431659-13-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Claire Dross The formal containers have been part of the SPARK library for some time now. However, some units used only by these containers are still part of the gnat repository. Move them to the SPARK library. gcc/ada/ChangeLog: * Makefile.rtl: Remove references to moved units. * libgnat/a-chtgfk.adb: Removed. * libgnat/a-chtgfk.ads: Removed. * libgnat/a-chtgfo.adb: Removed. * libgnat/a-chtgfo.ads: Removed. * libgnat/a-cohata.ads (Generic_Formal_Hash_Table_Types): Removed. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 2 - gcc/ada/libgnat/a-chtgfk.adb | 278 ----------------------- gcc/ada/libgnat/a-chtgfk.ads | 101 --------- gcc/ada/libgnat/a-chtgfo.adb | 413 ----------------------------------- gcc/ada/libgnat/a-chtgfo.ads | 114 ---------- gcc/ada/libgnat/a-cohata.ads | 19 -- 6 files changed, 927 deletions(-) delete mode 100644 gcc/ada/libgnat/a-chtgfk.adb delete mode 100644 gcc/ada/libgnat/a-chtgfk.ads delete mode 100644 gcc/ada/libgnat/a-chtgfo.adb delete mode 100644 gcc/ada/libgnat/a-chtgfo.ads diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index a36f60170b5..8656e71250b 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -120,8 +120,6 @@ GNATRTL_NONTASKING_OBJS= \ a-chlat9$(objext) \ a-chtgbk$(objext) \ a-chtgbo$(objext) \ - a-chtgfk$(objext) \ - a-chtgfo$(objext) \ a-chtgke$(objext) \ a-chtgop$(objext) \ a-chzla1$(objext) \ diff --git a/gcc/ada/libgnat/a-chtgfk.adb b/gcc/ada/libgnat/a-chtgfk.adb deleted file mode 100644 index 1e0dd8af9f9..00000000000 --- a/gcc/ada/libgnat/a-chtgfk.adb +++ /dev/null @@ -1,278 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_KEYS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2024, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Hash_Tables.Generic_Formal_Keys is - - Checks : constant Boolean := Container_Checks'Enabled; - - -------------------------- - -- Delete_Key_Sans_Free -- - -------------------------- - - procedure Delete_Key_Sans_Free - (HT : in out Hash_Table_Type; - Key : Key_Type; - X : out Count_Type) - is - Indx : Hash_Type; - Prev : Count_Type; - - begin - if HT.Length = 0 then - X := 0; - return; - end if; - - Indx := Index (HT, Key); - X := HT.Buckets (Indx); - - if X = 0 then - return; - end if; - - if Equivalent_Keys (Key, HT.Nodes (X)) then - HT.Buckets (Indx) := Next (HT.Nodes (X)); - HT.Length := HT.Length - 1; - return; - end if; - - loop - Prev := X; - X := Next (HT.Nodes (Prev)); - - if X = 0 then - return; - end if; - - if Equivalent_Keys (Key, HT.Nodes (X)) then - Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X))); - HT.Length := HT.Length - 1; - return; - end if; - end loop; - end Delete_Key_Sans_Free; - - ---------- - -- Find -- - ---------- - - function Find - (HT : Hash_Table_Type; - Key : Key_Type) return Count_Type - is - Indx : Hash_Type; - Node : Count_Type; - - begin - if HT.Length = 0 then - return 0; - end if; - - Indx := Index (HT, Key); - - Node := HT.Buckets (Indx); - while Node /= 0 loop - if Equivalent_Keys (Key, HT.Nodes (Node)) then - return Node; - end if; - Node := Next (HT.Nodes (Node)); - end loop; - - return 0; - end Find; - - -------------------------------- - -- Generic_Conditional_Insert -- - -------------------------------- - - procedure Generic_Conditional_Insert - (HT : in out Hash_Table_Type; - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - Indx : Hash_Type; - - begin - Indx := Index (HT, Key); - Node := HT.Buckets (Indx); - - if Node = 0 then - if Checks and then HT.Length = HT.Capacity then - raise Capacity_Error with "no more capacity for insertion"; - end if; - - New_Node (HT, Node); - Set_Next (HT.Nodes (Node), Next => 0); - - Inserted := True; - - HT.Buckets (Indx) := Node; - HT.Length := HT.Length + 1; - - return; - end if; - - loop - if Equivalent_Keys (Key, HT.Nodes (Node)) then - Inserted := False; - return; - end if; - - Node := Next (HT.Nodes (Node)); - - exit when Node = 0; - end loop; - - if Checks and then HT.Length = HT.Capacity then - raise Capacity_Error with "no more capacity for insertion"; - end if; - - New_Node (HT, Node); - Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx)); - - Inserted := True; - - HT.Buckets (Indx) := Node; - HT.Length := HT.Length + 1; - end Generic_Conditional_Insert; - - ----------------------------- - -- Generic_Replace_Element -- - ----------------------------- - - procedure Generic_Replace_Element - (HT : in out Hash_Table_Type; - Node : Count_Type; - Key : Key_Type) - is - pragma Assert (HT.Length > 0); - pragma Assert (Node /= 0); - - BB : Buckets_Type renames HT.Buckets; - NN : Nodes_Type renames HT.Nodes; - - Old_Indx : Hash_Type; - New_Indx : constant Hash_Type := Index (HT, Key); - - New_Bucket : Count_Type renames BB (New_Indx); - N, M : Count_Type; - - begin - Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; - - -- Replace_Element is allowed to change a node's key to Key - -- (generic formal operation Assign provides the mechanism), but - -- only if Key is not already in the hash table. (In a unique-key - -- hash table as this one, a key is mapped to exactly one node.) - - if Equivalent_Keys (Key, NN (Node)) then - -- The new Key value is mapped to this same Node, so Node - -- stays in the same bucket. - - Assign (NN (Node), Key); - return; - end if; - - -- Key is not equivalent to Node, so we now have to determine if it's - -- equivalent to some other node in the hash table. This is the case - -- irrespective of whether Key is in the same or a different bucket from - -- Node. - - N := New_Bucket; - while N /= 0 loop - if Checks and then Equivalent_Keys (Key, NN (N)) then - pragma Assert (N /= Node); - raise Program_Error with - "attempt to replace existing element"; - end if; - - N := Next (NN (N)); - end loop; - - -- We have determined that Key is not already in the hash table, so - -- the change is allowed. - - if Old_Indx = New_Indx then - -- The node is already in the bucket implied by Key. In this case - -- we merely change its value without moving it. - - Assign (NN (Node), Key); - return; - end if; - - -- The node is in a bucket different from the bucket implied by Key. - -- Do the assignment first, before moving the node, so that if Assign - -- propagates an exception, then the hash table will not have been - -- modified (except for any possible side-effect Assign had on Node). - - Assign (NN (Node), Key); - - -- Now we can safely remove the node from its current bucket - - N := BB (Old_Indx); -- get value of first node in old bucket - pragma Assert (N /= 0); - - if N = Node then -- node is first node in its bucket - BB (Old_Indx) := Next (NN (Node)); - - else - pragma Assert (HT.Length > 1); - - loop - M := Next (NN (N)); - pragma Assert (M /= 0); - - if M = Node then - Set_Next (NN (N), Next => Next (NN (Node))); - exit; - end if; - - N := M; - end loop; - end if; - - -- Now we link the node into its new bucket (corresponding to Key) - - Set_Next (NN (Node), Next => New_Bucket); - New_Bucket := Node; - end Generic_Replace_Element; - - ----------- - -- Index -- - ----------- - - function Index - (HT : Hash_Table_Type; - Key : Key_Type) return Hash_Type is - begin - return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; - end Index; - -end Ada.Containers.Hash_Tables.Generic_Formal_Keys; diff --git a/gcc/ada/libgnat/a-chtgfk.ads b/gcc/ada/libgnat/a-chtgfk.ads deleted file mode 100644 index a2ce37c68f7..00000000000 --- a/gcc/ada/libgnat/a-chtgfk.ads +++ /dev/null @@ -1,101 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_KEYS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2024, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Hash_Table_Type is used to implement hashed containers. This package --- declares hash-table operations that depend on keys. - -generic - with package HT_Types is - new Generic_Formal_Hash_Table_Types (<>); - - use HT_Types; - - with function Next (Node : Node_Type) return Count_Type; - - with procedure Set_Next - (Node : in out Node_Type; - Next : Count_Type); - - type Key_Type (<>) is limited private; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys - (Key : Key_Type; - Node : Node_Type) return Boolean; - -package Ada.Containers.Hash_Tables.Generic_Formal_Keys is - pragma Pure; - - function Index - (HT : Hash_Table_Type; - Key : Key_Type) return Hash_Type; - pragma Inline (Index); - -- Returns the bucket number (array index value) for the given key - - procedure Delete_Key_Sans_Free - (HT : in out Hash_Table_Type; - Key : Key_Type; - X : out Count_Type); - -- Removes the node (if any) with the given key from the hash table - - function Find - (HT : Hash_Table_Type; - Key : Key_Type) return Count_Type; - -- Returns the node (if any) corresponding to the given key - - generic - with procedure New_Node - (HT : in out Hash_Table_Type; - Node : out Count_Type); - procedure Generic_Conditional_Insert - (HT : in out Hash_Table_Type; - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean); - -- Attempts to insert a new node with the given key into the hash table. - -- If a node with that key already exists in the table, then that node - -- is returned and Inserted returns False. Otherwise New_Node is called - -- to allocate a new node, and Inserted returns True. - - generic - with function Hash (Node : Node_Type) return Hash_Type; - with procedure Assign (Node : in out Node_Type; Key : Key_Type); - procedure Generic_Replace_Element - (HT : in out Hash_Table_Type; - Node : Count_Type; - Key : Key_Type); - -- Assigns Key to Node, possibly changing its equivalence class. Procedure - -- Assign is called to assign Key to Node. If Node is not in the same - -- bucket as Key before the assignment, it is moved from its current bucket - -- to the bucket implied by Key. Note that it is never proper to assign to - -- Node a key value already in the hash table, and so if Key is equivalent - -- to some other node then Program_Error is raised. - -end Ada.Containers.Hash_Tables.Generic_Formal_Keys; diff --git a/gcc/ada/libgnat/a-chtgfo.adb b/gcc/ada/libgnat/a-chtgfo.adb deleted file mode 100644 index df7b554c050..00000000000 --- a/gcc/ada/libgnat/a-chtgfo.adb +++ /dev/null @@ -1,413 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2024, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; use type System.Address; - -package body Ada.Containers.Hash_Tables.Generic_Formal_Operations is - - Checks : constant Boolean := Container_Checks'Enabled; - - ----------- - -- Clear -- - ----------- - - procedure Clear (HT : in out Hash_Table_Type) is - begin - HT.Length := 0; - HT.Free := -1; - HT.Buckets := [others => 0]; -- optimize this somehow ??? - end Clear; - - --------------------------- - -- Delete_Node_Sans_Free -- - --------------------------- - - procedure Delete_Node_Sans_Free - (HT : in out Hash_Table_Type; - X : Count_Type) - is - pragma Assert (X /= 0); - - Indx : Hash_Type; - Prev : Count_Type; - Curr : Count_Type; - - begin - if Checks and then HT.Length = 0 then - raise Program_Error with - "attempt to delete node from empty hashed container"; - end if; - - Indx := Index (HT, HT.Nodes (X)); - Prev := HT.Buckets (Indx); - - if Checks and then Prev = 0 then - raise Program_Error with - "attempt to delete node from empty hash bucket"; - end if; - - if Prev = X then - HT.Buckets (Indx) := Next (HT.Nodes (Prev)); - HT.Length := HT.Length - 1; - return; - end if; - - if Checks and then HT.Length = 1 then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - loop - Curr := Next (HT.Nodes (Prev)); - - if Checks and then Curr = 0 then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - if Curr = X then - Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr))); - HT.Length := HT.Length - 1; - return; - end if; - - Prev := Curr; - end loop; - end Delete_Node_Sans_Free; - - ----------- - -- First -- - ----------- - - function First (HT : Hash_Table_Type) return Count_Type is - Indx : Hash_Type; - - begin - if HT.Length = 0 then - return 0; - end if; - - Indx := HT.Buckets'First; - loop - if HT.Buckets (Indx) /= 0 then - return HT.Buckets (Indx); - end if; - - Indx := Indx + 1; - end loop; - end First; - - ---------- - -- Free -- - ---------- - - procedure Free - (HT : in out Hash_Table_Type; - X : Count_Type) - is - N : Nodes_Type renames HT.Nodes; - - begin - -- This subprogram "deallocates" a node by relinking the node off of the - -- active list and onto the free list. Previously it would flag index - -- value 0 as an error. The precondition was weakened, so that index - -- value 0 is now allowed, and this value is interpreted to mean "do - -- nothing". This makes its behavior analogous to the behavior of - -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add - -- special-case checks at the point of call. - - if X = 0 then - return; - end if; - - pragma Assert (X <= HT.Capacity); - - -- pragma Assert (N (X).Prev >= 0); -- node is active - -- Find a way to mark a node as active vs. inactive; we could - -- use a special value in Color_Type for this. ??? - - -- The hash table actually contains two data structures: a list for - -- the "active" nodes that contain elements that have been inserted - -- onto the container, and another for the "inactive" nodes of the free - -- store. - -- - -- We desire that merely declaring an object should have only minimal - -- cost; specially, we want to avoid having to initialize the free - -- store (to fill in the links), especially if the capacity is large. - -- - -- The head of the free list is indicated by Container.Free. If its - -- value is non-negative, then the free store has been initialized - -- in the "normal" way: Container.Free points to the head of the list - -- of free (inactive) nodes, and the value 0 means the free list is - -- empty. Each node on the free list has been initialized to point - -- to the next free node (via its Next component), and the value 0 - -- means that this is the last free node. - -- - -- If Container.Free is negative, then the links on the free store - -- have not been initialized. In this case the link values are - -- implied: the free store comprises the components of the node array - -- started with the absolute value of Container.Free, and continuing - -- until the end of the array (Nodes'Last). - -- - -- ??? - -- It might be possible to perform an optimization here. Suppose that - -- the free store can be represented as having two parts: one - -- comprising the non-contiguous inactive nodes linked together - -- in the normal way, and the other comprising the contiguous - -- inactive nodes (that are not linked together, at the end of the - -- nodes array). This would allow us to never have to initialize - -- the free store, except in a lazy way as nodes become inactive. - - -- When an element is deleted from the list container, its node - -- becomes inactive, and so we set its Next component to value of - -- the node's index (in the nodes array), to indicate that it is - -- now inactive. This provides a useful way to detect a dangling - -- cursor reference. ??? - - Set_Next (N (X), Next => X); -- Node is deallocated (not on active list) - - if HT.Free >= 0 then - -- The free store has previously been initialized. All we need to - -- do here is link the newly-free'd node onto the free list. - - Set_Next (N (X), HT.Free); - HT.Free := X; - - elsif X + 1 = abs HT.Free then - -- The free store has not been initialized, and the node becoming - -- inactive immediately precedes the start of the free store. All - -- we need to do is move the start of the free store back by one. - - HT.Free := HT.Free + 1; - - else - -- The free store has not been initialized, and the node becoming - -- inactive does not immediately precede the free store. Here we - -- first initialize the free store (meaning the links are given - -- values in the traditional way), and then link the newly-free'd - -- node onto the head of the free store. - - -- ??? - -- See the comments above for an optimization opportunity. If - -- the next link for a node on the free store is negative, then - -- this means the remaining nodes on the free store are - -- physically contiguous, starting as the absolute value of - -- that index value. - - HT.Free := abs HT.Free; - - if HT.Free > HT.Capacity then - HT.Free := 0; - - else - for I in HT.Free .. HT.Capacity - 1 loop - Set_Next (Node => N (I), Next => I + 1); - end loop; - - Set_Next (Node => N (HT.Capacity), Next => 0); - end if; - - Set_Next (Node => N (X), Next => HT.Free); - HT.Free := X; - end if; - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (HT : in out Hash_Table_Type; - Node : out Count_Type) - is - N : Nodes_Type renames HT.Nodes; - - begin - if HT.Free >= 0 then - Node := HT.Free; - - -- We always perform the assignment first, before we - -- change container state, in order to defend against - -- exceptions duration assignment. - - Set_Element (N (Node)); - HT.Free := Next (N (Node)); - - else - -- A negative free store value means that the links of the nodes - -- in the free store have not been initialized. In this case, the - -- nodes are physically contiguous in the array, starting at the - -- index that is the absolute value of the Container.Free, and - -- continuing until the end of the array (Nodes'Last). - - Node := abs HT.Free; - - -- As above, we perform this assignment first, before modifying - -- any container state. - - Set_Element (N (Node)); - HT.Free := HT.Free - 1; - end if; - end Generic_Allocate; - - ------------------- - -- Generic_Equal -- - ------------------- - - function Generic_Equal - (L, R : Hash_Table_Type) return Boolean - is - L_Index : Hash_Type; - L_Node : Count_Type; - - N : Count_Type; - - begin - if L.Length /= R.Length then - return False; - end if; - - if L.Length = 0 then - return True; - end if; - - -- Find the first node of hash table L - - L_Index := L.Buckets'First; - loop - L_Node := L.Buckets (L_Index); - exit when L_Node /= 0; - L_Index := L_Index + 1; - end loop; - - -- For each node of hash table L, search for an equivalent node in hash - -- table R. - - N := L.Length; - loop - if not Find (HT => R, Key => L.Nodes (L_Node)) then - return False; - end if; - - N := N - 1; - - L_Node := Next (L.Nodes (L_Node)); - - if L_Node = 0 then - - -- We have exhausted the nodes in this bucket - - if N = 0 then - return True; - end if; - - -- Find the next bucket - - loop - L_Index := L_Index + 1; - L_Node := L.Buckets (L_Index); - exit when L_Node /= 0; - end loop; - end if; - end loop; - end Generic_Equal; - - ----------------------- - -- Generic_Iteration -- - ----------------------- - - procedure Generic_Iteration (HT : Hash_Table_Type) is - Node : Count_Type; - - begin - if HT.Length = 0 then - return; - end if; - - for Indx in HT.Buckets'Range loop - Node := HT.Buckets (Indx); - while Node /= 0 loop - Process (Node); - Node := Next (HT.Nodes (Node)); - end loop; - end loop; - end Generic_Iteration; - - ----------- - -- Index -- - ----------- - - function Index - (Buckets : Buckets_Type; - Node : Node_Type) return Hash_Type is - begin - return Buckets'First + Hash_Node (Node) mod Buckets'Length; - end Index; - - function Index - (HT : Hash_Table_Type; - Node : Node_Type) return Hash_Type is - begin - return Index (HT.Buckets, Node); - end Index; - - ---------- - -- Next -- - ---------- - - function Next - (HT : Hash_Table_Type; - Node : Count_Type) return Count_Type - is - Result : Count_Type; - First : Hash_Type; - - begin - Result := Next (HT.Nodes (Node)); - - if Result /= 0 then -- another node in same bucket - return Result; - end if; - - -- This was the last node in the bucket, so move to the next - -- bucket, and start searching for next node from there. - - First := Index (HT, HT.Nodes (Node)) + 1; - for Indx in First .. HT.Buckets'Last loop - Result := HT.Buckets (Indx); - - if Result /= 0 then -- bucket is not empty - return Result; - end if; - end loop; - - return 0; - end Next; - -end Ada.Containers.Hash_Tables.Generic_Formal_Operations; diff --git a/gcc/ada/libgnat/a-chtgfo.ads b/gcc/ada/libgnat/a-chtgfo.ads deleted file mode 100644 index f4471bec3d2..00000000000 --- a/gcc/ada/libgnat/a-chtgfo.ads +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2024, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Hash_Table_Type is used to implement hashed containers. This package --- declares hash-table operations that do not depend on keys. - -generic - with package HT_Types is - new Generic_Formal_Hash_Table_Types (<>); - - use HT_Types; - - with function Hash_Node (Node : Node_Type) return Hash_Type; - - with function Next (Node : Node_Type) return Count_Type; - - with procedure Set_Next - (Node : in out Node_Type; - Next : Count_Type); - -package Ada.Containers.Hash_Tables.Generic_Formal_Operations is - pragma Pure; - - function Index - (Buckets : Buckets_Type; - Node : Node_Type) return Hash_Type; - pragma Inline (Index); - -- Uses the hash value of Node to compute its Buckets array index - - function Index - (HT : Hash_Table_Type; - Node : Node_Type) return Hash_Type; - pragma Inline (Index); - -- Uses the hash value of Node to compute its Hash_Table buckets array - -- index. - - generic - with function Find - (HT : Hash_Table_Type; - Key : Node_Type) return Boolean; - function Generic_Equal (L, R : Hash_Table_Type) return Boolean; - -- Used to implement hashed container equality. For each node in hash table - -- L, it calls Find to search for an equivalent item in hash table R. If - -- Find returns False for any node then Generic_Equal terminates - -- immediately and returns False. Otherwise if Find returns True for every - -- node then Generic_Equal returns True. - - procedure Clear (HT : in out Hash_Table_Type); - -- Empties the hash table HT - - procedure Delete_Node_Sans_Free - (HT : in out Hash_Table_Type; - X : Count_Type); - -- Removes node X from the hash table without deallocating the node - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (HT : in out Hash_Table_Type; - Node : out Count_Type); - -- Claim a node from the free store. Generic_Allocate first - -- calls Set_Element on the potential node, and then returns - -- the node's index as the value of the Node parameter. - - procedure Free - (HT : in out Hash_Table_Type; - X : Count_Type); - -- Return a node back to the free store, from where it had - -- been previously claimed via Generic_Allocate. - - function First (HT : Hash_Table_Type) return Count_Type; - -- Returns the head of the list in the first (lowest-index) non-empty - -- bucket. - - function Next - (HT : Hash_Table_Type; - Node : Count_Type) return Count_Type; - -- Returns the node that immediately follows Node. This corresponds to - -- either the next node in the same bucket, or (if Node is the last node in - -- its bucket) the head of the list in the first non-empty bucket that - -- follows. - - generic - with procedure Process (Node : Count_Type); - procedure Generic_Iteration (HT : Hash_Table_Type); - -- Calls Process for each node in hash table HT - -end Ada.Containers.Hash_Tables.Generic_Formal_Operations; diff --git a/gcc/ada/libgnat/a-cohata.ads b/gcc/ada/libgnat/a-cohata.ads index 2ae2be78422..89540d4f75a 100644 --- a/gcc/ada/libgnat/a-cohata.ads +++ b/gcc/ada/libgnat/a-cohata.ads @@ -79,23 +79,4 @@ package Ada.Containers.Hash_Tables is package Implementation is new Helpers.Generic_Implementation; end Generic_Bounded_Hash_Table_Types; - generic - type Node_Type is private; - package Generic_Formal_Hash_Table_Types is - - type Nodes_Type is array (Count_Type range <>) of Node_Type; - type Buckets_Type is array (Hash_Type range <>) of Count_Type; - - type Hash_Table_Type - (Capacity : Count_Type; - Modulus : Hash_Type) is - record - Length : Count_Type := 0; - Free : Count_Type'Base := -1; - Nodes : Nodes_Type (1 .. Capacity); - Buckets : Buckets_Type (1 .. Modulus) := [others => 0]; - end record; - - end Generic_Formal_Hash_Table_Types; - end Ada.Containers.Hash_Tables; From patchwork Mon Nov 4 16:10:49 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: 2006307 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=A2EXasqi; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxQw4qT2z1xxW for ; Tue, 5 Nov 2024 03:15:52 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 42C5F3857810 for ; Mon, 4 Nov 2024 16:15:50 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32d.google.com (mail-wm1-x32d.google.com [IPv6:2a00:1450:4864:20::32d]) by sourceware.org (Postfix) with ESMTPS id 65FDB385783B for ; Mon, 4 Nov 2024 16:11:38 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 65FDB385783B 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 65FDB385783B Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::32d ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736721; cv=none; b=hPZgChBuJ0a33TbmlLRPwGI/HWjs7rlYt2tmuQV4xwVdp9IhJPR/BA2iC4x7CgObTPZsbPKOF/zWA/tOnY41C06lG5AYyyrhejmev1AAbWmAFaInunB3TxKdPupcn8PyFjn58O60xdFuH23Mi+u3idkRr8QS7npdbbuf2ZIu52I= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736721; c=relaxed/simple; bh=R+TtTOLmME47RyrGYo1j5TGt/BOMD33p/fRUSj+5ZB4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=Y/c1KpUTu6urwTTV5IAME6nHTnjy2Th58vWobnxr7liHIU+vjH6hYzcX3e6o4r3Bfnqe9GhKRByrekMXxNuOM1ReRTwxgcj166xYTlfgAk2ByStg+IRxhJVUoRVWsVGkQnn2VkMIZJcN/jT0VIeN9UazFrYqplJPueA8W8ZjIyk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32d.google.com with SMTP id 5b1f17b1804b1-43169902057so34632855e9.0 for ; Mon, 04 Nov 2024 08:11:38 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736697; x=1731341497; 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=/zKuo5MpHMl02s9ee9jnnd/2WotGCTNemAzcRrf+dhU=; b=A2EXasqiRy0Fgqed51h+sPOx4Q6XWE7O4WEjNz9DXuOIyuCxQJcbhejeASMVmRDmb/ loq5pm2sZhs1B93uXPQTY60pRmNWDryk74HwlhmsRZuZXHUT2R+Cb1n/38Q7CqtSUwus UDfV13UZQ8YBuTvwAwMso/9yMkWsSoiyoCC0zBaye2j5XCXaN36J1tlUzcGVkl0RQlXz cLWcomf2u0++bdSgOVVtY7JC1ntndQGqzZ+/nUTpLwG905C7DF2h4Ub2IuDM9eRfAcV1 v+qoLOw3RcTFdiOCNIxjQVrdHB2jFmn3hqVuEJG7qNGXtgbfsUjKTEM+oY0Ij2kImBuJ 0xYg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736697; x=1731341497; 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=/zKuo5MpHMl02s9ee9jnnd/2WotGCTNemAzcRrf+dhU=; b=nUbLz9V4vm31CzzshMQ+qjTRTtYoizAll7Bc8JUhVvfhzgohekx8rIVpOaJTZUBgPT gxBIJtuA9c3ZC+2mL8dZu3SyvlJo7Q6/VJ8jb9SmJjDkQlhJQ7RrdAlDCts7gIbyZiCY QZMG2fo4+lPKX890qsAN47iWo95juPKpOca8N4HI1yjoyiX4qLwp6G8Le9iCG9DLffaq 9Qsr0VmglouWpYw3UpJvAa3wqJw5scP4xz3VWG8xNtZ0wkuFuUYvjWFeNqlF9q6G/XFs zIzL9COlT8u2XQtpy79xs0PT8Chl12JltAJkAdr4q5E0u3nGuyLnORu2zjtsD4FLkieC t1dg== X-Gm-Message-State: AOJu0YzkbEj4d1jjadOFj54VizFpG0pXzd+2kbfzv5bPbnNlsELPhGOd Iwv1aCTOTJU5PRAHGB+Wgc8ba63Y1WvuCswSSqqUXemOiZudm8E9sZJRAW/fBQcEIsy53MxBlX0 = X-Google-Smtp-Source: AGHT+IENZ8pYOePHModmWPXMp2U/G//01lCfTxVQaTCRcf7dSYsEdFQBQSdsqaM9mfGPNS3RZMElhQ== X-Received: by 2002:a05:600c:458f:b0:431:5ed4:7e7d with SMTP id 5b1f17b1804b1-4327a82f755mr165819285e9.18.1730736696968; Mon, 04 Nov 2024 08:11:36 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.36 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:36 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Daniel King Subject: [COMMITTED 14/38] ada: Fix alignment of pthread_mutex_t Date: Mon, 4 Nov 2024 17:10:49 +0100 Message-ID: <20241104161116.1431659-14-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Daniel King On most targets the alignment of unsigned long is the same as pointer alignment, but on CHERI targets pointers have larger alignment (16 bytes compared to 8 bytes). pthread_mutex_t needs the same alignment as System.Address to account for CHERI targets. gcc/ada/ChangeLog: * libgnat/s-oslock__posix.ads: Fix alignment of pthread_mutex_t for CHERI targets. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-oslock__posix.ads | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/gcc/ada/libgnat/s-oslock__posix.ads b/gcc/ada/libgnat/s-oslock__posix.ads index e2c237f2698..cde92e5f23a 100644 --- a/gcc/ada/libgnat/s-oslock__posix.ads +++ b/gcc/ada/libgnat/s-oslock__posix.ads @@ -52,6 +52,11 @@ private Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE); end record; pragma Convention (C, pthread_mutex_t); - for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment; + for pthread_mutex_t'Alignment use + Integer'Max (Interfaces.C.unsigned_long'Alignment, + System.Address'Alignment); + -- On some targets (e.g. CHERI), pointers have larger alignment than + -- unsigned_long. On other targets (e.g. some 16-bit targets) long is + -- larger than a pointer. Choose the largest to err on the side of caution. end System.OS_Locks; From patchwork Mon Nov 4 16:10:50 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: 2006305 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=T1Sf3uPo; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxQC4Dflz1xyD for ; Tue, 5 Nov 2024 03:15:15 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9E855385AC24 for ; Mon, 4 Nov 2024 16:15:13 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lf1-x12f.google.com (mail-lf1-x12f.google.com [IPv6:2a00:1450:4864:20::12f]) by sourceware.org (Postfix) with ESMTPS id 83384385829B for ; Mon, 4 Nov 2024 16:11:40 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 83384385829B 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 83384385829B Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::12f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736720; cv=none; b=TnNaQ5Bj81BdofffHEy+NdjEiGifvGSyxKXlWkbPPtHnJwOHLlhjI2NZT95DWgUCF4HQbWUqLJV2hU8mvJx74YMqq0O7luxcM5IJB0XbZrZNRXMV3FJTLtqQD3b5WZnzndQmCoL04i1PoP2HbpZG+i0SXFCtGqf0Ewm0FVzMmAg= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736720; c=relaxed/simple; bh=aC4m9+JPKUPe7mxO4VToEjgtYGPrfRM1LeBH6YkqyMc=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=h/Rt/9MjyfE6aM928xXOiTKFJwG+7WyPgLEJ9++94upsRJhjM8wKx8Uq0yx+uvNXXv13juiPSJ4qOnZtaq30i3zGDVTrq2UEXtAaCpjN+DMTwcZgPHpKwgu/0EJBaKQRgfd6Nsb9Yx1ycaLCovKMUJ0MqB0H+ToX+twZo65qa3A= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-lf1-x12f.google.com with SMTP id 2adb3069b0e04-53c779ef19cso5095163e87.3 for ; Mon, 04 Nov 2024 08:11:40 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736698; x=1731341498; 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=AlJB0L1YoJNrxn38JV2KZH4JDvXzzRmTtsJ0fKKF4E4=; b=T1Sf3uPoqZ5WLpQI1dGPW8Wl1KFVq196AMLB31mUIgABEvlBhcTlDbtbI7F2BStG/m u5jnStBCGIleEGD44luh/1lY6LMuIITK86U4gRlsO0ttZ8NAx2/vutMAUlD/IyM5fUwV EPxVaUCKKPUh35CJJWwyXSSJCbAIpuqj/vRxcicCUJvy7j7HKASzRNG1xJVfX8Mtwt7Z ieCYtf8/5g7M7nvTVHOVab2GxuD0bZnLKzyDOMaS/Orj7+eseS6jdMp7cNwW45mfsy3n /TYfaHX2EeFYr+J0sEvZ7A01gtWQB83efa4P9O7tyQxPWGHdVfPCjY2GlweE+4vARZu2 zO5A== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736698; x=1731341498; 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=AlJB0L1YoJNrxn38JV2KZH4JDvXzzRmTtsJ0fKKF4E4=; b=JXBBybljcwKbDLQoWRVcYCwTnYzQACw7JtxOTnaJzFd+gwxJtg2PY1nd/6uHgDjJII ovzarQjxLHzM+R1cWR/WryWQ/x6lqRMgmpoYPB1sgGQWiGvbpPMdLPjBu7689Z3eEa8E q3NB8sDizLHazNK2S+26NmUTLUdYv3h0igh3SmpBHleyBLIP4IPYoqNdeL4Rziz/Nkf+ bxwDHKy+q6aa6AVYEGYD5FyScuK7BHo/DZN7AFfY6xbtiYDhug+NUqyvE1U6yqYm4ROt fCWdcG2CZ2EwOu0DybBaEznRf62eYynd9ltGf2A3q6Esn9Muw/sbwL12X4Tz1fmb39iL +E1Q== X-Gm-Message-State: AOJu0YwrBdHiM72mB0eEYGvalZQ4MI0cY3ln1d7Hs6A2kf18KJT9GJn1 wEzDQA/EWGL6lXZhYJvO86KMBDXLRn2XVoXerN6di6ykGFpxHUm1oXMd1L9YKVCE6mbjjKVVciM = X-Google-Smtp-Source: AGHT+IHnFTBgqTUL/4by7d4vula0KXcH1zLkV5hK4Ut8Poy+HjkEy8Z0SNznzYZ4E9Q0AkcJxtsE8g== X-Received: by 2002:a05:6512:334f:b0:53a:d8b:95c0 with SMTP id 2adb3069b0e04-53c79e4c3e3mr5114109e87.30.1730736697904; Mon, 04 Nov 2024 08:11:37 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.37 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:37 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Daniel King Subject: [COMMITTED 15/38] ada: Refactor exception declarations from Interfaces.CHERI to separate package Date: Mon, 4 Nov 2024 17:10:50 +0100 Message-ID: <20241104161116.1431659-15-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Daniel King Exception declarations require elaboration on the full run-time to register the exceptions. The package Interfaces.CHERI, however, is used on bare-metal targets during early initialization, before elaboration and is therefore marked No_Elaboration_Code_All. Refactoring the exception declarations to a separate package allows the common CHERI bindings to be used in such contexts. gcc/ada/ChangeLog: * libgnat/i-cheri.ads: Remove exception declarations. * libgnat/i-cheri-exceptions.ads: New file. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/i-cheri-exceptions.ads | 50 ++++++++++++++++++++++++++ gcc/ada/libgnat/i-cheri.ads | 16 --------- 2 files changed, 50 insertions(+), 16 deletions(-) create mode 100644 gcc/ada/libgnat/i-cheri-exceptions.ads diff --git a/gcc/ada/libgnat/i-cheri-exceptions.ads b/gcc/ada/libgnat/i-cheri-exceptions.ads new file mode 100644 index 00000000000..88ecb1325c4 --- /dev/null +++ b/gcc/ada/libgnat/i-cheri-exceptions.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C H E R I . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2024, AdaCore -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines exception types for CHERI-related errors + +package Interfaces.CHERI.Exceptions with + Preelaborate +is + + Capability_Bound_Error : exception; + -- An out-of-bounds access was attempted + + Capability_Permission_Error : exception; + -- An attempted access exceeded the permissions granted by a capability + + Capability_Sealed_Error : exception; + -- A sealed capability was dereferenced + + Capability_Tag_Error : exception; + -- An invalid capability was dereferenced + +end Interfaces.CHERI.Exceptions; diff --git a/gcc/ada/libgnat/i-cheri.ads b/gcc/ada/libgnat/i-cheri.ads index 389583a012f..9fbcb885284 100644 --- a/gcc/ada/libgnat/i-cheri.ads +++ b/gcc/ada/libgnat/i-cheri.ads @@ -467,20 +467,4 @@ is External_Name => "__builtin_cheri_stack_get"; -- Get the Capability Stack Pointer (CSP) - --------------------------- - -- Capability Exceptions -- - --------------------------- - - Capability_Bound_Error : exception; - -- An out-of-bounds access was attempted - - Capability_Permission_Error : exception; - -- An attempted access exceeded the permissions granted by a capability - - Capability_Sealed_Error : exception; - -- A sealed capability was dereferenced - - Capability_Tag_Error : exception; - -- An invalid capability was dereferenced - end Interfaces.CHERI; From patchwork Mon Nov 4 16:10:51 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: 2006310 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=RQYtnSn1; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxRg6BLGz1xxW for ; Tue, 5 Nov 2024 03:16:31 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id F3D443857823 for ; Mon, 4 Nov 2024 16:16:29 +0000 (GMT) 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 7950C3858410 for ; Mon, 4 Nov 2024 16:11:40 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 7950C3858410 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 7950C3858410 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42c ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736725; cv=none; b=aH3zvFqLBdBEQ9KhulQnS5Sly5T+jj5yfF8ARNfnEfOBUrshHUynlja9HO/q+MY9GhJ2T8AQXn/zw4XUUhB6YvURZDX2q//qcGNc4F8pgk300WfWrEcxbM/C+6foPW9AMhNmzvs9Apmcv2Rx6m88G7C+roCs7yqPcnToeQ9Xh6A= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736725; c=relaxed/simple; bh=A/Tj8baPGaoltPzm+OoeQPcfDDf2Yd6yKDNS1BTokcY=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=Mx2Txg+G8oFLG32/KZ8ztEsDSdcJPhV0igBbStDCs9Q8iPDOOozXwbEBbjYuyrEqJD9Sv1EeHwpEVZVMXZ2YDSwOiCvLqJ60twAau1W0bXJ1h8HMQuPEwQ3F7Y7vUw6KRxsyP1+MzCNU3QY91UUo3ttD9Ob1h9mj6ogFh54iVQg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42c.google.com with SMTP id ffacd0b85a97d-37d5689eea8so2558404f8f.1 for ; Mon, 04 Nov 2024 08:11:40 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736699; x=1731341499; 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=XoybVv2k6KUF+6Y8kNWe0OlVjKxOmA4k2yfhpt8lhPc=; b=RQYtnSn15iMvqo8bzfvVaqPXalIaIkJiIDlJdnuZBPutyPeyf+7FFcsvz2BDfqJXY+ +eUlPctm5ddJjxlthy0aoW3YREghyiL4SPkBnlg+DArNGe+JiShKYtYj96oc5u9y8j5v VkUIk8ehkg9uwUqGwITGwcUlmDCFUbWOCdoYCZ1hQwWYrDISiRK77Ge61+7/6/OO8oYf +5+hhWydbNvvVJKjlZfTNTxcwmQcZ6zom1Mck2+QzOaoVxsu52ICQtHVKEjdcAE2ajGr bOyUbg/dSa9vcCVZXEGODCPRbccX6HD9bF4Keg2waAIVYIdP4cFIt1QP4L6sgptmFx05 Vs6Q== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736699; x=1731341499; 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=XoybVv2k6KUF+6Y8kNWe0OlVjKxOmA4k2yfhpt8lhPc=; b=eQB1mmCcBY+B9VvEC4M4WXd240fO6ZIkQ7hXW3EbnJJusVcCG+c31cBTnziq2AvpmS JLAYaEtL2a5lgHHqDUF3b4mZ+qdDSlBxj+YwEk/TZMZOUTLwWLuifbsvLkqtMiL4dHQL lSpTRNwPT+cZHRghNC8cDECDcm4ethyksuHMGWNYuB7l9z3xenhxoJawdX6FLxPZOcX5 6dZNljyNr9dJuuKZrqigbIwObVoLeG8UYNhpC4+wwaQTut10s2vfK7C7BPnbU5b2GlhJ C3K3WQ/jj81dMz9aAxKciIA/3yP0D4Zuf9hppvkGwckO0Fh+rGWtPPWCSY5gAim8c2gL aXCQ== X-Gm-Message-State: AOJu0Yy/t/d+xQ8/fX2CYAvgISL1WefnHF+XeSm3mVfNyV+NPMtCdarX yTPI72pGG6Ui9iDzjRM5m8zzhH7uHxjUkRTnATVBMT+Ao9n/1Ca1m5ibNB2jP0rV0bQNRP3/ZcQ = X-Google-Smtp-Source: AGHT+IG142krOHPcwqgxDeG3aVeX9wqRMUwXIfCYl3mO02Nk6kc7R6+BhCoj8Hjs/ebxYHMr366QiQ== X-Received: by 2002:adf:f282:0:b0:37d:4a00:5704 with SMTP id ffacd0b85a97d-38061200c32mr22350094f8f.38.1730736698755; Mon, 04 Nov 2024 08:11:38 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.38 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:38 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Daniel King Subject: [COMMITTED 16/38] ada: Build and runtime support for CheriBSD Date: Mon, 4 Nov 2024 17:10:51 +0100 Message-ID: <20241104161116.1431659-16-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Daniel King SIGPROT is a new signal on CheriBSD that signals a CHERI protection violation. The full runtime converts these to the appropriate Ada exception declared in Interfaces.CHERI.Exceptions. gcc/ada/ChangeLog: * Makefile.rtl: Build support for Morello CheriBSD. * libgnarl/s-intman__cheribsd.adb: New file for CheriBSD. * libgnarl/s-osinte__cheribsd.ads: New file for CheriBSD. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 18 +- gcc/ada/libgnarl/s-intman__cheribsd.adb | 332 ++++++++++++ gcc/ada/libgnarl/s-osinte__cheribsd.ads | 683 ++++++++++++++++++++++++ 3 files changed, 1030 insertions(+), 3 deletions(-) create mode 100644 gcc/ada/libgnarl/s-intman__cheribsd.adb create mode 100644 gcc/ada/libgnarl/s-osinte__cheribsd.ads diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 8656e71250b..904ec34026f 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1789,10 +1789,8 @@ ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),) a-nallfl.ads. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the POSIX threads version of this package, adapted for CheriBSD + +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. Be on +-- the lookout for special signals that may be used by the thread library. + +-- Since this is a multi target file, the signal <-> exception mapping +-- is simple minded. If you need a more precise and target specific +-- signal handling, create a new s-intman.adb that will fit your needs. + +-- This file assumes that: + +-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows: +-- SIGPFE => Constraint_Error +-- SIGILL => Program_Error +-- SIGSEGV => Storage_Error +-- SIGBUS => Storage_Error + +-- SIGINT exists and will be kept unmasked unless the pragma +-- Unreserve_All_Interrupts is specified anywhere in the application. + +-- System.OS_Interface contains the following: +-- SIGADAABORT: the signal that will be used to abort tasks. +-- Unmasked: the OS specific set of signals that should be unmasked in +-- all the threads. SIGADAABORT is unmasked by +-- default +-- Reserved: the OS specific set of signals that are reserved. + +with Interfaces.CHERI.Exceptions; +with System.Task_Primitives; + +package body System.Interrupt_Management is + + use Interfaces.C; + use Interfaces.CHERI.Exceptions; + use System.OS_Interface; + + type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; + Exception_Interrupts : constant Interrupt_List := + [SIGFPE, SIGILL, SIGSEGV, SIGBUS]; + + Unreserve_All_Interrupts : constant Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function State (Int : Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in init.c The input argument is the + -- interrupt number, and the result is one of the following: + + User : constant Character := 'u'; + Runtime : constant Character := 'r'; + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + procedure Notify_Exception + (signo : Signal; + siginfo : access siginfo_t; + ucontext : System.Address); + -- This function identifies the Ada exception to be raised using the + -- information when the system received a synchronous signal. Since this + -- function is machine and OS dependent, different code has to be provided + -- for different target. + + ---------------------- + -- Notify_Exception -- + ---------------------- + + Signal_Mask : aliased sigset_t; + -- The set of signals handled by Notify_Exception + + procedure Notify_Exception + (signo : Signal; + siginfo : access siginfo_t; + ucontext : System.Address) + is + Result : Interfaces.C.int; + + begin + -- With the __builtin_longjmp, the signal mask is not restored, so we + -- need to restore it explicitly. + + Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); + pragma Assert (Result = 0); + + -- Perform the necessary context adjustments prior to a raise + -- from a signal handler. + + Adjust_Context_For_Raise (signo, ucontext); + + -- Check that treatment of exception propagation here is consistent with + -- treatment of the abort signal in System.Task_Primitives.Operations. + + case signo is + when SIGFPE => raise Constraint_Error; + when SIGILL => raise Program_Error; + when SIGSEGV => raise Storage_Error; + when SIGBUS => raise Storage_Error; + when SIGPROT => + case siginfo.all.si_code is + when PROT_CHERI_TAG => raise Capability_Tag_Error; + when PROT_CHERI_SEALED => raise Capability_Sealed_Error; + when PROT_CHERI_UNALIGNED_BASE => raise Storage_Error; + + when PROT_CHERI_BOUNDS + | PROT_CHERI_IMPRECISE => + raise Capability_Bound_Error; + + when PROT_CHERI_TYPE + | PROT_CHERI_PERM + | PROT_CHERI_STORELOCAL + | PROT_CHERI_CINVOKE + | PROT_CHERI_SYSREG => + raise Capability_Permission_Error; + + when others => + raise Storage_Error; + end case; + + when others => + null; + end case; + end Notify_Exception; + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Result : System.OS_Interface.int; + + Use_Alternate_Stack : constant Boolean := + System.Task_Primitives.Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + + Sigsetable_Signal_Mask : aliased sigset_t; + + Interrupts_Default_To_System : Integer; + pragma Import (C, Interrupts_Default_To_System, + "__gl_interrupts_default_to_system"); + + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Need to call pthread_init very early because it is doing signal + -- initializations. + + pthread_init; + + Abort_Task_Interrupt := SIGADAABORT; + + act.sa_handler := Notify_Exception'Address; + + -- Setting SA_SIGINFO asks the kernel to pass more than just the signal + -- number argument to the handler when it is called. The set of extra + -- parameters includes a pointer to the interrupted context, which the + -- ZCX propagation scheme needs. + + -- Most man pages for sigaction mention that sa_sigaction should be set + -- instead of sa_handler when SA_SIGINFO is on. In practice, the two + -- fields are actually union'ed and located at the same offset. + + -- On some targets, we set sa_flags to SA_NODEFER so that during the + -- handler execution we do not change the Signal_Mask to be masked for + -- the Signal. + + -- This is a temporary fix to the problem that the Signal_Mask is not + -- restored after the exception (longjmp) from the handler. The right + -- fix should be made in sigsetjmp so that we save the Signal_Set and + -- restore it after a longjmp. + + -- Since SA_NODEFER is obsolete, instead we reset explicitly the mask + -- in the exception handler. + + Result := sigemptyset (Signal_Mask'Access); + pragma Assert (Result = 0); + + -- Add signals that map to Ada exceptions to the mask + + for J in Exception_Interrupts'Range loop + if State (Exception_Interrupts (J)) /= Default then + Result := sigaddset (Signal_Mask'Access, + Signal (Exception_Interrupts (J))); + pragma Assert (Result = 0); + end if; + end loop; + + act.sa_mask := Signal_Mask; + + pragma Assert (Keep_Unmasked = [Interrupt_ID'Range => False]); + pragma Assert (Reserve = [Interrupt_ID'Range => False]); + + -- Process state of exception signals + + for J in Exception_Interrupts'Range loop + if State (Exception_Interrupts (J)) /= User then + Keep_Unmasked (Exception_Interrupts (J)) := True; + Reserve (Exception_Interrupts (J)) := True; + + if State (Exception_Interrupts (J)) /= Default then + act.sa_flags := SA_SIGINFO; + + if Use_Alternate_Stack + and then Exception_Interrupts (J) = SIGSEGV + then + act.sa_flags := act.sa_flags + SA_ONSTACK; + end if; + + Result := + sigaction + (Signal (Exception_Interrupts (J)), act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end if; + end loop; + + if State (Abort_Task_Interrupt) /= User then + Keep_Unmasked (Abort_Task_Interrupt) := True; + Reserve (Abort_Task_Interrupt) := True; + end if; + + -- Set SIGINT to unmasked state as long as it is not in "User" state. + -- Check for Unreserve_All_Interrupts last. + + if State (SIGINT) /= User then + Keep_Unmasked (SIGINT) := True; + Reserve (SIGINT) := True; + end if; + + -- Check all signals for state that requires keeping them unmasked and + -- reserved. + + -- Unmasking might involve explicit operations later on, typically + -- performed on the entire set of relevant signals gathered together + -- by way of sigset_t mask. Doing anything of this kind is forbidden + -- for very specific signals and would trip assertion checks if + -- attempted. Check for this here, preventing the Keep_Unmasked + -- request upfront. This is of particular relevance for + -- Interrupts_System_By_Default as it would lead to such requests + -- for every signal not altered otherwise. + + Result := sigemptyset (Sigsetable_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + if Interrupts_Default_To_System = 0 or else + sigaddset (Sigsetable_Signal_Mask'Access, Signal (J)) = 0 + then + Keep_Unmasked (J) := True; + end if; + Reserve (J) := True; + end if; + end loop; + + -- Add the set of signals that must always be unmasked for this target + + for J in Unmasked'Range loop + Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True; + Reserve (Interrupt_ID (Unmasked (J))) := True; + end loop; + + -- Add target-specific reserved signals + + for J in Reserved'Range loop + Reserve (Interrupt_ID (Reserved (J))) := True; + end loop; + + -- Process pragma Unreserve_All_Interrupts. This overrides any settings + -- due to pragma Interrupt_State: + + if Unreserve_All_Interrupts /= 0 then + Keep_Unmasked (SIGINT) := False; + Reserve (SIGINT) := False; + end if; + + -- We do not really have Signal 0. We just use this value to identify + -- non-existent signals (see s-intnam.ads). Therefore, Signal should not + -- be used in all signal related operations hence mark it as reserved. + + Reserve (0) := True; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/libgnarl/s-osinte__cheribsd.ads b/gcc/ada/libgnarl/s-osinte__cheribsd.ads new file mode 100644 index 00000000000..fd3c603d8b4 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__cheribsd.ads @@ -0,0 +1,683 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, Florida State University -- +-- Copyright (C) 1995-2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the CheriBSD (POSIX Threads) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces; +with Interfaces.C; + +with System.OS_Locks; +with System.Parameters; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-pthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + type int32_t is new int; + type uint32_t is new unsigned; + type uint64_t is new unsigned_long; + type pid_t is new int32_t; + type uid_t is new uint32_t; + + ----------- + -- Errno -- + ----------- + + function Errno return int; + pragma Inline (Errno); + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 34; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD) + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGPROT : constant := 34; -- in-address space security (CHERI) exception + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + -- Interrupts that must be unmasked at all times. FreeBSD + -- pthreads will not allow an application to mask out any + -- interrupt needed by the threads library. + Unmasked : constant Signal_Set := + (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP); + + -- FreeBSD will uses SIGPROF for timing. Do not allow a + -- handler to attach to this signal. + Reserved : constant Signal_Set := (0 .. 0 => SIGPROF); + + type sigset_t is private; + + function sigaddset + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type siginfo_reason is array (Integer range 1 .. 8) of int; + type siginfo_t is record + si_signo : int; + si_errno : int; + si_code : int; + si_pid : pid_t; + si_uid : uid_t; + si_status : int; + si_addr : Address; + sival_int : int; + reason : siginfo_reason; + end record; + pragma Convention (C, siginfo_t); + + -- Codes for SIGPROT + PROT_CHERI_BOUNDS : constant int := 1; + PROT_CHERI_TAG : constant int := 2; + PROT_CHERI_SEALED : constant int := 3; + PROT_CHERI_TYPE : constant int := 4; + PROT_CHERI_PERM : constant int := 5; + PROT_CHERI_IMPRECISE : constant int := 7; + PROT_CHERI_STORELOCAL : constant int := 8; + PROT_CHERI_CINVOKE : constant int := 9; + PROT_CHERI_SYSREG : constant int := 11; + PROT_CHERI_UNALIGNED_BASE : constant int := 12; + + -- sigcontext is architecture dependent, so define it private + type struct_sigcontext is private; + + type old_struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, old_struct_sigaction); + + type new_struct_sigaction is record + sa_handler : System.Address; + sa_flags : int; + sa_mask : sigset_t; + end record; + pragma Convention (C, new_struct_sigaction); + + subtype struct_sigaction is new_struct_sigaction; + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_SIGINFO : constant := 16#0040#; + SA_ONSTACK : constant := 16#0001#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported (i.e SCHED_RR is supported) + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep, "nanosleep"); + + type clockid_t is new int; + + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + + procedure usleep (useconds : unsigned_long); + pragma Import (C, usleep, "usleep"); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_OTHER : constant := 2; + SCHED_RR : constant := 3; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + Self_PID : constant pid_t; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + subtype pthread_mutex_t is System.OS_Locks.pthread_mutex_t; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + PTHREAD_SCOPE_PROCESS : constant := 0; + PTHREAD_SCOPE_SYSTEM : constant := 2; + + -- Read/Write lock not supported on freebsd. To add support both types + -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined + -- with the associated routines pthread_rwlock_[init/destroy] and + -- pthread_rwlock_[rdlock/wrlock/unlock]. + + subtype pthread_rwlock_t is pthread_mutex_t; + subtype pthread_rwlockattr_t is pthread_mutexattr_t; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. Only call this function + -- when Stack_Base_Available is True. + + function Get_Page_Size return int; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + -- FSU_THREADS requires pthread_init, which is nonstandard and this should + -- be invoked during the elaboration of s-taprop.adb. + + -- FreeBSD does not require this so we provide an empty Ada body + + procedure pthread_init; + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import + (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol"); + + function pthread_mutexattr_getprotocol + (attr : access pthread_mutexattr_t; + protocol : access int) return int; + pragma Import + (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol"); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprioceiling"); + + function pthread_mutexattr_getprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : access int) return int; + pragma Import + (C, pthread_mutexattr_getprioceiling, + "pthread_mutexattr_getprioceiling"); + + type struct_sched_param is record + sched_priority : int; + end record; + pragma Convention (C, struct_sched_param); + + function pthread_getschedparam + (thread : pthread_t; + policy : access int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_getschedparam, "pthread_getschedparam"); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_getscope + (attr : access pthread_attr_t; + contentionscope : access int) return int; + pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import + (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); + + function pthread_attr_getinheritsched + (attr : access pthread_attr_t; + inheritsched : access int) return int; + pragma Import + (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, + "pthread_attr_setschedpolicy"); + + function pthread_attr_getschedpolicy + (attr : access pthread_attr_t; + policy : access int) return int; + pragma Import (C, pthread_attr_getschedpolicy, + "pthread_attr_getschedpolicy"); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); + + function pthread_attr_getschedparam + (attr : access pthread_attr_t; + sched_param : access int) return int; + pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam"); + + function sched_yield return int; + pragma Import (C, sched_yield, "pthread_yield"); + + -------------------------- + -- P1003.1c Section 16 -- + -------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_getdetachstate + (attr : access pthread_attr_t; + detachstate : access int) return int; + pragma Import + (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate"); + + function pthread_attr_getstacksize + (attr : access pthread_attr_t; + stacksize : access size_t) return int; + pragma Import + (C, pthread_attr_getstacksize, "pthread_attr_getstacksize"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import + (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + function pthread_detach (thread : pthread_t) return int; + pragma Import (C, pthread_detach, "pthread_detach"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + ------------------------------------ + -- Non-portable Pthread Functions -- + ------------------------------------ + + function pthread_set_name_np + (thread : pthread_t; + name : System.Address) return int; + pragma Import (C, pthread_set_name_np, "pthread_set_name_np"); + +private + + type sigset_t is array (1 .. 4) of unsigned; + + -- In FreeBSD the component sa_handler turns out to + -- be one a union type, and the selector is a macro: + -- #define sa_handler __sigaction_u._handler + -- #define sa_sigaction __sigaction_u._sigaction + + -- Should we add a signal_context type here ??? + -- How could it be done independent of the CPU architecture ??? + -- sigcontext type is opaque, so it is architecturally neutral. + -- It is always passed as an access type, so define it as an empty record + -- since the contents are not used anywhere. + + type struct_sigcontext is null record; + pragma Convention (C, struct_sigcontext); + + Self_PID : constant pid_t := 0; + + type time_t is range -2 ** (System.Parameters.time_t_bits - 1) + .. 2 ** (System.Parameters.time_t_bits - 1) - 1; + + type timespec is record + ts_sec : time_t; + ts_nsec : long; + end record; + pragma Convention (C, timespec); + + type pthread_t is new System.Address; + type pthread_attr_t is new System.Address; + type pthread_mutexattr_t is new System.Address; + type pthread_cond_t is new System.Address; + type pthread_condattr_t is new System.Address; + type pthread_key_t is new int; + +end System.OS_Interface; From patchwork Mon Nov 4 16:10:52 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 2006318 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=KCpx8hsx; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxTX4wJSz1xxW for ; Tue, 5 Nov 2024 03:18:08 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id AF723385AC30 for ; Mon, 4 Nov 2024 16:18:06 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32e.google.com (mail-wm1-x32e.google.com [IPv6:2a00:1450:4864:20::32e]) by sourceware.org (Postfix) with ESMTPS id F28423858280 for ; Mon, 4 Nov 2024 16:11:40 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org F28423858280 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 F28423858280 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::32e ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736720; cv=none; b=cJ12uvKBSTzyYkd6Ri9sXVVm5tgANK8jIhh5JCuUHu2E6DF1qfVPF+qQj8vo2RjHCFOi5eu71IfYwmjQBWis5ttXSn6wNNDREnx6EubtN8u0YyJuj3MEQHly3BwtWvMThpFAL4vVYwfiV4J/2pVdxf+A0K7BRaPBG3vYZm4HCf4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736720; c=relaxed/simple; bh=C3OFTDtC8MTrV22vTZPptAAZxH1YuUp/6JRQR7EsAGE=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=ZPpmRm+rupb/aW/Z5tyR7IgHWbPkqXDRWSuAJQ7FkmbhacXLh2hHiBiy5DrvbJJMYcRCYW5ZYF21S9Ue9WMgHgydjCbTMnR3YMDMazwxHcwKqFIdkzvh7J/5n6vqaXyaP3aJeyt6GZtLfXiOdG1fp0rXjZLpMpD7wDRwrP6LA9U= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32e.google.com with SMTP id 5b1f17b1804b1-431616c23b5so26499795e9.0 for ; Mon, 04 Nov 2024 08:11:40 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736699; x=1731341499; 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=DhAK3V1AxuMf153HUFsZvMWsZRR3i8USUzfZ4MUj/fw=; b=KCpx8hsx5mjpxqETcmhHDIpD0Vtrqwd6uPxNMCugscLRMraHfUJQoQoAZBd2wPYRfz zfBNX8k4FiixMAotagDPqqs6fAhDkOUnAL6ijXznr4+h1bhKUPKmQoE+DzGaht/kiEfV jpE6Q8CwlzAtD2ucLiDKyDNuU75ICNOjaeOKIscnq2758KGTcesLBsSZK2UNeFJCMGxU yT0JLrgl1rBlgdaOjvzA7AzEdcF4OgqecZ//1rbPYyYDpfV5oUKhWn3n8uGuymN2IPMM YBNA1iYDD+486P6Z9zHDIZxgaUt4lFAOvXVtFsOxomteF8n7o1uD9WJkkmBvsM46crci 6SXw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736699; x=1731341499; 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=DhAK3V1AxuMf153HUFsZvMWsZRR3i8USUzfZ4MUj/fw=; b=j7kFdxIc6ggwuWAGzE2XkYXSeQOXkrsw3ppC+67pRoYEu0AmwP4M8NLP+O9Pd+lRG+ vKg/f9OKbXOGy9jE2hlntqq+oX80DZcerPu3ACPKRPwZ6M8QDvo0YTbZJkVDce92qXBs pw1OcVC7RGTW3Z83+/sTW5eL3uFebvMUmjwHIoVZ5UaUZpI+LS/0etd5s02rExVrQieh oXxJ2Hy1FwgWMa1GQUq6ZTdegf8hyAugNY/Pv04Mcc782wXkjZG+Sxr9VIy4bG693n1o uwC8M05Zy1M9aIdlmZHmejdOKDSa9w+IpyKj7E2ZrKfkvGrhF0CX/154jOL6jgG78UlT KbYw== X-Gm-Message-State: AOJu0YwQy7wrAxKoWYQgW6pRQdShImsZPX8CDxjbElV0lv+Dd9qwKM1F 7iXwCeaXxxxoF/lfv4OcTwyVFraaf/Blvjs+mI01Cjs4Jpbd7FPyqP6VE+regWULJRN4TWnbcEQ = X-Google-Smtp-Source: AGHT+IEOGCp8iCe/aAlVBX8UGLHWH5JIB2vN5iKgXMtqjUNhWWHaAxHDhq3IK8oiaAJ3eJOK2jfqcw== X-Received: by 2002:a05:600c:45cd:b0:42c:b98d:b993 with SMTP id 5b1f17b1804b1-4327da72175mr121042525e9.2.1730736699501; Mon, 04 Nov 2024 08:11:39 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.38 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:39 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: =?utf-8?q?Rapha=C3=ABl_AMIARD?= Subject: [COMMITTED 17/38] ada: Fix error message for pragma First_Controlling_Parameter Date: Mon, 4 Nov 2024 17:10:52 +0100 Message-ID: <20241104161116.1431659-17-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Raphaël AMIARD gcc/ada/ChangeLog: * sem_prag.adb (Analyze_Pragma): Fix format for second line of warning (should be a continuation line) Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_prag.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 00df728e950..9a3e7acf34f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17906,7 +17906,7 @@ package body Sem_Prag is Error_Msg_N ("?_j?'First_'Controlling_'Parameter has no effect", N); Error_Msg_NE - ("?_j?because & does not implement interface types", + ("\?_j?because & does not implement interface types", N, E); end if; From patchwork Mon Nov 4 16:10:53 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: 2006299 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=fl5Itl7l; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxNk5FF8z1xwF for ; Tue, 5 Nov 2024 03:13:58 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2BE6E385AC1B for ; Mon, 4 Nov 2024 16:13:56 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32e.google.com (mail-wm1-x32e.google.com [IPv6:2a00:1450:4864:20::32e]) by sourceware.org (Postfix) with ESMTPS id B59063857704 for ; Mon, 4 Nov 2024 16:11:41 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B59063857704 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 B59063857704 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::32e ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736725; cv=none; b=Tdd8mebVGdSUW+JnkU8Z2tKGbGJMHukmmHnyBfQBqEnirA7sKKRP1kTtu0KIMtXzWjZXSo+3S3PoKBQVVYrdHAgFGrF5hBDrBSykzoIJajb/YuSd3YzQ53b7lAWF+crjqaVGNEr+zcTUTyqQtYjaLfl6D/scgdGYY0+XACqQPKY= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736725; c=relaxed/simple; bh=H58eNcOBZizQ/FAe+EDN5Y6gXSQvdA3g9NIyvLuppHA=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=SfopON0/bCzowqJRkzgM1v27a4FuCVgCAPssOX1EfN5cGlS7tNSzdGi/aZAGQUf1Qnq2gr+Mc6KX5NnZ4JwGn3NU0Bd2kPfdtdwrOzsG2SCoM3hapkPzEd4tb40cF1+wLQQqesuVIcVEnQ07ooUDcomdrM9o0kpZF2c4dDIUyKk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32e.google.com with SMTP id 5b1f17b1804b1-43169902057so34633265e9.0 for ; Mon, 04 Nov 2024 08:11:41 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736700; x=1731341500; 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=01nlqck8nLhs7sX+s9aXOgS7nkTlm88iFRexYZcBe4o=; b=fl5Itl7luo66OMe37SDeEUCCAk3JH8lx1RYrRg3GqcGgftwjrJ7Dt5VLXjzihSeVOe bkSANGZBsmkiM89EJIraJM98PZ6zJfv4ceQHy2vnVPVGDG2xiUd8KpEw3JvkZuQHBNF4 4vBh3XMmNdrH9OetKbgsxii52rb39JS2UlK8JGjdTihnzd2l/vqOIrryB7iHR1PgZCFG Hn2V8oKKfy9Y0dX5DiLP9RL98e3cEGaRmPWmJqPLGfSyIgINtMRo0vMt3ihd67FSmK/B dexdhHrEj4/EUSrwUdYdxp31ATTjJAkffy7vMmBlrgTqTA3olpVfOOFbgOCoubbGESYg VIpA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736700; x=1731341500; 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=01nlqck8nLhs7sX+s9aXOgS7nkTlm88iFRexYZcBe4o=; b=PSQR+IceGuB1LJvRCECAfvJN48eacMCvAsK1IKXZ0dALh9RdukWfq2S6aXEkIsWTAG 25HJxal8bZsFlO7msiD2SjXOWxElXg6AbQ+SRcdwD82i1hBajBBsbEPU21xAdN+5C/0j SBdxkACO2nuaUdW3r/VXfUaXcrjEwl0Q9elw+6y2+aBTCNuVZt2wDlz2lGgoUuXfYqPE IgL3KE62S9vfUpErdgMfFMN4A5ov8BjiLODSx88BP+TML+ToHtvandG8tNfVZBsIlgpu NBce0+ybPS+L2Xxf37Xn9/E2I7vhuI0m53ZZ+b8Yo6gzG0jGDZTRGdrSaG0F+RCLP7ro wffQ== X-Gm-Message-State: AOJu0Yxxitip9rUufWmHk802+dODcozAArYqNSiBJnyITux1zNIOVH5q Ixv6ryr7ldcCidIXYpNYtGpC/fFz8OdDKr09RKVGoW+2vugNq+W3qhjFbjRpaf0ZR6QksLNEkkU = X-Google-Smtp-Source: AGHT+IFCyvUJROM414O0O1ZPxl0bnCaCw3pn3sg+doc/CvNF1kPm0EyJkTQ0l1c2p7iHCae6jNx3Rw== X-Received: by 2002:a5d:4489:0:b0:37d:454f:b49a with SMTP id ffacd0b85a97d-381b70f0802mr15336481f8f.43.1730736700263; Mon, 04 Nov 2024 08:11:40 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.39 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:39 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Ronan Desplanques Subject: [COMMITTED 18/38] ada: Tweak CPU affinity handling Date: Mon, 4 Nov 2024 17:10:53 +0100 Message-ID: <20241104161116.1431659-18-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Ronan Desplanques The primary motivation for this change is making the taskset command line tool work as expected for tasking programs that don't use features from section D.16 of the Ada reference manual. A couple of components are added to the ATCB record to make it possible to tell values that come from explicit aspects and subprogram calls from values that are inherited from activating tasks. gcc/ada/ChangeLog: * libgnarl/s-mudido__affinity.adb (Unchecked_Set_Affinity): Set new ATCB component. * libgnarl/s-taprop__linux.adb (Create_Task): Only set CPU affinity when required. (Requires_Affinity_Change): New subprogram. (Set_Task_Affinity): Likewise. * libgnarl/s-tarest.adb (Create_Restricted_Task): Adapt to Initialize_ATCB change. * libgnarl/s-taskin.adb (Initialize_ATCB): Update parameter list. Record whether aspects were explicitly specified. * libgnarl/s-taskin.ads (Common_ATCB): Add component. * libgnarl/s-tassta.adb (Create_Task): Update call to Initialize_ATCB. * libgnarl/s-tporft.adb (Register_Foreign_Thread): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnarl/s-mudido__affinity.adb | 1 + gcc/ada/libgnarl/s-taprop__linux.adb | 27 +++++++++++++++++-- gcc/ada/libgnarl/s-tarest.adb | 3 ++- gcc/ada/libgnarl/s-taskin.adb | 12 +++++---- gcc/ada/libgnarl/s-taskin.ads | 36 ++++++++++++++++--------- gcc/ada/libgnarl/s-tassta.adb | 3 ++- gcc/ada/libgnarl/s-tporft.adb | 4 +-- 7 files changed, 63 insertions(+), 23 deletions(-) diff --git a/gcc/ada/libgnarl/s-mudido__affinity.adb b/gcc/ada/libgnarl/s-mudido__affinity.adb index ec8c8f6c19f..e9c17ef68b6 100644 --- a/gcc/ada/libgnarl/s-mudido__affinity.adb +++ b/gcc/ada/libgnarl/s-mudido__affinity.adb @@ -367,6 +367,7 @@ package body System.Multiprocessors.Dispatching_Domains is -- Attach the CPU to the task T.Common.Base_CPU := CPU; + T.Common.CPU_Is_Explicit := True; -- Change the number of tasks attached to a given task in the system -- domain if needed. diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index 0a51b3601c0..d9425e0d2fa 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -259,6 +259,11 @@ package body System.Task_Primitives.Operations is -- Initialize the lock L. If Ceiling_Support is True, then set the ceiling -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory. + function Requires_Affinity_Change + (Domain : Dispatching_Domain_Access) return Boolean; + -- Returns whether a call to pthread_setaffinity_np is required to assign a + -- task to Domain. + ------------------- -- Abort_Handler -- ------------------- @@ -521,6 +526,20 @@ package body System.Task_Primitives.Operations is Ceiling_Violation := Result = EINVAL; end Read_Lock; + ------------------------------ + -- Requires_Affinity_Change -- + ------------------------------ + + function Requires_Affinity_Change + (Domain : Dispatching_Domain_Access) return Boolean is + begin + return + Domain /= System_Domain + or else Domain.all + /= [Multiprocessors.CPU'First + .. Multiprocessors.Number_Of_CPUs => True]; + end Requires_Affinity_Change; + ------------ -- Unlock -- ------------ @@ -941,7 +960,9 @@ package body System.Task_Primitives.Operations is -- Support is available - elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then + elsif T.Common.CPU_Is_Explicit + and then T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU + then declare CPUs : constant size_t := C.size_t (Multiprocessors.Number_Of_CPUs); @@ -971,7 +992,7 @@ package body System.Task_Primitives.Operations is -- Handle dispatching domains - else + elsif Requires_Affinity_Change (T.Common.Domain) then declare CPUs : constant size_t := C.size_t (Multiprocessors.Number_Of_CPUs); @@ -1464,6 +1485,8 @@ package body System.Task_Primitives.Operations is if pthread_setaffinity_np'Address /= Null_Address and then T.Common.LL.Thread /= Null_Thread_Id + and then (T.Common.CPU_Is_Explicit + or else Requires_Affinity_Change (T.Common.Domain)) then declare CPUs : constant size_t := diff --git a/gcc/ada/libgnarl/s-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb index 5c2ee90e84b..df07869757f 100644 --- a/gcc/ada/libgnarl/s-tarest.adb +++ b/gcc/ada/libgnarl/s-tarest.adb @@ -514,7 +514,8 @@ package body System.Tasking.Restricted.Stages is Initialize_ATCB (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, - Base_CPU, null, Task_Info, Stack_Size, Created_Task, Success); + Base_CPU, CPU /= Unspecified_CPU, null, Task_Info, Stack_Size, + Created_Task, Success); -- If we do our job right then there should never be any failures, which -- was probably said about the Titanic; so just to be safe, let's retain diff --git a/gcc/ada/libgnarl/s-taskin.adb b/gcc/ada/libgnarl/s-taskin.adb index 95c95ed3110..9fade5dea92 100644 --- a/gcc/ada/libgnarl/s-taskin.adb +++ b/gcc/ada/libgnarl/s-taskin.adb @@ -89,12 +89,12 @@ package body System.Tasking is Elaborated : Access_Boolean; Base_Priority : System.Any_Priority; Base_CPU : System.Multiprocessors.CPU_Range; + CPU_Is_Explicit : Boolean; Domain : Dispatching_Domain_Access; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; T : Task_Id; - Success : out Boolean) - is + Success : out Boolean) is begin T.Common.State := Unactivated; @@ -110,9 +110,10 @@ package body System.Tasking is -- would be illegal, because Common_ATCB is limited because -- Task_Primitives.Private_Data is limited. - T.Common.Parent := Parent; - T.Common.Base_Priority := Base_Priority; - T.Common.Base_CPU := Base_CPU; + T.Common.Parent := Parent; + T.Common.Base_Priority := Base_Priority; + T.Common.CPU_Is_Explicit := CPU_Is_Explicit; + T.Common.Base_CPU := Base_CPU; -- The Domain defaults to that of the activator. But that can be null in -- the case of foreign threads (see Register_Foreign_Thread), in which @@ -235,6 +236,7 @@ package body System.Tasking is Elaborated => null, Base_Priority => Base_Priority, Base_CPU => Base_CPU, + CPU_Is_Explicit => Main_CPU /= Unspecified_CPU, Domain => System_Domain, Task_Info => Task_Info.Unspecified_Task_Info, Stack_Size => 0, diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads index 1bae7e114cf..77851633181 100644 --- a/gcc/ada/libgnarl/s-taskin.ads +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -518,6 +518,17 @@ package System.Tasking is -- -- Protection: Only written by Self, accessed by anyone + CPU_Is_Explicit : Boolean; + -- True if the task is either assigned to a CPU or explicitly not + -- assigned to a CPU through Not_A_Specific_CPU being used with the CPU + -- Aspect a subprogram in System.Multiprocessors.Dispatching_Domains. + -- False otherwise. + -- We keep track of this information to make it possible to accomodate + -- native affinity inheritance on some platforms when no RM D.16 + -- features are used. An example of such a platform is Linux, where we + -- strive to make the taskset command line tool have the expected effect + -- when the program does not use RM D.16 features. + Base_CPU : System.Multiprocessors.CPU_Range; -- Base CPU, only changed via dispatching domains package. -- @@ -1184,18 +1195,19 @@ package System.Tasking is -- System.Tasking.Initialization being present, as was done before. procedure Initialize_ATCB - (Self_ID : Task_Id; - Task_Entry_Point : Task_Procedure_Access; - Task_Arg : System.Address; - Parent : Task_Id; - Elaborated : Access_Boolean; - Base_Priority : System.Any_Priority; - Base_CPU : System.Multiprocessors.CPU_Range; - Domain : Dispatching_Domain_Access; - Task_Info : System.Task_Info.Task_Info_Type; - Stack_Size : System.Parameters.Size_Type; - T : Task_Id; - Success : out Boolean); + (Self_ID : Task_Id; + Task_Entry_Point : Task_Procedure_Access; + Task_Arg : System.Address; + Parent : Task_Id; + Elaborated : Access_Boolean; + Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + CPU_Is_Explicit : Boolean; + Domain : Dispatching_Domain_Access; + Task_Info : System.Task_Info.Task_Info_Type; + Stack_Size : System.Parameters.Size_Type; + T : Task_Id; + Success : out Boolean); -- Initialize fields of the TCB for task T, and link into global TCB -- structures. Call this only with abort deferred and holding RTS_Lock. -- Self_ID is the calling task (normally the activator of T). Success is diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb index 594a1672866..65e950af655 100644 --- a/gcc/ada/libgnarl/s-tassta.adb +++ b/gcc/ada/libgnarl/s-tassta.adb @@ -584,7 +584,8 @@ package body System.Tasking.Stages is end if; Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, - Base_Priority, Base_CPU, Domain, Task_Info, Stack_Size, T, Success); + Base_Priority, Base_CPU, CPU /= Unspecified_CPU, Domain, Task_Info, + Stack_Size, T, Success); if not Success then Free (T); diff --git a/gcc/ada/libgnarl/s-tporft.adb b/gcc/ada/libgnarl/s-tporft.adb index 66a9f02656e..a1570321f06 100644 --- a/gcc/ada/libgnarl/s-tporft.adb +++ b/gcc/ada/libgnarl/s-tporft.adb @@ -66,8 +66,8 @@ begin System.Tasking.Initialize_ATCB (Self_Id, null, Null_Address, Null_Task, Foreign_Task_Elaborated'Access, - System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, null, - Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded); + System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, False, + null, Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded); Unlock_RTS; pragma Assert (Succeeded); From patchwork Mon Nov 4 16:10:54 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: 2006317 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=W1SrbqJq; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxTR4zLkz1xxW for ; Tue, 5 Nov 2024 03:18:02 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 3079D385773C for ; Mon, 4 Nov 2024 16:18:00 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32b.google.com (mail-wm1-x32b.google.com [IPv6:2a00:1450:4864:20::32b]) by sourceware.org (Postfix) with ESMTPS id 843B63857354 for ; Mon, 4 Nov 2024 16:11:42 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 843B63857354 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 843B63857354 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::32b ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736731; cv=none; b=d4GkVNeFgTRR4oa3/dLAxCO47tshBq80Ps/p24IXlHZlWJauCI7GtBndK486ZasBVB8Tb/w30aLqhtMSSZt1IUdYqD6MEHmQmFKv8EWSuRkkTS80Z35R2LLDmtEFjsSvL82K+ULZ8MG7XI25YSkFp9OeGIBbMSNT70NkqtO9nrw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736731; c=relaxed/simple; bh=Ga/LDh/v4lZeLK1vYOn0VRjfRe5VpMgPg9mBjKAa0jc=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=CdNfStjxNVcpkY4cL3LCXfpjn9kexdclMHryvMq4Wxw2Yw4AF7qsFVbwXBn/VnWOYb8smuig20XRFZLZ0z5U4B0YEo3pS2yDQLirhWp0LzEslETPCOpPjnZYNgI0c0KXWaNmXGCEhw8tzt9QOsWwrpifRMkWfYC2Ssu7SbPJVW8= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32b.google.com with SMTP id 5b1f17b1804b1-4315baa51d8so39146335e9.0 for ; Mon, 04 Nov 2024 08:11:42 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736701; x=1731341501; 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=z7XvftgnFtxCoFVegtlTP+Bp/yOMbiqBEvuIelQ/0cU=; b=W1SrbqJqMygqYIr+ygWEAppLgmTDHYVRT8mAstcvq5pOkcH/ASOEkIzYu7WHQBRivV hu0n+XSruDNXE4wyoq8k75VKNJ5UkzAYdfA0h1OK+Zim7o5PiTvhJaL0oniI6ebLtg1e oARbfRUGr2kzbU0B67DEOXJn++VUo+s/cx1TQmYpzbCmM/LEYQlnU2zMWltJUsIrz7NR 5x87iIKLlK+Fv2NpMlk0go2mjIwDA3Qa65AuzFGss7MONisX4HzC41BknEtBeVvzZ3il q8qWtEQaRVVLgyjUOXNaTrgXxOZ5EViQXmszAhK0kRUu259AK2D1u4GcJBMhCBT8vKaS bPlw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736701; x=1731341501; 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=z7XvftgnFtxCoFVegtlTP+Bp/yOMbiqBEvuIelQ/0cU=; b=v+KnvtltHQRWXkTYcujE+TV3REe2ZnUzvaKWwiCeIPOj4bdLCjnDs65Gm7RaVPR8wM qXmTd/u/uBQ/Zb4pXTZ7DGNSFQ4dmqmelzPmAx0qMzFiT1hrnYWMtCCtNqmlJXSoPNPj 3/p/eh63xRYDQu13J/Xxg0xjYHUoJVFU+TtIkDaZc8tjh6hg9BJm5TEcYQ4+opcJBYdH zRi4YTnX2dJVlWn0FwCMN92f+l0OSlPrkjaPLajhywlxrPQn3uu5+p8lC8/U53Rnx5um AsE4SRRR2PJBQg5HnbWMUSkbJ0rmqKHra3A4DM8Sf2mWNwlWLOXat28mbip0v6QHNnfn NsLw== X-Gm-Message-State: AOJu0YxgLHHzZK1wc/Yq3sqg3PHXh27e2wgl8gm2cFRl8J9rLj/Kxfgz yyCVOj7xti8U02hdkDciGHRamhmAnftrjyc+OoLSLQC3RPl56tpaNyh+kgDYm38EpTeGmW7ROLg = X-Google-Smtp-Source: AGHT+IHq+LnTPEl/1VA6zBjcnbdY7xB6EPqGQp7+tS8YOKScy1KJ/k+CZqfcLFl3/JonAVPwQkXUXQ== X-Received: by 2002:a7b:c848:0:b0:431:53db:3d29 with SMTP id 5b1f17b1804b1-4327b7019f5mr146745375e9.18.1730736701111; Mon, 04 Nov 2024 08:11:41 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.40 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:40 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Viljar Indus Subject: [COMMITTED 19/38] ada: Add Schema to the SARIF report Date: Mon, 4 Nov 2024 17:10:54 +0100 Message-ID: <20241104161116.1431659-19-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Viljar Indus gcc/ada/ChangeLog: * diagnostics-sarif_emitter.adb (Print_SARIF_Report): Add a Schema field to the SARIF report. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/diagnostics-sarif_emitter.adb | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/diagnostics-sarif_emitter.adb index cbb423b2e1d..fe251f9754d 100644 --- a/gcc/ada/diagnostics-sarif_emitter.adb +++ b/gcc/ada/diagnostics-sarif_emitter.adb @@ -31,6 +31,14 @@ with Sinput; use Sinput; package body Diagnostics.SARIF_Emitter is + -- We are currently using SARIF 2.1.0 + + SARIF_Version : constant String := "2.1.0"; + pragma Style_Checks ("M100"); + SARIF_Schema : constant String := + "https://docs.oasis-open.org/sarif/sarif/v2.1.0/errata01/os/schemas/sarif-schema-2.1.0.json"; + pragma Style_Checks ("M79"); + type Artifact_Change is record File : String_Ptr; -- Name of the file @@ -1074,7 +1082,11 @@ package body Diagnostics.SARIF_Emitter is Begin_Block; NL_And_Indent; - Write_String_Attribute ("version", "2.1.0"); + Write_String_Attribute ("$schema", SARIF_Schema); + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute ("version", SARIF_Version); Write_Char (','); NL_And_Indent; From patchwork Mon Nov 4 16:10:55 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: 2006303 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=YAzV6xJX; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxQ42WDyz1xyD for ; Tue, 5 Nov 2024 03:15:08 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 833F53857022 for ; Mon, 4 Nov 2024 16:15:06 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x436.google.com (mail-wr1-x436.google.com [IPv6:2a00:1450:4864:20::436]) by sourceware.org (Postfix) with ESMTPS id 3E7E03857011 for ; Mon, 4 Nov 2024 16:11:43 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 3E7E03857011 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 3E7E03857011 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::436 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736731; cv=none; b=Jfi0/BtM4kuo+gtU4nFBnL0cEy5Paq2g4Wlyqb3DokcF1TojJ2+fxE82KuYtkxgBAqS/nYIaf0BdfS2DV39iAi/o/KPzSIH/ok5nJ/0hol1EipCRyJQTY24z1hTt31MltWfevbU0jfzn8lsy5X+mgi5K55Y7kRWUTPHg8VxNFCY= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736731; c=relaxed/simple; bh=oXf+GnLlYofE/WO0/croihESWJxLtalE4MARkCFmfkg=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=dybFV80ZUCPLnMDwz2Qy7NCGeuL5t5PpNlciMv35BfGOyxnbM7M2INg1G/1ezoUGnTeUAvLIFbXxeKLBcSAo2qtzWYwn+znjFAS3Ar4rjA73/BS77cQs3++8g/2rO9u2QCria3kl0TnEbCQHSegcFRWjsyg0xkpP59y8Q3DhnuU= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x436.google.com with SMTP id ffacd0b85a97d-37f52925fc8so2734242f8f.1 for ; Mon, 04 Nov 2024 08:11:43 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736702; x=1731341502; 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=U1eTBVzRsNW1mUdALK/4eKF9eZ20cddkQ0pDverAmWg=; b=YAzV6xJX5lfoZcVVxWcjNuxdn8NtWctsfj+Zv4iZDce7T+TCKpk+GL3PArxmiwNL/Z Wa9E7gYhOz7LEc5sPxK3XfQjHAtiSd8vlGv26nzVEUGDkZTgznZlMapR5uyypHEDX3md bclGFB83o20pVy4C2ISKkgPKJ2oc2ecvYiSHucUoDyeWECffPFyLMzy1CAIy0BJYHSPZ ocp/4Pgu1Ix8A5BmJi2HQ/CI3uzMX3Ydwk0Y2z3+/RcoK+h6hLl3TXJrDp0xbX99oxOJ twb257o7oSu/TIbElJiiF5biqU+5qX6msohbIowKZN/rSHs0827AlfFoOofeFt+sS2C/ QjGw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736702; x=1731341502; 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=U1eTBVzRsNW1mUdALK/4eKF9eZ20cddkQ0pDverAmWg=; b=oROTIUA1M/aV4ekO9U5tRfrH8LBMfWNCAmLSNmDPH/hEK9Wnv/aOngF7WcidjpIp5J UUfS9xo/C+A90Xk+zRNi8/i+h2J0Ow71INj+vJzzs8QGr3Rq8IhhIU8XiE+dyqWEA0UY RU1KoqW5hvX7gisE6x27vulZ1nnxZFhWA0RiRpEWTVfkucscumWWcysBZbJAzgJYPKNR aEy88xBn2u5wN4+p4GMWnAdnEEk6LsBiSnIkkCPQMmbFDt6ijcSxLqG1gGMkDj/xbFMG ERoHWPqCq2+oB43qpv2Yz/nu95QeWvUppEqs9T/vZ1pRkoYuiMPNSaI/sPaBAd4buyS9 pJdA== X-Gm-Message-State: AOJu0Ywv2+l7/ipya7GY3625Q9rHyvTJA3WwKfbBm4UYhI09iz+WKs+m VYknEIR8YGLRPueczm/JQ+AfHja5Qy06AO/00PdPsmCXrwE/SRKDHqgQ1sXm1rns0vbk7vl5AUo = X-Google-Smtp-Source: AGHT+IGc4ahvr4ne1nAEgzWHUWN6CVouLA/IrRNyAICaUS0eXDENRtXH3rKTE8bBBTvMQi7iGtjLDA== X-Received: by 2002:a05:6000:1a8a:b0:37d:4a7b:eeb2 with SMTP id ffacd0b85a97d-381c7a6d600mr9789310f8f.35.1730736701897; Mon, 04 Nov 2024 08:11:41 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.41 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:41 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Viljar Indus Subject: [COMMITTED 20/38] ada: Add Invocation node to the SARIF report Date: Mon, 4 Nov 2024 17:10:55 +0100 Message-ID: <20241104161116.1431659-20-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Viljar Indus Add an invocation node to the SARIF report that contains the command line use to activate gnat and whether the execution was successful or not. gcc/ada/ChangeLog: * diagnostics-sarif_emitter.adb (Print_Runs): Add printing for the invocation node that consists of a single invocations that is composed of the commandLine and executionSuccessful attributes. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/diagnostics-sarif_emitter.adb | 81 ++++++++++++++++++++++++++- 1 file changed, 80 insertions(+), 1 deletion(-) diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/diagnostics-sarif_emitter.adb index fe251f9754d..b6035c2970d 100644 --- a/gcc/ada/diagnostics-sarif_emitter.adb +++ b/gcc/ada/diagnostics-sarif_emitter.adb @@ -28,6 +28,10 @@ with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; with Gnatvsn; use Gnatvsn; with Output; use Output; with Sinput; use Sinput; +with Lib; use Lib; +with Namet; use Namet; +with Osint; use Osint; +with Errout; use Errout; package body Diagnostics.SARIF_Emitter is @@ -94,6 +98,19 @@ package body Diagnostics.SARIF_Emitter is -- ... -- ] + procedure Print_Invocations; + -- Print an invocations node that consists of + -- * a single invocation node that consists of: + -- * commandLine + -- * executionSuccessful + -- + -- "invocations": [ + -- { + -- "commandLine": , + -- "executionSuccessful": ["true"|"false"], + -- } + -- ] + procedure Print_Artifact_Change (A : Artifact_Change); -- Print an ArtifactChange node -- @@ -573,6 +590,63 @@ package body Diagnostics.SARIF_Emitter is Write_Char (']'); end Print_Fixes; + ----------------------- + -- Print_Invocations -- + ----------------------- + + procedure Print_Invocations is + + function Compose_Command_Line return String; + -- Composes the original command line from the parsed main file name and + -- relevant compilation switches + + function Compose_Command_Line return String is + Buffer : Bounded_String; + begin + Append (Buffer, Get_First_Main_File_Name); + for I in 1 .. Compilation_Switches_Last loop + declare + Switch : constant String := Get_Compilation_Switch (I).all; + begin + if Buffer.Length + Switch'Length + 1 <= Buffer.Max_Length then + Append (Buffer, ' ' & Switch); + end if; + end; + end loop; + + return +Buffer; + end Compose_Command_Line; + + begin + Write_Str ("""" & "invocations" & """" & ": " & "["); + Begin_Block; + NL_And_Indent; + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print commandLine + + Write_String_Attribute ("commandLine", Compose_Command_Line); + Write_Char (','); + NL_And_Indent; + + -- Print executionSuccessful + + Write_String_Attribute + ("executionSuccessful", + (if Compilation_Errors then "false" else "true")); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + End_Block; + NL_And_Indent; + Write_Char (']'); + end Print_Invocations; + ------------------ -- Print_Region -- ------------------ @@ -1052,6 +1126,12 @@ package body Diagnostics.SARIF_Emitter is Write_Char (','); NL_And_Indent; + -- A run consists of an invocation + Print_Invocations; + + Write_Char (','); + NL_And_Indent; + -- A run consists of results Print_Results (Diags); @@ -1076,7 +1156,6 @@ package body Diagnostics.SARIF_Emitter is ------------------------ procedure Print_SARIF_Report (Diags : Diagnostic_List) is - begin Write_Char ('{'); Begin_Block; From patchwork Mon Nov 4 16:10:56 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: 2006311 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=cQXQVbYW; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxRv4JtPz1xxW for ; Tue, 5 Nov 2024 03:16:43 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2F886385696A for ; Mon, 4 Nov 2024 16:16:40 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x434.google.com (mail-wr1-x434.google.com [IPv6:2a00:1450:4864:20::434]) by sourceware.org (Postfix) with ESMTPS id 018083857835 for ; Mon, 4 Nov 2024 16:11:44 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 018083857835 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 018083857835 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::434 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736725; cv=none; b=FP9G16pICD4Y670RqfXgSKipxrbzKyS7cmDvzF/tlZ6kZ4sZOjjVrDegBIqJEuye8wLk8jge7zLoy9vb4ySDNBAefuDQDq2l2IwT817LWGU1qPMtLGEINNSPoDw8PGOM2+8yh9WHXYrgq6yMFySJTm/+S8xiPrumcBwm4ODY5/Y= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736725; c=relaxed/simple; bh=+VJLK7Q2NFtIiHh1MFFsVICXnCAdDO5Qq4nbzKMrfDs=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=mKQgE9AFamsuFj6lanwuHfLTUkj1mMqZxTNKpl0SzLJlmLeJruBumA6x3HlIi5zau+EoTYURA4VLCqfF2h+MLLGG4Az3FZOZvWo52cdYIr3zd+gcZWK4HbwC9b/RAT33a57qE3WFD0sqjnpCsDf+N6tW9s1QGKErO1+FmVEIhAY= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x434.google.com with SMTP id ffacd0b85a97d-37d41894a32so2443383f8f.1 for ; Mon, 04 Nov 2024 08:11:43 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736703; x=1731341503; 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=tID+0xDIgS61USS4ix3W7v+7xN1uNzyO0QiaJ4NjyiE=; b=cQXQVbYWi1XwLZAxU/Pb/cJHod8V7neEwdoDf54YDGIz/MH0xbMVbyOswCzfLdldG6 RtDb6t4caZRpscJDn5GriZg7jmvDT23PYPT+HU/n5Shtm0kKEDS6AbosWKXZgpi9H1Hi LfcQnlK9Nv944RAAoRsBMd3bg7HSOUgAxlcOiVa2qBACm6rf7zSakoveqhMtpDhGKsxz 68TMsUw6lKhitYF7dsDPQM/Ed9wyj7dJP3+91OIVsGE2qSkYWd4M72Iq8S9iQTPY9vdL eICXleOC2f03u33h9wDjG4sZv0ejqTx0/kiTuziOjBgsv1HoBtZPHp+gRXbMU5QlAgSi un5A== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736703; x=1731341503; 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=tID+0xDIgS61USS4ix3W7v+7xN1uNzyO0QiaJ4NjyiE=; b=ufPr2bmXUu7Ia1lWLDvUjRDptnowBitnykiIL3D6VuoivIQxlnRQq9niXvAXJyi7vb R0I7mlVOgW4J68HAuT11kEGkQsOWznSw18r69Tl4haRH8X7M7VYN7oDKOg7pdLHBh6XL gEtPpyZB0baeM/jktBRuNqtAi7V1F0pqWxdEwYEWRxNm2m9xnjWEM8vEaaTg2VMb2RgS nv9746Fp+2/DHT7tUm9zGbL0+7xmX4tJlq4NdgQreh0UDDCswqCUCCsDzSPRdpeVd2rF XmW7LVkkCGzIjz9/oyPMyty6btX50WTOqPTrL3VD6tun4ljPQXd5CJfe0XvwGHtZvkWB qbAQ== X-Gm-Message-State: AOJu0YzlXigUx6FW4mB8938DFqXhfq61VssqAsEhaKIFwOkkQaq2HnZe d0xAvI2GMokdnz/B7dBYJccz7HgUs59bZW0AdrEWfyAX7GdPhmA+sa3819yZxrtSczeyfmi+0L0 = X-Google-Smtp-Source: AGHT+IHRkx6zDjFrLrQyXp4RaI3ymW/pD4Sl81U5RWVNVlo1R3uSn9yS8LTd6nYu9Kc+MWT0Q8wpGA== X-Received: by 2002:a5d:64c5:0:b0:374:c1ea:2d40 with SMTP id ffacd0b85a97d-381c7967671mr10675297f8f.1.1730736702643; Mon, 04 Nov 2024 08:11:42 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.42 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:42 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Daniel King Subject: [COMMITTED 21/38] ada: CheriBSD: add SIGPROT handler Date: Mon, 4 Nov 2024 17:10:56 +0100 Message-ID: <20241104161116.1431659-21-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Daniel King gcc/ada/ChangeLog: * libgnarl/s-intman__cheribsd.adb: Add SIGPROT to interrupt list. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnarl/s-intman__cheribsd.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/libgnarl/s-intman__cheribsd.adb b/gcc/ada/libgnarl/s-intman__cheribsd.adb index 3b5f16d01c5..c6d7d0b0a54 100644 --- a/gcc/ada/libgnarl/s-intman__cheribsd.adb +++ b/gcc/ada/libgnarl/s-intman__cheribsd.adb @@ -68,7 +68,7 @@ package body System.Interrupt_Management is type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; Exception_Interrupts : constant Interrupt_List := - [SIGFPE, SIGILL, SIGSEGV, SIGBUS]; + [SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGPROT]; Unreserve_All_Interrupts : constant Interfaces.C.int; pragma Import From patchwork Mon Nov 4 16:10:57 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: 2006322 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=QE7XU7U+; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxVc5G26z1xxW for ; Tue, 5 Nov 2024 03:19:04 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C3D0C385AC1D for ; Mon, 4 Nov 2024 16:19:00 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x332.google.com (mail-wm1-x332.google.com [IPv6:2a00:1450:4864:20::332]) by sourceware.org (Postfix) with ESMTPS id 28A60385770E for ; Mon, 4 Nov 2024 16:11:45 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 28A60385770E 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 28A60385770E Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::332 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736736; cv=none; b=sTAzU1TuRgVWbL8//AOEWFZnTb+2L9rkb0S2+qvFD8oUadKZGP2sZJbPw3wbBTKaTlvksJo0oFZNereWQTRxccot5jJwQe+3ugOZ7IC6hjVvzzLTBWXxwgVCUgxrIHeSvR+xQk7vTV+IprW6yVYQZbgSASo/L6WK6Kzb/LYR+UM= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736736; c=relaxed/simple; bh=3QADR0+Ui736DBcJ8hZEjwideyHeVzG4T/ixUIjipNA=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=QRwk0YhSCUUf4Acze4JxG0CysN6UXT4yNw/gOw159669E5HyGrFxIeG9HzE4A5eLws0GA9mNuo1P3jetnpYpK3anZ3xG0nmJH6dX1+TLl6JR0mXnGPNsneq6MB9+EgnSf7dghpO0xGajl5hiLQD0Njdc7+WTvagwi5cGpdU8nek= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x332.google.com with SMTP id 5b1f17b1804b1-4315e62afe0so38448615e9.1 for ; Mon, 04 Nov 2024 08:11:45 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736704; x=1731341504; 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=4MYXYzRsR5YhHX2Z9Blbp7Hpj+pYqO6+OvRdjRDGPbM=; b=QE7XU7U+6wyHmiUSxZNfJ3piqbtX7GDbS/CTMJ/RLmUECx4qLwnUCQFK0wuVdgLyRo Wg39bL8pgFGCyGPAWjN4taESFwd3zkONE/px783Ur2mB9XNhg0VKDw9Pyk3/k2oLv+Yc iOt3cqneO5bD+t7t67B834TxSUHjce3KMHzpmJP1G6Sk/P2qLR8BahZsLlPb61r81CRv 10NH/brww1j9Ula4+3mZmVUSVAFGgVEXRligkuLkarKeIyljSMVpiYHrtAW0t6pHSRwZ A/fVMI0m5D7rrbI2REoSFcJA37iXwyDYV1fXTC9V9zSHIIRFeajDlopDYQRzxtpLWztw MxOA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736704; x=1731341504; 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=4MYXYzRsR5YhHX2Z9Blbp7Hpj+pYqO6+OvRdjRDGPbM=; b=qVOvHioklC5nmSwT6+aZtjul7ByJal5465nEhaBHerkd+GHjAzkrIp72WHdfePEUla ZVgDH2DwuSW2d6sZRPmWTCkCCuA97OuiDHoLSXN5F2VTQKxagkzNRU+A1q8XGHrt67Ie 1g2eTfm71h0uhAZhdCZSYLR5TmrJuSqeI4oRyUuV0v3PuX1y8Ywh9HjG4fv2iWDNLgta LFPG5Mt6LTqPJeQtrgvATWDwDkBqHIbPv7Q2VEHIKCM0UBAFUX23g40I05sziqQs6xCf UQtVTKqfYEXrk+DfwlwvgChrZ/YWt2WmxU3NxY6FaQjqJ43qGjcSvElohYmVYyY5bm2o QUUg== X-Gm-Message-State: AOJu0Yxyc/EbnxeM9xU1iEiHtR8kYZrRmE1BBCSCf4QPyAf0LHv+7gmO JcRp57imeaYIVXesHs7efCEFlf2dsFO44ygwvOKwtlAZy8bNH6LODNeAnrb88NJPcImpeaysUnU = X-Google-Smtp-Source: AGHT+IEhSaNlW18VegjWqkyAldtmXm3NDDtN/CXyTbxK6yB/GwGuldJG+BIgrwPrrHY07NCkhK15ZA== X-Received: by 2002:a05:6000:1868:b0:381:d014:9bdd with SMTP id ffacd0b85a97d-381d0149e9emr7087104f8f.23.1730736703467; Mon, 04 Nov 2024 08:11:43 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.42 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:42 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Daniel King Subject: [COMMITTED 22/38] ada: Add CHERI variant of full secondary stack allocator Date: Mon, 4 Nov 2024 17:10:57 +0100 Message-ID: <20241104161116.1431659-22-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Daniel King gcc/ada/ChangeLog: * Makefile.rtl: Use s-secsta__cheri.adb on Morello CheriBSD. * libgnat/s-secsta__cheri.adb: New file. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 3 +- gcc/ada/libgnat/s-secsta__cheri.adb | 1085 +++++++++++++++++++++++++++ 2 files changed, 1087 insertions(+), 1 deletion(-) create mode 100644 gcc/ada/libgnat/s-secsta__cheri.adb diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 904ec34026f..4d32bc47185 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1805,7 +1805,8 @@ ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),) ifneq (,$(findstring morello,$(target_alias))) LIBGNAT_TARGET_PAIRS += \ s-intman.adb. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with Interfaces.CHERI; use Interfaces.CHERI; +with System.Parameters; use System.Parameters; +with System.Soft_Links; use System.Soft_Links; +with System.Storage_Elements; use System.Storage_Elements; + +package body System.Secondary_Stack is + + ------------------------------------ + -- Binder Allocated Stack Support -- + ------------------------------------ + + -- When at least one of the following restrictions + -- + -- No_Implicit_Heap_Allocations + -- No_Implicit_Task_Allocations + -- + -- is in effect, the binder creates a static secondary stack pool, where + -- each stack has a default size. Assignment of these stacks to tasks is + -- performed by SS_Init. The following variables are defined in this unit + -- in order to avoid depending on the binder. Their values are set by the + -- binder. + + Binder_SS_Count : Natural := 0; + pragma Export (Ada, Binder_SS_Count, "__gnat_binder_ss_count"); + -- The number of secondary stacks in the pool created by the binder + + Binder_Default_SS_Size : Size_Type; + pragma Export (Ada, Binder_Default_SS_Size, "__gnat_default_ss_size"); + -- The default secondary stack size as specified by the binder. The value + -- is defined here rather than in init.c or System.Init because the ZFP and + -- Ravenscar-ZFP run-times lack these locations. + + Binder_Default_SS_Pool : Address; + pragma Export (Ada, Binder_Default_SS_Pool, "__gnat_default_ss_pool"); + -- The address of the secondary stack pool created by the binder + + Binder_Default_SS_Pool_Index : Natural := 0; + -- Index into the secondary stack pool created by the binder + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Allocate_Dynamic + (Stack : SS_Stack_Ptr; + Mem_Size : Memory_Size; + Addr : out Address); + pragma Inline (Allocate_Dynamic); + -- Allocate enough space on dynamic secondary stack Stack to fit a request + -- of size Mem_Size. Addr denotes the address of the first byte of the + -- allocation. + + procedure Allocate_On_Chunk + (Stack : SS_Stack_Ptr; + Prev_Chunk : SS_Chunk_Ptr; + Chunk : SS_Chunk_Ptr; + Byte : Memory_Index; + Mem_Size : Memory_Size; + Addr : out Address); + pragma Inline (Allocate_On_Chunk); + -- Allocate enough space on chunk Chunk to fit a request of size Mem_Size. + -- Stack is the owner of the allocation Chunk. Prev_Chunk is the preceding + -- chunk of Chunk. Byte indicates the first free byte within Chunk. Addr + -- denotes the address of the first byte of the allocation. This routine + -- updates the state of Stack.all to reflect the side effects of the + -- allocation. + + procedure Allocate_Static + (Stack : SS_Stack_Ptr; + Mem_Size : Memory_Size; + Addr : out Address); + pragma Inline (Allocate_Static); + -- Allocate enough space on static secondary stack Stack to fit a request + -- of size Mem_Size. Addr denotes the address of the first byte of the + -- allocation. + + procedure Free is new Ada.Unchecked_Deallocation (SS_Chunk, SS_Chunk_Ptr); + -- Free a dynamically allocated chunk + + procedure Free is new Ada.Unchecked_Deallocation (SS_Stack, SS_Stack_Ptr); + -- Free a dynamically allocated secondary stack + + function Has_Enough_Free_Memory + (Chunk : SS_Chunk_Ptr; + Byte : Memory_Index; + Mem_Size : Memory_Size) return Boolean; + pragma Inline (Has_Enough_Free_Memory); + -- Determine whether chunk Chunk has enough room to fit a memory request of + -- size Mem_Size, starting from the first free byte of the chunk denoted by + -- Byte. + + function Number_Of_Chunks (Stack : SS_Stack_Ptr) return Chunk_Count; + pragma Inline (Number_Of_Chunks); + -- Count the number of static and dynamic chunks of secondary stack Stack + + function Size_Up_To_And_Including (Chunk : SS_Chunk_Ptr) return Memory_Size; + pragma Inline (Size_Up_To_And_Including); + -- Calculate the size of secondary stack which houses chunk Chunk, from the + -- start of the secondary stack up to and including Chunk itself. The size + -- includes the following kinds of memory: + -- + -- * Free memory in used chunks due to alignment holes + -- * Occupied memory by allocations + -- + -- This is a constant time operation, regardless of the secondary stack's + -- nature. + + function Top_Chunk_Id (Stack : SS_Stack_Ptr) return Chunk_Id_With_Invalid; + pragma Inline (Top_Chunk_Id); + -- Obtain the Chunk_Id of the chunk indicated by secondary stack Stack's + -- pointer. + + function Used_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size; + pragma Inline (Used_Memory_Size); + -- Calculate the size of stack Stack's occupied memory usage. This includes + -- the following kinds of memory: + -- + -- * Free memory in used chunks due to alignment holes + -- * Occupied memory by allocations + -- + -- This is a constant time operation, regardless of the secondary stack's + -- nature. + + function Padding_For_Bounds_Alignment + (Ptr : Address; + Size : Memory_Size) + return Memory_Size; + pragma Inline (Padding_For_Bounds_Alignment); + -- Calculate the amount of padding needed to align an address up to the + -- next representable boundary. + + ---------------------- + -- Allocate_Dynamic -- + ---------------------- + + procedure Allocate_Dynamic + (Stack : SS_Stack_Ptr; + Mem_Size : Memory_Size; + Addr : out Address) + is + function Allocate_New_Chunk return SS_Chunk_Ptr; + pragma Inline (Allocate_New_Chunk); + -- Create a new chunk which is big enough to fit a request of size + -- Mem_Size. + + ------------------------ + -- Allocate_New_Chunk -- + ------------------------ + + function Allocate_New_Chunk return SS_Chunk_Ptr is + Chunk_Size : Memory_Size; + + begin + -- The size of the new chunk must fit the memory request precisely. + -- In the case where the memory request is way too small, use the + -- default chunk size. This avoids creating multiple tiny chunks. + + Chunk_Size := Mem_Size; + + if Chunk_Size < Stack.Default_Chunk_Size then + Chunk_Size := Stack.Default_Chunk_Size; + end if; + + return new SS_Chunk (Chunk_Size); + + -- The creation of the new chunk may exhaust the heap. Raise a new + -- Storage_Error to indicate that the secondary stack is exhausted + -- as well. + + exception + when Storage_Error => + raise Storage_Error with "secondary stack exhausted"; + end Allocate_New_Chunk; + + -- Local variables + + Next_Chunk : SS_Chunk_Ptr; + + -- Start of processing for Allocate_Dynamic + + begin + -- Determine whether the chunk indicated by the stack pointer is big + -- enough to fit the memory request and if it is, allocate on it. + + if Has_Enough_Free_Memory + (Chunk => Stack.Top.Chunk, + Byte => Stack.Top.Byte, + Mem_Size => Mem_Size) + then + Allocate_On_Chunk + (Stack => Stack, + Prev_Chunk => null, + Chunk => Stack.Top.Chunk, + Byte => Stack.Top.Byte, + Mem_Size => Mem_Size, + Addr => Addr); + + return; + end if; + + -- At this point it is known that the chunk indicated by the stack + -- pointer is not big enough to fit the memory request. Examine all + -- subsequent chunks, and apply the following criteria: + -- + -- * If the current chunk is too small, free it + -- + -- * If the current chunk is big enough, allocate on it + -- + -- This ensures that no space is wasted. The process is costly, however + -- allocation is costly in general. Paying the price here keeps routines + -- SS_Mark and SS_Release cheap. + + while Stack.Top.Chunk.Next /= null loop + + -- The current chunk is big enough to fit the memory request, + -- allocate on it. + + if Has_Enough_Free_Memory + (Chunk => Stack.Top.Chunk.Next, + Byte => Stack.Top.Chunk.Next.Memory'First, + Mem_Size => Mem_Size) + then + Allocate_On_Chunk + (Stack => Stack, + Prev_Chunk => Stack.Top.Chunk, + Chunk => Stack.Top.Chunk.Next, + Byte => Stack.Top.Chunk.Next.Memory'First, + Mem_Size => Mem_Size, + Addr => Addr); + + return; + + -- Otherwise the chunk is too small, free it + + else + Next_Chunk := Stack.Top.Chunk.Next.Next; + + -- Unchain the chunk from the stack. This keeps the next candidate + -- chunk situated immediately after Top.Chunk. + -- + -- Top.Chunk Top.Chunk.Next Top.Chunk.Next.Next + -- | | (Next_Chunk) + -- v v v + -- +-------+ +------------+ +--------------+ + -- | | --> | | --> | | + -- +-------+ +------------+ +--------------+ + -- to be freed + + Free (Stack.Top.Chunk.Next); + Stack.Top.Chunk.Next := Next_Chunk; + end if; + end loop; + + -- At this point one of the following outcomes took place: + -- + -- * Top.Chunk is the last chunk in the stack + -- + -- * Top.Chunk was not the last chunk originally. It was followed by + -- chunks which were too small and as a result were deleted, thus + -- making Top.Chunk the last chunk in the stack. + -- + -- Either way, nothing should be hanging off the chunk indicated by the + -- stack pointer. + + pragma Assert (Stack.Top.Chunk.Next = null); + + -- Create a new chunk big enough to fit the memory request, and allocate + -- on it. + + Stack.Top.Chunk.Next := Allocate_New_Chunk; + + Allocate_On_Chunk + (Stack => Stack, + Prev_Chunk => Stack.Top.Chunk, + Chunk => Stack.Top.Chunk.Next, + Byte => Stack.Top.Chunk.Next.Memory'First, + Mem_Size => Mem_Size, + Addr => Addr); + end Allocate_Dynamic; + + ----------------------- + -- Allocate_On_Chunk -- + ----------------------- + + procedure Allocate_On_Chunk + (Stack : SS_Stack_Ptr; + Prev_Chunk : SS_Chunk_Ptr; + Chunk : SS_Chunk_Ptr; + Byte : Memory_Index; + Mem_Size : Memory_Size; + Addr : out Address) + is + New_High_Water_Mark : Memory_Size; + Padding : Memory_Size; + + begin + -- The allocation occurs on a reused or a brand new chunk. Such a chunk + -- must always be connected to some previous chunk. + + if Prev_Chunk /= null then + pragma Assert (Prev_Chunk.Next = Chunk); + + -- Update the Size_Up_To_Chunk because this value is invalidated for + -- reused and new chunks. + -- + -- Prev_Chunk Chunk + -- v v + -- . . . . . . . +--------------+ +-------- + -- . --> |##############| --> | + -- . . . . . . . +--------------+ +-------- + -- | | + -- -------------------+------------+ + -- Size_Up_To_Chunk Size + -- + -- The Size_Up_To_Chunk is equal to the size of the whole stack up to + -- the previous chunk, plus the size of the previous chunk itself. + + Chunk.Size_Up_To_Chunk := Size_Up_To_And_Including (Prev_Chunk); + end if; + + -- The chunk must have enough room to fit the memory request. If this is + -- not the case, then a previous step picked the wrong chunk. + + pragma Assert (Has_Enough_Free_Memory (Chunk, Byte, Mem_Size)); + + -- The first byte of the allocation is the first free byte within the + -- chunk. + + Addr := Chunk.Memory (Byte)'Address; + + -- Align the address to ensure that the CHERI bounds will be + -- representable. + + Padding := Padding_For_Bounds_Alignment (Addr, Mem_Size); + Addr := Addr + Storage_Offset (Padding); + + -- The chunk becomes the chunk indicated by the stack pointer. This is + -- either the currently indicated chunk, an existing chunk, or a brand + -- new chunk. + + Stack.Top.Chunk := Chunk; + + -- The next free byte is immediately after the memory request + -- + -- Addr Top.Byte + -- | | + -- +-----|--------|----+ + -- |##############| | + -- +-------------------+ + + -- ??? this calculation may overflow on 32bit targets + + Stack.Top.Byte := Byte + Mem_Size + Padding; + + -- At this point the next free byte cannot go beyond the memory capacity + -- of the chunk indicated by the stack pointer, except when the chunk is + -- full, in which case it indicates the byte beyond the chunk. Ensure + -- that the occupied memory is at most as much as the capacity of the + -- chunk. Top.Byte - 1 denotes the last occupied byte. + + pragma Assert (Stack.Top.Byte - 1 <= Stack.Top.Chunk.Size); + + -- Calculate the new high water mark now that the memory request has + -- been fulfilled, and update if necessary. The new high water mark is + -- technically the size of the used memory by the whole stack. + + New_High_Water_Mark := Used_Memory_Size (Stack); + + if New_High_Water_Mark > Stack.High_Water_Mark then + Stack.High_Water_Mark := New_High_Water_Mark; + end if; + end Allocate_On_Chunk; + + --------------------- + -- Allocate_Static -- + --------------------- + + procedure Allocate_Static + (Stack : SS_Stack_Ptr; + Mem_Size : Memory_Size; + Addr : out Address) + is + begin + -- Static secondary stack allocations are performed only on the static + -- chunk. There should be no dynamic chunks following the static chunk. + + pragma Assert (Stack.Top.Chunk = Stack.Static_Chunk'Access); + pragma Assert (Stack.Top.Chunk.Next = null); + + -- Raise Storage_Error if the static chunk does not have enough room to + -- fit the memory request. This indicates that the stack is about to be + -- depleted. + + if not Has_Enough_Free_Memory + (Chunk => Stack.Top.Chunk, + Byte => Stack.Top.Byte, + Mem_Size => Mem_Size) + then + raise Storage_Error with "secondary stack exhaused"; + end if; + + Allocate_On_Chunk + (Stack => Stack, + Prev_Chunk => null, + Chunk => Stack.Top.Chunk, + Byte => Stack.Top.Byte, + Mem_Size => Mem_Size, + Addr => Addr); + end Allocate_Static; + + -------------------- + -- Get_Chunk_Info -- + -------------------- + + function Get_Chunk_Info + (Stack : SS_Stack_Ptr; + C_Id : Chunk_Id) return Chunk_Info + is + function Find_Chunk return SS_Chunk_Ptr; + pragma Inline (Find_Chunk); + -- Find the chunk which corresponds to Id. Return null if no such chunk + -- exists. + + ---------------- + -- Find_Chunk -- + ---------------- + + function Find_Chunk return SS_Chunk_Ptr is + Chunk : SS_Chunk_Ptr; + Id : Chunk_Id; + + begin + Chunk := Stack.Static_Chunk'Access; + Id := 1; + while Chunk /= null loop + if Id = C_Id then + return Chunk; + end if; + + Chunk := Chunk.Next; + Id := Id + 1; + end loop; + + return null; + end Find_Chunk; + + -- Local variables + + Chunk : constant SS_Chunk_Ptr := Find_Chunk; + + -- Start of processing for Get_Chunk_Info + + begin + if Chunk = null then + return Invalid_Chunk; + + else + return (Size => Chunk.Size, + Size_Up_To_Chunk => Chunk.Size_Up_To_Chunk); + end if; + end Get_Chunk_Info; + + -------------------- + -- Get_Stack_Info -- + -------------------- + + function Get_Stack_Info (Stack : SS_Stack_Ptr) return Stack_Info is + Info : Stack_Info; + + begin + Info.Default_Chunk_Size := Stack.Default_Chunk_Size; + Info.Freeable := Stack.Freeable; + Info.High_Water_Mark := Stack.High_Water_Mark; + Info.Number_Of_Chunks := Number_Of_Chunks (Stack); + Info.Top.Byte := Stack.Top.Byte; + Info.Top.Chunk := Top_Chunk_Id (Stack); + + return Info; + end Get_Stack_Info; + + ---------------------------- + -- Has_Enough_Free_Memory -- + ---------------------------- + + function Has_Enough_Free_Memory + (Chunk : SS_Chunk_Ptr; + Byte : Memory_Index; + Mem_Size : Memory_Size) return Boolean + is + Padding : Memory_Size; + + begin + -- First check if the chunk is full (Byte is > Memory'Last in that + -- case), then check there is enough free memory. + + -- Byte - 1 denotes the last occupied byte. Subtracting that byte from + -- the memory capacity of the chunk yields the size of the free memory + -- within the chunk. The chunk can fit the request as long as the free + -- memory is as big as the request. + + -- We also need to consider any extra padding needed to align the + -- address to ensure that the CHERI lower bound is representable. + + Padding := + Padding_For_Bounds_Alignment (Chunk.Memory (Byte)'Address, Mem_Size); + + return Chunk.Memory'Last >= Byte + and then Chunk.Size - (Byte - 1) >= Mem_Size + and then Chunk.Size - (Byte - 1) - Mem_Size >= Padding; + + end Has_Enough_Free_Memory; + + ---------------------- + -- Number_Of_Chunks -- + ---------------------- + + function Number_Of_Chunks (Stack : SS_Stack_Ptr) return Chunk_Count is + Chunk : SS_Chunk_Ptr; + Count : Chunk_Count; + + begin + Chunk := Stack.Static_Chunk'Access; + Count := 0; + while Chunk /= null loop + Chunk := Chunk.Next; + Count := Count + 1; + end loop; + + return Count; + end Number_Of_Chunks; + + ------------------------------ + -- Size_Up_To_And_Including -- + ------------------------------ + + function Size_Up_To_And_Including + (Chunk : SS_Chunk_Ptr) return Memory_Size + is + begin + return Chunk.Size_Up_To_Chunk + Chunk.Size; + end Size_Up_To_And_Including; + + ----------------- + -- SS_Allocate -- + ----------------- + + procedure SS_Allocate + (Addr : out Address; + Storage_Size : Storage_Count; + Alignment : SSE.Storage_Count := Standard'Maximum_Alignment) + is + + function Round_Up (Size : Storage_Count) return Memory_Size; + pragma Inline (Round_Up); + -- Round Size up to the nearest multiple of the maximum alignment + + function Align_Addr (Addr : Address) return Address; + pragma Inline (Align_Addr); + -- Align Addr to the next multiple of Alignment + + ---------------- + -- Align_Addr -- + ---------------- + + function Align_Addr (Addr : Address) return Address is + begin + + -- L : Alignment + -- A : Standard'Maximum_Alignment + + -- Addr + -- L | L L + -- A--A--A--A--A--A--A--A--A--A--A + -- | | + -- \----/ | | + -- Addr mod L | Addr + L + -- | + -- Addr + L - (Addr mod L) + + return Addr + (Alignment - (Addr mod Alignment)); + end Align_Addr; + + -------------- + -- Round_Up -- + -------------- + + function Round_Up (Size : Storage_Count) return Memory_Size is + Algn_MS : constant Memory_Size := Standard'Maximum_Alignment; + Size_MS : constant Memory_Size := Memory_Size (Size); + + begin + -- Detect a case where the Size is very large and may yield + -- a rounded result which is outside the range of Chunk_Memory_Size. + -- Treat this case as secondary-stack depletion. + + if Memory_Size'Last - Algn_MS < Size_MS then + raise Storage_Error with "secondary stack exhausted"; + end if; + + return ((Size_MS + Algn_MS - 1) / Algn_MS) * Algn_MS; + end Round_Up; + + -- Local variables + + Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all; + Mem_Size : Memory_Size; + + Over_Aligning : constant Boolean := + Alignment > Standard'Maximum_Alignment; + + Over_Align_Padding : SSE.Storage_Count := 0; + + Adjusted_Storage_Size : Interfaces.CHERI.Bounds_Length; + -- Storage_Size plus padding for over-alignment and extra padding to + -- align the capability's upper bound. + + Capability_Lower_Bound : Address; + + -- Start of processing for SS_Allocate + + begin + -- Alignment must be a power of two and can be: + + -- - lower than or equal to Maximum_Alignment, in which case the result + -- will be aligned on Maximum_Alignment; + -- - higher than Maximum_Alignment, in which case the result will be + -- dynamically realigned. + + if Over_Aligning then + Over_Align_Padding := Alignment; + end if; + + -- It should not be possible to request an allocation of negative + -- size. + + pragma Assert (Storage_Size >= 0); + + -- Round the requested size (plus the needed padding in case of + -- over-alignment) to ensure that the CHERI bounds length will be + -- representable. + + Adjusted_Storage_Size := + Representable_Length + (Bounds_Length (Storage_Size + Over_Align_Padding)); + + -- Round up to the nearest multiple of the default alignment to ensure + -- efficient access and that the next available Byte is always aligned + -- on the default alignement value. + + Mem_Size := Round_Up (Storage_Count (Adjusted_Storage_Size)); + + if Sec_Stack_Dynamic then + Allocate_Dynamic (Stack, Mem_Size, Addr); + else + Allocate_Static (Stack, Mem_Size, Addr); + end if; + + -- Restrict the capability bounds to the requested allocation size, + -- possibly with some padding for alignment of the bounds. + + Capability_Lower_Bound := + Capability_With_Address_Aligned_Up (Addr, Adjusted_Storage_Size); + + Addr := Capability_With_Exact_Bounds + (Capability_Lower_Bound, Adjusted_Storage_Size); + + if Over_Aligning then + Addr := Align_Addr (Addr); + end if; + + end SS_Allocate; + + ------------- + -- SS_Free -- + ------------- + + procedure SS_Free (Stack : in out SS_Stack_Ptr) is + Static_Chunk : constant SS_Chunk_Ptr := Stack.Static_Chunk'Access; + Next_Chunk : SS_Chunk_Ptr; + + begin + -- Free all dynamically allocated chunks. The first dynamic chunk is + -- found immediately after the static chunk of the stack. + + while Static_Chunk.Next /= null loop + Next_Chunk := Static_Chunk.Next.Next; + Free (Static_Chunk.Next); + Static_Chunk.Next := Next_Chunk; + end loop; + + -- At this point one of the following outcomes has taken place: + -- + -- * The stack lacks any dynamic chunks + -- + -- * The stack had dynamic chunks which were all freed + -- + -- Either way, there should be nothing hanging off the static chunk + + pragma Assert (Static_Chunk.Next = null); + + -- Free the stack only when it was dynamically allocated + + if Stack.Freeable then + Free (Stack); + end if; + end SS_Free; + + ---------------- + -- SS_Get_Max -- + ---------------- + + function SS_Get_Max return Long_Long_Integer is + Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all; + + begin + return Long_Long_Integer (Stack.High_Water_Mark); + end SS_Get_Max; + + ------------- + -- SS_Info -- + ------------- + + procedure SS_Info is + procedure SS_Info_Dynamic (Stack : SS_Stack_Ptr); + pragma Inline (SS_Info_Dynamic); + -- Output relevant information concerning dynamic secondary stack Stack + + function Total_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size; + pragma Inline (Total_Memory_Size); + -- Calculate the size of stack Stack's total memory usage. This includes + -- the following kinds of memory: + -- + -- * Free memory in used chunks due to alignment holes + -- * Free memory in the topmost chunk due to partial usage + -- * Free memory in unused chunks following the chunk indicated by the + -- stack pointer. + -- * Memory occupied by allocations + -- + -- This is a linear-time operation on the number of chunks. + + --------------------- + -- SS_Info_Dynamic -- + --------------------- + + procedure SS_Info_Dynamic (Stack : SS_Stack_Ptr) is + begin + Put_Line + (" Number of Chunks : " & Number_Of_Chunks (Stack)'Img); + + Put_Line + (" Default size of Chunks : " & Stack.Default_Chunk_Size'Img); + end SS_Info_Dynamic; + + ----------------------- + -- Total_Memory_Size -- + ----------------------- + + function Total_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size is + Chunk : SS_Chunk_Ptr; + Total : Memory_Size; + + begin + -- The total size of the stack is equal to the size of the stack up + -- to the chunk indicated by the stack pointer, plus the size of the + -- indicated chunk, plus the size of any subsequent chunks. + + Total := Size_Up_To_And_Including (Stack.Top.Chunk); + + Chunk := Stack.Top.Chunk.Next; + while Chunk /= null loop + Total := Total + Chunk.Size; + Chunk := Chunk.Next; + end loop; + + return Total; + end Total_Memory_Size; + + -- Local variables + + Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all; + + -- Start of processing for SS_Info + + begin + Put_Line ("Secondary Stack information:"); + + Put_Line + (" Total size : " + & Total_Memory_Size (Stack)'Img + & " bytes"); + + Put_Line + (" Current allocated space : " + & Used_Memory_Size (Stack)'Img + & " bytes"); + + if Sec_Stack_Dynamic then + SS_Info_Dynamic (Stack); + end if; + end SS_Info; + + ------------- + -- SS_Init -- + ------------- + + procedure SS_Init + (Stack : in out SS_Stack_Ptr; + Size : Size_Type := Unspecified_Size) + is + function Next_Available_Binder_Sec_Stack return SS_Stack_Ptr; + pragma Inline (Next_Available_Binder_Sec_Stack); + -- Return a pointer to the next available stack from the pool created by + -- the binder. This routine updates global Default_Sec_Stack_Pool_Index. + + ------------------------------------- + -- Next_Available_Binder_Sec_Stack -- + ------------------------------------- + + function Next_Available_Binder_Sec_Stack return SS_Stack_Ptr is + + -- The default-sized secondary stack pool generated by the binder + -- is passed to this unit as an Address because it is not possible + -- to define a pointer to an array of unconstrained components. The + -- pointer is instead obtained using an unchecked conversion to a + -- constrained array of secondary stacks with the same size as that + -- specified by the binder. + + -- WARNING: The following data structure must be synchronized with + -- the one created in Bindgen.Gen_Output_File_Ada. The version in + -- bindgen is called Sec_Default_Sized_Stacks. + + type SS_Pool is + array (1 .. Binder_SS_Count) + of aliased SS_Stack (Binder_Default_SS_Size); + + type SS_Pool_Ptr is access SS_Pool; + -- A reference to the secondary stack pool + + function To_SS_Pool_Ptr is + new Ada.Unchecked_Conversion (Address, SS_Pool_Ptr); + + -- Use an unchecked conversion to obtain a pointer to one of the + -- secondary stacks from the pool generated by the binder. There + -- are several reasons for using the conversion: + -- + -- * Accessibility checks prevent a value of a local pointer to be + -- stored outside this scope. The conversion is safe because the + -- pool is global to the whole application. + -- + -- * Unchecked_Access may circumvent the accessibility checks, but + -- it is incompatible with restriction No_Unchecked_Access. + -- + -- * Unrestricted_Access may circumvent the accessibility checks, + -- but it is incompatible with pure Ada constructs. + -- ??? cannot find the restriction or switch + + pragma Warnings (Off); + function To_SS_Stack_Ptr is + new Ada.Unchecked_Conversion (Address, SS_Stack_Ptr); + pragma Warnings (On); + + Pool : SS_Pool_Ptr; + + begin + -- Obtain a typed view of the pool + + Pool := To_SS_Pool_Ptr (Binder_Default_SS_Pool); + + -- Advance the stack index to the next available stack + + Binder_Default_SS_Pool_Index := Binder_Default_SS_Pool_Index + 1; + + -- Return a pointer to the next available stack + + return To_SS_Stack_Ptr (Pool (Binder_Default_SS_Pool_Index)'Address); + end Next_Available_Binder_Sec_Stack; + + -- Local variables + + Stack_Size : Memory_Size_With_Invalid; + + -- Start of processing for SS_Init + + begin + -- Allocate a new stack on the heap or use one from the pool created by + -- the binder. + + if Stack = null then + + -- The caller requested a pool-allocated stack. Determine the proper + -- size of the stack based on input from the binder or the runtime in + -- case the pool is exhausted. + + if Size = Unspecified_Size then + + -- Use the default secondary stack size as specified by the binder + -- only when it has been set. This prevents a bootstrap issue with + -- older compilers where the size is never set. + + if Binder_Default_SS_Size > 0 then + Stack_Size := Binder_Default_SS_Size; + + -- Otherwise use the default stack size of the particular runtime + + else + Stack_Size := Runtime_Default_Sec_Stack_Size; + end if; + + -- Otherwise the caller requested a heap-allocated stack. Use the + -- specified size directly. + + else + Stack_Size := Size; + end if; + + -- The caller requested a pool-allocated stack. Use one as long as + -- the pool created by the binder has available stacks. This stack + -- cannot be deallocated. + + if Size = Unspecified_Size + and then Binder_SS_Count > 0 + and then Binder_Default_SS_Pool_Index < Binder_SS_Count + then + Stack := Next_Available_Binder_Sec_Stack; + Stack.Freeable := False; + + -- Otherwise the caller requested a heap-allocated stack, or the pool + -- created by the binder ran out of available stacks. This stack can + -- be deallocated. + + else + -- It should not be possible to create a stack with a negative + -- default chunk size. + + pragma Assert (Stack_Size in Memory_Size); + + Stack := new SS_Stack (Stack_Size); + Stack.Freeable := True; + end if; + + -- Otherwise the stack was already created either by the compiler or by + -- the user, and is about to be reused. + + else + null; + end if; + + -- The static chunk becomes the chunk indicated by the stack pointer. + -- Note that the stack may still hold dynamic chunks, which in turn may + -- be reused or freed. + + Stack.Top.Chunk := Stack.Static_Chunk'Access; + + -- The first free byte is the first free byte of the chunk indicated by + -- the stack pointer. + + Stack.Top.Byte := Stack.Top.Chunk.Memory'First; + + -- Since the chunk indicated by the stack pointer is also the first + -- chunk in the stack, there are no prior chunks, therefore the size + -- of the stack up to the chunk is zero. + + Stack.Top.Chunk.Size_Up_To_Chunk := 0; + + -- Reset the high water mark to account for brand new allocations + + Stack.High_Water_Mark := 0; + end SS_Init; + + ------------- + -- SS_Mark -- + ------------- + + function SS_Mark return Mark_Id is + Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all; + + begin + return (Stack => Stack, Top => Stack.Top); + end SS_Mark; + + ---------------- + -- SS_Release -- + ---------------- + + procedure SS_Release (M : Mark_Id) is + begin + M.Stack.Top := M.Top; + end SS_Release; + + ------------------ + -- Top_Chunk_Id -- + ------------------ + + function Top_Chunk_Id (Stack : SS_Stack_Ptr) return Chunk_Id_With_Invalid is + Chunk : SS_Chunk_Ptr; + Id : Chunk_Id; + + begin + Chunk := Stack.Static_Chunk'Access; + Id := 1; + while Chunk /= null loop + if Chunk = Stack.Top.Chunk then + return Id; + end if; + + Chunk := Chunk.Next; + Id := Id + 1; + end loop; + + return Invalid_Chunk_Id; + end Top_Chunk_Id; + + ---------------------- + -- Used_Memory_Size -- + ---------------------- + + function Used_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size is + begin + -- The size of the occupied memory is equal to the size up to the chunk + -- indicated by the stack pointer, plus the size in use by the indicated + -- chunk itself. Top.Byte - 1 is the last occupied byte. + -- + -- Top.Byte + -- | + -- . . . . . . . +--------------|----+ + -- . ..> |##############| | + -- . . . . . . . +-------------------+ + -- | | + -- -------------------+-------------+ + -- Size_Up_To_Chunk size in use + + -- ??? this calculation may overflow on 32bit targets + + return Stack.Top.Chunk.Size_Up_To_Chunk + Stack.Top.Byte - 1; + end Used_Memory_Size; + + ---------------------------------- + -- Padding_For_Bounds_Alignment -- + ---------------------------------- + + function Padding_For_Bounds_Alignment + (Ptr : Address; + Size : Memory_Size) + return Memory_Size + is + IA : constant Integer_Address := To_Integer (Ptr); + begin + return Memory_Size (Align_Address_Up (IA, Bounds_Length (Size)) - IA); + end Padding_For_Bounds_Alignment; + +end System.Secondary_Stack; From patchwork Mon Nov 4 16:10:58 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: 2006308 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=WUMiMubd; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxRJ57Hpz1xxW for ; Tue, 5 Nov 2024 03:16:12 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id B2A14385AC24 for ; Mon, 4 Nov 2024 16:16:10 +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 A4D94385780F for ; Mon, 4 Nov 2024 16:11:45 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A4D94385780F 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 A4D94385780F 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=1730736736; cv=none; b=GlrY3U7GcD2JKN4u+38qtevXcCUNTlykaG55hg3c2QZ6ubVvv1dbmzSeolW3RRE2N7AwC1hVtl/eZSg13TIJKkzpAWbxgVRHC4n9TrrAJmXz325HNlLd+qshlGxictyQNekYyHaUZ5GkSfp2Rb22qulk9Ts36SFPbOmKaaVj/I0= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736736; c=relaxed/simple; bh=uEPB6MAF7rJas+tYN9f1ME5blVOHV2fUSbBZVf7+u38=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=ftFD7n2gde4a9vq1pybyaHdSbG4K52Z6lzCuwN/Wr9dHf2V0an7baMEGbXqFwoj0rsUccb+27//k8fPcHKp+pvDCGUD+sNzkNmbCwz+WBL7dzEmG1fXrY5o4GwRZyIMeqDW+GrRcilZpgIjOgEH7dFjONWY4Ny78hAe1twfgqzQ= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42b.google.com with SMTP id ffacd0b85a97d-37d43a9bc03so2991950f8f.2 for ; Mon, 04 Nov 2024 08:11:45 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736704; x=1731341504; 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=ugYyIU8vOgVc12jnjqqAhZMFyVmmxmcP82NyxvzcTDw=; b=WUMiMubdZHNIKk2jXWn5aDZ4/p2nLYo1abDu/r4u2rrHwf0S9WeZDhgu8gEnseLFSN 0wXgooWECX1+mQPWQBRt+URWPInOaas6iJhuHCqbqw+kYnLPTxG3CknfR89iY/p4h8Ls DP1iHTstSkRjMEQ8Q0UIl9v12IIhPuujgo3GgDyTTip8G8rPcwFvDn1Uk2RSeVgs0Ed9 5LEcruVyh+N5vxtZjN7uAe/L9dQqiZrNmNFIrZCO6beHPfVrZ1bBYSr723/9zOCa8J+f pxRTq0bELxnoctjZlnacdLxiXg/2nA8Jexl4h9E4KLKnCP1u0fmM1UE8pLEpMTgl9yqp x0wg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736704; x=1731341504; 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=ugYyIU8vOgVc12jnjqqAhZMFyVmmxmcP82NyxvzcTDw=; b=WvU+7X9aKRoSKT7rzqJo/2shjXlzN9eVvNo06FjrjGi1FpaouDfsrsYO6bEznpJ5GO RYziYy0LW0osErLJdWdKUO+F7LnlWKctE9pDJBYddnllO3D7NgUhXejqMfQhHPTwre4V 2dRkM0aNC/1q0vpdPfxC9UqtzAvV1MZiCK5Wj/6dVkptybaHCQlVE4OVAR/r1dlq5L2g aYt327f9tLZ5awH2MjQ4Z5NS84GH5KDQPdq/md2hny0bsEUP7y7IeiuZuoit38bX/Tti eHS+4f/szZ+YFJCftlCLgYemC+2AdTza2L3SNaHINuvwVVkuM0UV87vjtWiVBLXCJGU+ kyOA== X-Gm-Message-State: AOJu0Yw+Vd1dYuqMGJzq/JmzM/iLvJWu+2mO04BVPvO17sj2DZlvwPU8 jQ2JdgR3nawEst/WiAkVTu09nux5kNDGsMCjcLwsB5AbPQVLeijk4XxiCq87hH8ZIR6GxK5M4G4 = X-Google-Smtp-Source: AGHT+IGZFzC4NGvtYAwF83prNZ8shFO+sxlB7edDPYbmVGrr/qot/7i7ICdMqrxUZ/FRFBfJ8vq3Bw== X-Received: by 2002:a5d:6da6:0:b0:37d:501f:483f with SMTP id ffacd0b85a97d-381c7ab2fb6mr9422829f8f.44.1730736704326; Mon, 04 Nov 2024 08:11:44 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.43 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:43 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [COMMITTED 23/38] ada: Missing runtime check in interpolated string Date: Mon, 4 Nov 2024 17:10:58 +0100 Message-ID: <20241104161116.1431659-23-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Javier Miranda When the type imposed by the context for an interpolated string is constrained, the compiler silently omits adding a runtime check. gcc/ada/ChangeLog: * exp_ch2.adb (Expand_N_Interpolated_String_Literal): Use the base type of the type imposed by the context for building the interpolated string image; required to allow the expander adding the missing runtime check when the target type is constrained. (Apply_Static_Length_Check): New subprogram. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch2.adb | 72 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 69 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 99a16947525..aacf26c5128 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -51,7 +51,9 @@ with Sinfo.Utils; use Sinfo.Utils; with Sinput; use Sinput; with Snames; use Snames; with Stand; +with Stringt; use Stringt; with Tbuild; use Tbuild; +with Uintp; use Uintp; package body Exp_Ch2 is @@ -721,6 +723,12 @@ package body Exp_Ch2 is procedure Expand_N_Interpolated_String_Literal (N : Node_Id) is + procedure Apply_Static_Length_Check (Typ : Entity_Id); + -- Tries to determine statically whether the length of the interpolated + -- string N exceeds the length of the target subtype Typ. If it can be + -- determined at compile time then an N_Raise_Constraint_Error node + -- replaces the interpolated string N, and a warning message is issued. + function Build_Interpolated_String_Image (N : Node_Id) return Node_Id; -- Build the following Expression_With_Actions node: -- do @@ -733,6 +741,47 @@ package body Exp_Ch2 is -- Destroy (Sink); -- in Result end + ------------------------------- + -- Apply_Static_Length_Check -- + ------------------------------- + + procedure Apply_Static_Length_Check (Typ : Entity_Id) is + HB : constant Node_Id := High_Bound (First_Index (Typ)); + LB : constant Node_Id := Low_Bound (First_Index (Typ)); + Str_Elem : Node_Id; + Str_Length : Nat; + Typ_Length : Nat; + + begin + if Compile_Time_Known_Value (LB) + and then Compile_Time_Known_Value (HB) + then + Typ_Length := UI_To_Int (Expr_Value (HB) - Expr_Value (LB) + 1); + + -- Compute the minimum length of the interpolated string: the + -- length of the concatenation of the string literals composing + -- the interpolated string. + + Str_Length := 0; + Str_Elem := First (Expressions (N)); + while Present (Str_Elem) loop + if Nkind (Str_Elem) = N_String_Literal then + Str_Length := Str_Length + String_Length (Strval (Str_Elem)); + end if; + + Next (Str_Elem); + end loop; + + if Str_Length > Typ_Length then + Apply_Compile_Time_Constraint_Error + (N, "wrong length for interpolated string of}??", + CE_Length_Check_Failed, + Ent => Typ, + Typ => Typ); + end if; + end if; + end Apply_Static_Length_Check; + ------------------------------------- -- Build_Interpolated_String_Image -- ------------------------------------- @@ -747,10 +796,11 @@ package body Exp_Ch2 is Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Type), Loc)); + B_Type : constant Entity_Id := Base_Type (Etype (N)); Get_Id : constant RE_Id := - (if Etype (N) = Stand.Standard_String then + (if B_Type = Stand.Standard_String then RE_Get - elsif Etype (N) = Stand.Standard_Wide_String then + elsif B_Type = Stand.Standard_Wide_String then RE_Wide_Get else RE_Wide_Wide_Get); @@ -760,7 +810,7 @@ package body Exp_Ch2 is Make_Object_Declaration (Loc, Defining_Identifier => Result_Entity, Object_Definition => - New_Occurrence_Of (Etype (N), Loc), + New_Occurrence_Of (B_Type, Loc), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (Get_Id), Loc), @@ -838,8 +888,24 @@ package body Exp_Ch2 is -- Start of processing for Expand_N_Interpolated_String_Literal begin + -- If the type imposed by the context is constrained then check that + -- the statically known length of the interpolated string does not + -- exceed the length of its type. + + if Is_Constrained (Typ) then + Apply_Static_Length_Check (Typ); + + if Nkind (N) = N_Raise_Constraint_Error then + return; + end if; + end if; + Rewrite (N, Build_Interpolated_String_Image (N)); Analyze_And_Resolve (N, Typ); + + if Is_Constrained (Typ) then + Apply_Length_Check (Expression (N), Typ); + end if; end Expand_N_Interpolated_String_Literal; end Exp_Ch2; From patchwork Mon Nov 4 16:10:59 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: 2006313 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=gOoU6rUX; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxSb4Mkdz1xxW for ; Tue, 5 Nov 2024 03:17:19 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 4909D385B528 for ; Mon, 4 Nov 2024 16:17:13 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x432.google.com (mail-wr1-x432.google.com [IPv6:2a00:1450:4864:20::432]) by sourceware.org (Postfix) with ESMTPS id 7C63D385842D for ; Mon, 4 Nov 2024 16:11:46 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 7C63D385842D 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 7C63D385842D Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::432 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736730; cv=none; b=lmrk1xeStjYhSTTV2YL4rOG9KfcoEjG8gbdwgo2h6v8aXMldbPGyaiOMh9QZokAUJo4fn7PkChQJlmFT+8SAc27ZAuNgT55nKitLQZPs0ZKkhvKg2F+CSfwuBrGg4hW2E/n/GDnb28g29SvINuDEG9vsn6Ply9/0kFlnM8YrBLA= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736730; c=relaxed/simple; bh=D84MFS1Ho3DYypMcvmn3TXD4D8aTgnxgOWbHHmC8gfc=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=dgLNH8/aFRTwnqKEVQwDouIdjM7QFvx8cZPBatZVuInLAa1OH9vOGyL4pNomE9pBtf07Z8UkryxpZcb1GrzA1xVFxhR30e7Y/uI2TkaGMsHraa7J8H4UtkSdOkdcrY6kxaJmAKf1lDrrLpgvQbrT6TO/Boilz4jg4aeLcszyOUA= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x432.google.com with SMTP id ffacd0b85a97d-37d4ac91d97so3785718f8f.2 for ; Mon, 04 Nov 2024 08:11:46 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736705; x=1731341505; 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=W1H6I2Bq6bMQ224de7HzFL6p/NlBDcfEDOktpzToCyw=; b=gOoU6rUX0H6D2idEm6AfM5l3Waz2pMWq6sK+I11HCHSj6M5Wb4X8iy6r9ZlL/afeQk MtJxM+7unBVHt8xCh7mndTqJYpFZP//RgCPe02WpuxhTStqD5qiMKScvUtCIo5r5ESzj uk5OtDBLrfyB6Hk7Lr33yKdV0RAsMmIpoFzISoWBdCRTRw/p1qpoxAJkEx2QBt9BXbhN Xf1g5FcJ5CewspPuXwT5ywQ1BJ9HaZc8oOf483+VUdY8oF49nbfTp4P29m+eey0fY6SB QMie3J+fpWJ1vNV25mIOBt2w20Lvvnr+z1FTwsUlPDDJsI6/X5KAMzQiBaSHRL+DtOiz Z/YQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736705; x=1731341505; 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=W1H6I2Bq6bMQ224de7HzFL6p/NlBDcfEDOktpzToCyw=; b=B0rG02SZliBvRmajLYDmOpnrb247H6/3Ua+9ZEnMXBKi0e66ABUx9GWkeEuDOAtmJA LN6tmgdLEOEuUTComOxc4BzZzpT+dap94DhO2NaeNa9gPvHJLeEr0AOi/FCMP4wsrQYi lbK3geTBo7VmCTsEZdGHF3MSs35kE7EN1WP8LPRJ9nX6SSr3MUcDmen0o931D+T4+yb1 yVk8BV6mspfTrMoMc4tzhl3SHcvs+T6MZpvWfXfx3j//1YOEe1yeDD/AdsvUd8SqjfFv 6oSUjOn3LNMJEpcwMNvb0P+LdWtMtefKaf3+VYln54i0wzdLmZDrfNUesS0/xDAIW46V xlMQ== X-Gm-Message-State: AOJu0Yy601TDPCX4dKu99OGdqyVmL5zOKTX49WsEOgJXG4h4ORe0upjh XU/07p6QwKt5/aV7/5FayJJg6PUH+O6qfxa/n8R9qyzZ7cqxFzr9Xv8y2IiitrCyaZaBJ5mb2fM = X-Google-Smtp-Source: AGHT+IFVAJGW8bClNC2cnOLBtcM39m2qSQ1+0gQPdup5NaAXxE+h5uowVyqK5E4BlhJZCvsW2Fy0EA== X-Received: by 2002:a05:6000:18a3:b0:374:c3e4:d6b1 with SMTP id ffacd0b85a97d-381c7ac41eamr12002504f8f.44.1730736705064; Mon, 04 Nov 2024 08:11:45 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.44 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:44 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Ronan Desplanques Subject: [COMMITTED 24/38] ada: Display message on reproducer generation failure Date: Mon, 4 Nov 2024 17:10:59 +0100 Message-ID: <20241104161116.1431659-24-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Ronan Desplanques Before this patch, nothing was reported to the user when an exception was raised during generation of a minimal reproducer. This patch fixes this. gcc/ada/ChangeLog: * comperr.adb (Compiler_Abort): Display message in exception handler. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/comperr.adb | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index e411ddb5d29..726f0ccadb0 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -409,7 +409,8 @@ package body Comperr is Generate_Minimal_Reproducer; end if; exception - when others => null; + when others => + Write_Str ("failed to generate reproducer"); end; Write_Eol; From patchwork Mon Nov 4 16:11:00 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: 2006309 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=GOn38TNW; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxRc6zlYz1xxW for ; Tue, 5 Nov 2024 03:16:28 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 25F78385842D for ; Mon, 4 Nov 2024 16:16:27 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42e.google.com (mail-wr1-x42e.google.com [IPv6:2a00:1450:4864:20::42e]) by sourceware.org (Postfix) with ESMTPS id 2B5EA385772E for ; Mon, 4 Nov 2024 16:11:47 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2B5EA385772E 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 2B5EA385772E Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42e ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736739; cv=none; b=tp6nlKU/Vy3FT34n9CN199LuzhpclqIpuRTESOImw4tr7jHUWqqF7rFm5baPHaakeX0gx5ZYR3uKPHA1ncwdZn2SqNS1gBIom/n0ENZfoT9rFVjSilC6PKWZAlh8JINHaMG2yI8Wihnr5Zwzg+BJZUJR80WqUJHdFilG3l+Eu4k= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736739; c=relaxed/simple; bh=bJtGn+fz6AK0oLSISYosnP16rAPQakfV5dgkXOFtpuI=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=UbCmZQ5X524CFARBaKc/XUsx8CJfEV01J/3UOVvr2Lj+DdtPXXXiIsyyN9Vmg4Q5acVnyG1gS19h/AnLZvQrjNoZux38zzKFawytXEllZmDqRr846AdG2oGMOVsmbdEmY77ZFDL3UeIgpY7FKtg9DGgAtiGhcMrzXfgFXSA4PL8= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42e.google.com with SMTP id ffacd0b85a97d-37ed7eb07a4so3312823f8f.2 for ; Mon, 04 Nov 2024 08:11:47 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736706; x=1731341506; 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=8N5HIbFMSGFLxMlUQi2PfNKB4j8NQ2/ybNHB2A2r1Ik=; b=GOn38TNWWo5Rvot7/kNJ0d9BkzgbxdmtHxrVo5yjSDUd9koKbm/prJfkOUnoxF9MTD fxJ0jiZddqHHg+BChAgFv0wIHm5P3PbT8JqwMvJuVKLo2sCdyNzazA7dZiBH+UHtaTvi 6HN38GTIZaB6EKEEZriN+LYgQBK5zd9GZOoZCQtetC5cJAqHM0LHRkkItoAvrkB41DRt JZeHhXSJn7spkqnY80/Kkjrrzutruow94I/+2olsvokTbCFOZcYqbLHuGqWoVcbbkamz wMFQ97WtETzUUriLoVjG/MuFtUkaQth219AYnwxRYS7BsXBnRnQhJiqUfvYzRKQWQqWb CYYw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736706; x=1731341506; 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=8N5HIbFMSGFLxMlUQi2PfNKB4j8NQ2/ybNHB2A2r1Ik=; b=fDlwsN2AKPNX3sFMJSC5kSD1CNLedNtP/7RYQtw0Ukb7jTQcZGcaIHmu1m8PxUpYaI djgmyMSLx6pyB1oljJ5l/n/C26YI9zfj9qqEJCNjH5w2pKOzxKx2Rane8+UgW/w6fv9N wlGHDfQGR+yWjurZ+uMC1N34PHOWpZbuvK9/JYuNC+WK8syMQMRuyEK9JOwmeVQXqa9M RRTMNeoOqCt12JWkKbD+K+KVyiASMiMMt+9ab4TmUe/BPMOAReUqXRPqLvYtDD4N3OAH yI5L9mICoqeRcbIRBYMI16kWUiper7WtTJscTpGlbowtN18tgQ6TLOr+Ho5dXxUh1I8z sF4w== X-Gm-Message-State: AOJu0YzlNq4y2Kl23l7bdzsh2IeqXMOsUzW3Lb+y9hRLZe/6rru7EglW XkuVcIXC8hImM5Xj+aF6MfHJ5EiCQAz0DTZohYAiaIP8RB67nKbfhKvSELz8VuGPZYQVWV4efAk = X-Google-Smtp-Source: AGHT+IGPs+eL/1Hs+b9xmoypl0mBDGHqJkLBRIaOJYgDphEY1YjaCAMcfwy7nfqIexrHisAvsHQqMw== X-Received: by 2002:a5d:64a8:0:b0:37d:46e3:4e88 with SMTP id ffacd0b85a97d-381be7654c6mr15339094f8f.9.1730736705824; Mon, 04 Nov 2024 08:11:45 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.45 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:45 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 25/38] ada: Tweak description of new predicate Date: Mon, 4 Nov 2024 17:11:00 +0100 Message-ID: <20241104161116.1431659-25-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou The existing comment is a bit too vague. gcc/ada/ChangeLog: * exp_aggr.ads (Is_Two_Pass_Aggregate): Beef up comment. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.ads | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads index aa79616c609..2bbaeb21741 100644 --- a/gcc/ada/exp_aggr.ads +++ b/gcc/ada/exp_aggr.ads @@ -60,7 +60,8 @@ package Exp_Aggr is function Is_Two_Pass_Aggregate (N : Node_Id) return Boolean; -- Return True if N is an aggregate that is to be expanded in two passes. - -- This is the case if it consists only of iterated associations. + -- This is the case if it consists only of iterated component associations + -- with iterator specifications, see RM 4.3.3(20.2/5). function Static_Array_Aggregate (N : Node_Id) return Boolean; -- N is an array aggregate that may have a component association with From patchwork Mon Nov 4 16:11:01 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: 2006312 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=bLuTakAT; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxSG3D2qz1xxW for ; Tue, 5 Nov 2024 03:17:02 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 864D3385770E for ; Mon, 4 Nov 2024 16:16:57 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lf1-x133.google.com (mail-lf1-x133.google.com [IPv6:2a00:1450:4864:20::133]) by sourceware.org (Postfix) with ESMTPS id 4EAED3857C5D for ; Mon, 4 Nov 2024 16:11:48 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 4EAED3857C5D 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 4EAED3857C5D Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::133 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736740; cv=none; b=Eg/6c5ByAymxNsRiqQ8AL2bKZb/hUo0oOeuGaXhVok3RekEulSjX7MR8Z0koAnHUrzlV0aLWWJIQMoGZVCTYQEY4EjjiZ2dOb79aorQ2TVDuUxKsPzqKV77Ol7rrcYXC6p/znUqnqbKAEG11A5qiM1u7Uvfc24uZJJPlPuleWE8= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736740; c=relaxed/simple; bh=QkrRifwCeDThSCblT6iLCWNUcbxcyl0RwczsbWgndXs=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=rvLTOF8960feg8Ff9EKcrx3rQFW2YUifTH32WopqWcnXNwmGxaDnTuch1ttL1sPiUM/+B7yRvBb+fQYhd/O9KnWghKBg505jjX2s+NgWPS3W3lBip1t6EulbMjSjA1gPlV7MuU7c9YS8NxW7YFTFQboXTafIfka7iEsw3zp1sJ8= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-lf1-x133.google.com with SMTP id 2adb3069b0e04-539f0f9ee49so4930747e87.1 for ; Mon, 04 Nov 2024 08:11:48 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736707; x=1731341507; 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=ReCEaLT0k6Q5l37an0/086qw6BzyfnKatLtupzBISC4=; b=bLuTakAT192YzviyZ5JKY/ZgoPTkE5wp/XUgc3tBMsz0wHj2ekLQmdxmwYLIJbO+5v uHFfWDpYCjA+fa/JxrH5fuoQwjYS7yYJJSXXrv+Tz7iJ5wgYUfaMLWFrXtXwuDxOcGPn dAyhoYD4CO4B/CfytMeUOA0EZE1+FAvGvWcT4UetRgxTH5qXkbX9aTJSVd/jSO6Cgq+Z J8s9OXhfi7cQlKnlZgPE6+DhukZSa9ZrG6OI3A3iXEb+5mwpb4BxU5pWz1WgkOshY8vs VYPqv+2VCHNzMFZCzsw4zdhMAdPutkONkH6mDSRY9T0X3YIleo4yQ2agALq4rWKXXTRu YUXA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736707; x=1731341507; 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=ReCEaLT0k6Q5l37an0/086qw6BzyfnKatLtupzBISC4=; b=XuxWB7RxTLbAhnITaM4kqdC3bpDG9cU4qb6nlLXjwveRLsIIabzEgRB6i6Wi2JUeYV 8hTFtZ0cC9sSiuPylVq2C88EECUkpDftMBveP/UpN3Elyvbu1sL3B/L8j2pf7K57cbDJ PVVUjXAtMDRdC1O6PhisDyDDBaKKkIEyQM7d6Drhzc0FllEmiNMzeaxXBeAzaRRCdhFf GKcdAswxojQBav3H5yVU2Ks6H8IcIJt1NzdEOt9V6hPwxz73vMoskn4s4ecl9nbOoNyN QYhDNGiz1GF/FHEpTylCaysq/mrS7ne1u8zc0jqYiawH+Uym1bAR3DNZ5nbjK6WzY7Kw XH3Q== X-Gm-Message-State: AOJu0YxWQYZyipY4RSTTAMJhaMjdp0+RJaUdHXAo8IiJ6F2sMd8RQyxL cognqW47gjIi9yQsvixHmaNFkeyDUzNCf4k7L8Jd/BEUo930exp1343vGonZaa7+ubbvaeXZtZM = X-Google-Smtp-Source: AGHT+IFwlKn46UINMDMtnDNMERNNcslCJUB71vhxAg7MwsuMy9iRa9pu3om3JtrLyxyWfpRPhS6SPQ== X-Received: by 2002:a05:6512:3b06:b0:539:f607:1d2b with SMTP id 2adb3069b0e04-53b348b7c7bmr15901511e87.7.1730736706546; Mon, 04 Nov 2024 08:11:46 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.45 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:46 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Viljar Indus Subject: [COMMITTED 26/38] ada: Update documentation for -gnatVxx switches Date: Mon, 4 Nov 2024 17:11:01 +0100 Message-ID: <20241104161116.1431659-26-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Viljar Indus Imporve the wording to explicitly state which options are turned on by -gnatVa and that -gnatVd is enabled by default. It can be somewhat hard to decifer that information from the old wording. Especially when compared to -gnatWxx switches where there is an elaborate scheme for describing those properties. gcc/ada/ChangeLog: * usage.adb: Update the wording for -gnatVa and -gnatVd. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/usage.adb | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 38a82beb615..d2857c922b1 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -443,10 +443,12 @@ begin Write_Switch_Char ("Vxx"); Write_Line ("Enable selected validity checking mode, xx = list of parameters:"); - Write_Line (" a turn on all validity checking options"); + Write_Line (" a turn on all of the following validity checking" + & " options"); Write_Line (" c turn on checking for copies"); Write_Line (" C turn off checking for copies"); - Write_Line (" d turn on default (RM) checking"); + Write_Line (" d turn on default (RM) checking" + & " (enabled by default)"); Write_Line (" D turn off default (RM) checking"); Write_Line (" e turn on checking for elementary components"); Write_Line (" E turn off checking for elementary components"); From patchwork Mon Nov 4 16:11:02 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: 2006323 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=bAjfnPb2; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxWP65MSz1xxW for ; Tue, 5 Nov 2024 03:19:45 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9CE303857350 for ; Mon, 4 Nov 2024 16:19:43 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x331.google.com (mail-wm1-x331.google.com [IPv6:2a00:1450:4864:20::331]) by sourceware.org (Postfix) with ESMTPS id A10853857B98 for ; Mon, 4 Nov 2024 16:11:48 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A10853857B98 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 A10853857B98 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::331 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736744; cv=none; b=Rv4kBefCVRafJeTmSXSnxzjZ/hO2JqnLRJVPrbaugTclj2rvYrtaORm6870/Wt2xZnyESZLrz4N4JHIhaLo6knm3A60NE0CHBXEoTWnlqbo3bofgYYfJm7kFn129Fh8Lb0nwANgNP+oG3J9Kt3OWefprdWlLXgJ3KBX/dwAtkWI= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736744; c=relaxed/simple; bh=phdiv+fFjeYJ34I0ChvFZagrIV02mZ63Mr4wu+y+gc4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=wEuN66Cmi8gXcgNtb/cXDEO9P8kHTfNaGYcTw/imbyYZkqj5tZv4FCkPvHRHTNksPbY8t94g3movXT+ySbUd3leiRI3zxWyS3pJoPFaioP1Kk3FZyy+TZoimmkXlWLX5ZkolqUapme3RZgO0+oLMqnofxcoaUE7XJX582VSXREs= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x331.google.com with SMTP id 5b1f17b1804b1-43169902057so34634495e9.0 for ; Mon, 04 Nov 2024 08:11:48 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736707; x=1731341507; 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=VSpVuDzmXkgtLCSZh3Dn4qw5j2beqEmgVGEAkKMEIEw=; b=bAjfnPb2wm1uYRLjYvaw9PW3AvuRbzIqY+HOYMg1q/eYAKdRzNuq94tJiFoA0EXNdu NPU91YDrJRcgP6SHXOXzGTm+4VtYYTkr9CZIScF1VuYcyS369KrY+Mak2nTe4h3U06tY tsZJffB209GBGZvum65rdX0GkREUEIDYGxH9/PQzd/+L+whc9MdUjzcXB3EAKxDRTRMe Mp+oV4BUg59Cm/9tbzVy5KKiqz/CvflQJ23mefJq0ORsvCbUiKenqkmDq5px6K8nNai0 YAB3ie0vWP0GD0HWyRDIotVCR5akUNDEVCVC007xappQ19zC6GVevK1SrKkwGbHAq8PZ xovA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736707; x=1731341507; 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=VSpVuDzmXkgtLCSZh3Dn4qw5j2beqEmgVGEAkKMEIEw=; b=gxkH7mdlBTbbK82OxMWZ4fXEW0YYZtlkMnR5rRNHSMtcUWiTxB9+bSOmqJWAMx6rbc FmF7DPomifn6i2L0fSU5JKUGvwMK6GU9xmHFu32LfLhqkPQvstFGLiowJpyKardw84US /2U6QoVyP+IPOVF+dbl3MfZrLclsxK4n01XUwLnKeXb2kYgwPKQ9MZiG+oA3dXyirSx3 zDH3LBhipbPEapxyzkAV6qrB+QlPFC5m2VQ+f81nvuVuSDY6E8xSM5+SYUihb2qJWe7L JVinbamelLfIJxFEkx2vnPEWqIMtHIcJZITdS/V+L0QkYEMT1c70bLT58TbvUan0Njhm Iafg== X-Gm-Message-State: AOJu0YyRltsOlRTbXh+minMkHqkjkJwNMnjoPYO0J30QRA5+E3BQ547y 29NjXLIt43KtDJf8YMgy2un34gx/hsoHom3GPOt4iO7zrPhZSqGeUQj0HWM5lJ3MPe4GoMfRRg8 = X-Google-Smtp-Source: AGHT+IHd/LEpO59JcuUNjiNTsmeAr0g09GW4vhTotkRCX/62N1Erq1sOUXKzBZXB/OPqzR82gUnPNA== X-Received: by 2002:a05:600c:3547:b0:42c:b16e:7a22 with SMTP id 5b1f17b1804b1-431bb9855c0mr191081545e9.12.1730736707297; Mon, 04 Nov 2024 08:11:47 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.46 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:46 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 27/38] ada: Remove dead code in Resolve_Iterated_Component_Association Date: Mon, 4 Nov 2024 17:11:02 +0100 Message-ID: <20241104161116.1431659-27-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou It dates back to when analysis was performed on a copy of the expression. gcc/ada/ChangeLog: * sem_aggr.adb (Resolve_Iterated_Component_Association): Move up declaration of Expr and remove dead code from older processing. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_aggr.adb | 16 +++------------- 1 file changed, 3 insertions(+), 13 deletions(-) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 63e17f480a4..9439d649f2a 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2114,8 +2114,9 @@ package body Sem_Aggr is (N : Node_Id; Index_Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Id : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + Expr : constant Node_Id := Expression (N); ----------------------- -- Remove_References -- @@ -2145,7 +2146,6 @@ package body Sem_Aggr is Choice : Node_Id; Resolution_OK : Boolean; Scop : Entity_Id; - Expr : constant Node_Id := Expression (N); -- Start of processing for Resolve_Iterated_Component_Association @@ -2234,16 +2234,6 @@ package body Sem_Aggr is end; end if; - -- An iterated_component_association may appear in a nested - -- aggregate for a multidimensional structure: preserve the bounds - -- computed for the expression, as well as the anonymous array - -- type generated for it; both are needed during array expansion. - - if Nkind (Expr) = N_Aggregate then - Set_Aggregate_Bounds (Expression (N), Aggregate_Bounds (Expr)); - Set_Etype (Expression (N), Etype (Expr)); - end if; - End_Scope; end Resolve_Iterated_Component_Association; From patchwork Mon Nov 4 16:11:03 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: 2006321 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=C6L9ueNT; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxVW0NPDz1xxW for ; Tue, 5 Nov 2024 03:18:59 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 3A76F3857000 for ; Mon, 4 Nov 2024 16:18:56 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x332.google.com (mail-wm1-x332.google.com [IPv6:2a00:1450:4864:20::332]) by sourceware.org (Postfix) with ESMTPS id 61AD83858C2B for ; Mon, 4 Nov 2024 16:11:49 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 61AD83858C2B 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 61AD83858C2B Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::332 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736740; cv=none; b=gx5h4FDjb/OQp4tQQGEMvj9zpHSttbk3TQv3UFDu3bsX5FIomlxfy5to/MiBT6pEsZXwDTwsQl5lsbLp6jyAWawwb5N1N+NsFG1XNLKnd/9HpRwrX1ST/fGM4GzS7A82ar1E6ClA19Td4XsJsH9sdtXhcKp7Hiez3175jBSSKyg= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736740; c=relaxed/simple; bh=QNWVKovK0eRWIFHxT3ZHL0LXY/DZHr9pvz1vdEQ7siU=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=LUxafIY8VhBOLOoEkXJUXVvVpt+hslejUu80aaEmLz8sIPcGhAG1djSkRi/7Gbzw+z1D05nB94GVrSMFRMWknUnJifi2Kpw8YdB6DhZKbomix1npZJu1CJd2qM3+VJ9MMMXYHb73lJuE24P93kM+GSmg0xdrMEGmooBu4WS1khg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x332.google.com with SMTP id 5b1f17b1804b1-43168d9c6c9so36133425e9.3 for ; Mon, 04 Nov 2024 08:11:49 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736708; x=1731341508; 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=sU6qHnA5jyFJDbdW3z5dHY2kQ2rOa0okvlKEAAGfGLg=; b=C6L9ueNTPRkis/RAA8tJgyLi5uBp9nyMmZUmSEueM/s6gxi4Z4Lkva9yJSP/42Gw0H nwt+J+/P46Wr5ta0oAHv9CGj9r031T4MJ7scMzRV2D2YwEy8Yg8WOQ5OB391CUmr763u 1G54eI0V2+DZgbUTAnqttl6QMp8yBUFpot1BJoRy9WK8JEyV4jIpX0wIZg4q/L1Z4CKT iSN+pVBOhq5avlB6abc3+Rhq9AhstQSCmcNhpK86Tu0YgxOrzTu8RRPhKuJ+84aP5+eF zCR5O1lISMZU4UTw/E5jzadEZWgevmdNawNWYXm4jGvT8VhYVT/tYDewzdaLT5XxSblu HubQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736708; x=1731341508; 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=sU6qHnA5jyFJDbdW3z5dHY2kQ2rOa0okvlKEAAGfGLg=; b=jXmfYYtBmYnHyq3D7mW/uVqwLJn1tbPIFdZgugzrgM3B1WMKqLL9sf1XYfmbFO/1kh 6rXPKuYpbnrQl+IlkgRHu6bGhygMnIkrkvW+v5muSHUeb7FSxuD8ESC4UaiHRHNr32Gw 41xgfGm41t+e3xt2uDU2VVOAsKlHv2R2J513CmreU7To0QdMcVhY4Iwq74dGbfkcCNNj eSl3+FBGb3tRyk+fSQVIThrOTG+//m/UMDC3o446wKYTrH/xf4lW8vIIXr7ql6eoH9yK Fy09wnYtMlEpZqMEhe6tgf/I0pdtLpmETnwnUpWQ6Wv0hezI/SUM3jh1lSkA4CLdFhMv qJTA== X-Gm-Message-State: AOJu0YwtqBRR2lTXOzcY5ycvWcNIvZmxgXvMYilGSCkrRRtbXNKo/sXs qYOVLW10xHZWwrfk4AE/DKsfcZWhhKEMMpmmirW0MmnJXkxdiRqYTruOuq4AVlUEAlLWH6Ser6s = X-Google-Smtp-Source: AGHT+IGuEV2uXBWmmJ6tLMg0Q2jeIYMHKL5TkSUPQlQHIcjT1kK8AVoBwWc9MAStKVqlO5z4N7zuRQ== X-Received: by 2002:a5d:514c:0:b0:37e:d92f:c14a with SMTP id ffacd0b85a97d-380611e4a96mr22965115f8f.42.1730736708017; Mon, 04 Nov 2024 08:11:48 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.47 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:47 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 28/38] ada: Propagate resolution status from Resolve_Iterated_Component_Association Date: Mon, 4 Nov 2024 17:11:03 +0100 Message-ID: <20241104161116.1431659-28-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou The resolution status of Resolve_Aggr_Expr is lost when the routine is invoked indirectly from Resolve_Iterated_Component_Association. gcc/ada/ChangeLog: * sem_aggr.adb (Resolve_Iterated_Component_Association): Change to function returning Boolean and return the result of the call made to Resolve_Aggr_Expr. (Resolve_Array_Aggregate): Return failure status if the call to Resolve_Iterated_Component_Association returns false. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_aggr.adb | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 9439d649f2a..b05b0b267fe 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1646,10 +1646,11 @@ package body Sem_Aggr is -- node as Expr, since there is no Expression and we need a Sloc for the -- error message. - procedure Resolve_Iterated_Component_Association + function Resolve_Iterated_Component_Association (N : Node_Id; - Index_Typ : Entity_Id); - -- For AI12-061 + Index_Typ : Entity_Id) return Boolean; + -- For AI12-061: resolves iterated component association N of Index_Typ. + -- Returns False if resolution fails. function Subtract (Val : Uint; To : Node_Id) return Node_Id; -- Creates a new expression node where Val is subtracted to expression @@ -2110,9 +2111,9 @@ package body Sem_Aggr is -- Resolve_Iterated_Component_Association -- -------------------------------------------- - procedure Resolve_Iterated_Component_Association + function Resolve_Iterated_Component_Association (N : Node_Id; - Index_Typ : Entity_Id) + Index_Typ : Entity_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); Id : constant Entity_Id := Defining_Identifier (N); @@ -2217,10 +2218,6 @@ package body Sem_Aggr is Resolution_OK := Resolve_Aggr_Expr (Expr, Single_Elmt => False); - if not Resolution_OK then - return; - end if; - if Operating_Mode /= Check_Semantics then Remove_References (Expr); declare @@ -2235,6 +2232,8 @@ package body Sem_Aggr is end if; End_Scope; + + return Resolution_OK; end Resolve_Iterated_Component_Association; -------------- @@ -2659,7 +2658,11 @@ package body Sem_Aggr is Assoc := First (Component_Associations (N)); while Present (Assoc) loop if Nkind (Assoc) = N_Iterated_Component_Association then - Resolve_Iterated_Component_Association (Assoc, Index_Typ); + if not Resolve_Iterated_Component_Association + (Assoc, Index_Typ) + then + return Failure; + end if; elsif Nkind (Assoc) /= N_Component_Association then Error_Msg_N From patchwork Mon Nov 4 16:11:04 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: 2006316 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=P9SFasC3; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxT704bhz1xxW for ; Tue, 5 Nov 2024 03:17:47 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 572D1385B519 for ; Mon, 4 Nov 2024 16:17:42 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x332.google.com (mail-wm1-x332.google.com [IPv6:2a00:1450:4864:20::332]) by sourceware.org (Postfix) with ESMTPS id 9CEF6385802C for ; Mon, 4 Nov 2024 16:11:50 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 9CEF6385802C 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 9CEF6385802C Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::332 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736745; cv=none; b=HTj4/xOqOGUZxdnJaqmvKbDcRfPCJVdoloRvR8N+OWj3B8dfY0Mf9jspcRkyV7xA2CK+0HN+GpJMb1DWPwt56eYcIslPPDukISTAvZ5areuYJfy44XZD24G84epCHCylS7kcHbhPt/MY4JgeGXoGztFkYgFcbg0GLxmJLVhru6c= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736745; c=relaxed/simple; bh=oHbNi1DszMQX86PvX7vaa2/FaSwn9yt8N7eNJcXvZv0=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=KBQPwUJKnyoDCdk9CD2GOkF+w2R6euc7EidA9lTim3CGB4TR1qyhlgZ57siu5MRK5zErSkv0Xm2GJR6DGGoOPBSfW3PlxvDLM/VmDxIh9PHuC6Jnflq2iuePU/AqKj27AgjHllCdDq5SJiOnVUWagUO1RhId0XwH7oeXYb/Saz0= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x332.google.com with SMTP id 5b1f17b1804b1-43169902057so34634755e9.0 for ; Mon, 04 Nov 2024 08:11:50 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736709; x=1731341509; 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=qH4CfQyd3uliOLk6JA2UT8J4vhHeUDICfyI86yyqnmQ=; b=P9SFasC3Ye8VzuBdyjZRU/mDqNzJrlxtg4tyBV3DWSpNn+mDMntX211urJGM6X+N9n 2SiJVtzllipJfKANI1phIfHSfHHr8/0pN1+7UHUIUdmrQGjWYNyzwMgMQIh+JzAQypxm 275KyiqW9fVwyOgoZfRmywksuLIinTsREzmU7LjJEK6vyGOh0JJWWEHTm7YJESdnV1ze oXTSTzB+bIHPPxIiTP5tD6jZB2l5kILvlqEOdP9dfATqE+pcgd86OHU7gAuQn/bsyL4k B3tUKbBD68uw+hQEFgHesulttAU8tj/BqDxCGIDZJolPczHkZJMYkWNGzDYu8DMx6kO9 L7/A== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736709; x=1731341509; 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=qH4CfQyd3uliOLk6JA2UT8J4vhHeUDICfyI86yyqnmQ=; b=niMZEapBBOViiOuVYnahYZQ0e5/JeMaDrp6SZtHLfvp7AIE7Ywn/frH7nHAT8MHsKz pmyhZyTVkdYzbMR6H3deUuDX4Evvv7T49Bqgw4DfiIGkwvf9NFt0gNKw4up5O/cly8x/ HPu6biWxVg3+3M28ipm0HXO+wQPZ/bZK/mDqoyFUpaAn+suCYF3Ohba++xD12VCLn8Zn sTSYuna1fpRRP0Z1IEuMjZA8RplSAcdoU8BoW60lbCNwd95nkIFXnFW0plgsoRpGa7j2 MHhQ+4rac8mS9Onld9m4NlklPSDdT4WKrTAaquBivCKEWkLbnqlR5eeCYhJGfMwAZMi+ 3ezA== X-Gm-Message-State: AOJu0YytB8FEBNbOSNBu50YQXUDiM0vDB/d6mAWDfQVQfKZ37+vvPqUw EgyV7yC5KzYwFe2l+kU/67tx9+jc+vOVbNHys0aXbfOidBcLDIvH4I8IRD31KNuEFv+ysjVtueA = X-Google-Smtp-Source: AGHT+IHBbqN1/U+XzZX+4N8bxgeJOk6c1eAIgVSTa8crVPRytmmO517g+Q65o96uK1DPbQ0Q+zB9OA== X-Received: by 2002:a05:600c:548c:b0:430:4db0:3fef with SMTP id 5b1f17b1804b1-431bb98f341mr169266075e9.15.1730736709268; Mon, 04 Nov 2024 08:11:49 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.48 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:48 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 29/38] ada: Fix crash on default value with nested iterated component associations Date: Mon, 4 Nov 2024 17:11:04 +0100 Message-ID: <20241104161116.1431659-29-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou The problem is that the freeze node for the type of the element ends up in the component list of the record type declared with the default value. gcc/ada/ChangeLog: PR ada/113036 * freeze.adb (Freeze_Expression): Deal with freezing actions coming from within nested internal loops present in spec expressions. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/freeze.adb | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 9a862176c30..7502a04d517 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -9055,8 +9055,9 @@ package body Freeze is or else Ekind (Current_Scope) = E_Void then declare - Freeze_Nodes : List_Id := No_List; - Pos : Int := Scope_Stack.Last; + Freeze_Nodes : List_Id := No_List; + Pos : Int := Scope_Stack.Last; + Scop : Entity_Id := Current_Scope; begin if Present (Desig_Typ) then @@ -9083,12 +9084,18 @@ package body Freeze is -- If the expression is within a top-level pragma, as for a pre- -- condition on a library-level subprogram, nothing to do. - if not Is_Compilation_Unit (Current_Scope) - and then (Is_Record_Type (Scope (Current_Scope)) - or else (Ekind (Current_Scope) in E_Block | E_Loop - and then Is_Internal (Current_Scope))) - then - Pos := Pos - 1; + if not Is_Compilation_Unit (Scop) then + if Is_Record_Type (Scope (Scop)) then + Pos := Pos - 1; + + else + while Ekind (Scop) in E_Block | E_Loop + and then Is_Internal (Scop) + loop + Pos := Pos - 1; + Scop := Scope (Scop); + end loop; + end if; end if; if Is_Non_Empty_List (Freeze_Nodes) then From patchwork Mon Nov 4 16:11:05 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: 2006325 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=aiHGkAkQ; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxWW0FZgz1xyJ for ; Tue, 5 Nov 2024 03:19:50 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 201073857704 for ; Mon, 4 Nov 2024 16:19:48 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32f.google.com (mail-wm1-x32f.google.com [IPv6:2a00:1450:4864:20::32f]) by sourceware.org (Postfix) with ESMTPS id 79ACF3857BA5 for ; Mon, 4 Nov 2024 16:11:51 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 79ACF3857BA5 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 79ACF3857BA5 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::32f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736744; cv=none; b=JG3G2aDGI5yjXOZnEhTodF5XaXGU45ksgIXzrvDMOnAlx8bfk2y6alFey64weALPGoQpybae8ijTMHXB4khrtQQyFWyvYjr07tvgBtylBWDse+8kiXV0Qsb2KW1M7aSehMsxM+ceHkS6Ywcu5PgBuN+UtMMFyHpC4GkJQ6KxlPI= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736744; c=relaxed/simple; bh=p4jlVIlL9lor+rIzEkxMSz2ma6bQqwH0Ez5m/xdtV7o=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=JEeqxcZIaLsRhMdzDFYhVW35uHe6PCqit4v8jCdV8AEOteyp3kQ6xZW//hVz4JOJBIs2i8Yo7/CMtsdPVTvDWXF2HpntpF2UTc8c5GfxzkTS//MJvx3dusNd2UuBe44hlMZREk4TWB1jtW4mcV2wForMjZbBxSpmtSAJBjWaBKE= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32f.google.com with SMTP id 5b1f17b1804b1-4315baa51d8so39147525e9.0 for ; Mon, 04 Nov 2024 08:11:51 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736710; x=1731341510; 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=0fgxZVqPBUchKr9N7rME3zvvAEEsrJ07mqwNDokivPU=; b=aiHGkAkQLjFmsbG9EJ0AlMXhHRTtwrwEmmWZxQWR/a4dwft4BdGd0ev9Jh88nV6lCN MVY/9lE5ddcSC1LLc58Uev/aAt3oeThxZqeadtU4kZUwfNFn+Ulsni/xElimqIxRBmzh IX4mWpaBWUXLH7xiFCXRdYkV4AFq25oYn/IW3ob5EolaojlUn70HTnmVCsfYhyuOeIN1 rLMsSlJ4pRdVVJaEBdkZyR5Vd1tgj2HOcDndi/L3g9QxtL0Afbqili6/F9jo+9rWhe45 pNGN2EJUxsgLL53ZeJlmNACwXik4PHUZzrZjn94HYxBWfjI/pJD0ry0sTJdwwnouXMLQ C2vQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736710; x=1731341510; 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=0fgxZVqPBUchKr9N7rME3zvvAEEsrJ07mqwNDokivPU=; b=WQ1cl6iMurFuon14zUBsPcF8xGxxPOhrRef0IArLqR9WPmQ6i7Yy4tH+6Md9ACcz/3 JoZVZam0T4GZow6vvhnhZOOZ4JJAQIZEgqed7AbxOiwxr9OMO2qGwwCG+kKUPtEfM/HH SEPR8CnEShe0ET/PrrngQWSrgg2OGlCcY0SkQ9hviYdHXtwdN624BUM/w4XvrPybrLE6 X9cJwEYsq++Dje7NhMptp04S8zkmt9QrhXTvjHlkHieO80i4M43gEdC7L8Z8nu1ouwvW 0lzMMn/pwz+4hJKheBPurIyvFZlugmmynsBn0Qvh/JXWPxXl8SQYFBFaFdtW7YGPHod+ ofzw== X-Gm-Message-State: AOJu0YyAR4ishG3sLeRTp+HDVn2Ty4VsEgN7UniiC2FIUYK50hwKODYv 03furg4zfIZFueEZxwtHEstT2I84mhkzNibYCYK61SYZcVH5Co+4XoGVcQH8Gt3zIL1lt6BEi58 = X-Google-Smtp-Source: AGHT+IEcSxm6u5NSRkl1fB5JgXkYHT3/68PWMq5sIaKIdFX6UJFapMEsaxp3XOP54x26e2Ic/nUq2w== X-Received: by 2002:a05:600c:1c93:b0:42c:b9c7:f54b with SMTP id 5b1f17b1804b1-4327b70150fmr133349425e9.16.1730736710127; Mon, 04 Nov 2024 08:11:50 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.49 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:49 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Viljar Indus Subject: [COMMITTED 30/38] ada: Avoid unused with warning with Extend_System Date: Mon, 4 Nov 2024 17:11:05 +0100 Message-ID: <20241104161116.1431659-30-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Viljar Indus When the Extend_System pragma is used then we are supposed to check the extended system for referenced entities. Otherwise we would get an incorrect unused with warning. This was previously done on body files but it should also be done specs as well. gcc/ada/ChangeLog: * sem_warn.adb (Check_One_Unit): When a system extension is present always check entities from that unit before marking the unit unreferenced. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_warn.adb | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 69e60be2966..2ffd631d628 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -2583,14 +2583,17 @@ package body Sem_Warn is if No (Ent) then + -- Check entities in the extended system if + -- specified. + + if Check_System_Aux (Lunit) then + null; + -- If in spec, just set the flag - if Unit = Spec_Unit then + elsif Unit = Spec_Unit then Set_No_Entities_Ref_In_Spec (Item); - elsif Check_System_Aux (Lunit) then - null; - -- Else the warning may be needed else From patchwork Mon Nov 4 16:11:06 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: 2006327 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=P3Iig859; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxXQ36DXz1xxN for ; Tue, 5 Nov 2024 03:20:38 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 79E4F3857002 for ; Mon, 4 Nov 2024 16:20:36 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lf1-x134.google.com (mail-lf1-x134.google.com [IPv6:2a00:1450:4864:20::134]) by sourceware.org (Postfix) with ESMTPS id CA65B3857400 for ; Mon, 4 Nov 2024 16:11:52 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org CA65B3857400 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 CA65B3857400 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::134 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736750; cv=none; b=ocO8YOXkF/+9P/tBU236X3AlfPiBu9/sv5xzZCU/ryUPne6lWdV/Ed56Qwc/pqSC1lYHBJThilSjQcRxH7D/RO/XHngGK8TnzdOxfjiXzPuog6lNf9vQDzIPwFi7AiaJC/a6hHmM/a3dF6FLE45NHsPzmHHtx3CjGRxcYS4qFdU= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736750; c=relaxed/simple; bh=hC5LL98TJVf3j+B4Ku8KwCpJQOmXkmavN3TzlWFvSMI=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=FvW5ceSZE8bM4wULr36f4LPfyAsASDctnAYwpFqcH4txX0DFU74YqggO5MUXls1adFebuBbvusuCkOeSlAogt23MD3mTqf2eBK3qwnY5Ij+L2U2sKpKBmq8SZoTI4RCa+J5sYKK5ERvZTBavFYvELUD6eknUNoKuT1/3vVvAyFg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-lf1-x134.google.com with SMTP id 2adb3069b0e04-539f1292a9bso4976865e87.2 for ; Mon, 04 Nov 2024 08:11:52 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736711; x=1731341511; 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=SbkQVIYlDyQm+pjZiAou7tHXxvmROoGSBIdYXbigGEg=; b=P3Iig859H+W3wtqWgM/pyjCWFQbiJIyqugvAr41zD/3E8WXTWfmZo58EKZymqWHc0o BC/4jGHxHx0LnrbCnldZdP7dZnq+UlPfGo+n6fVEWTPruL95O88p4MeycaV9IamiRBrN /VGfPEAK88ZIqSaGGy3K07ZlZHHYOmQIKU+r5eVgaFIjvqUvugZeOIEsj6GJ/TA9i6jV uGpjTd5N1ZtxRW6orSJ+EPQHNfsABZonx92TDkHwVIr4ZYO1tJeDsWsx2a9Mq4XsQO9z l/DoeAqIbiVELP05+CC0rpfimAPjUGMZ2+/3q2+ggnB6F/GXEOcC2RmQkaAd6tQS/8oa kgLQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736711; x=1731341511; 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=SbkQVIYlDyQm+pjZiAou7tHXxvmROoGSBIdYXbigGEg=; b=NRn1e6XPEyf7fc0ZhQAsMt/ac/Tw6jnwKiXiVAxDRUprRsMmUzbhyUnLrhMYxFleKZ HP2puGoLxn/b1OtF926jP9Yfmz66jziRsMUKLhH0eNF4EqVq/cjXK4yx8p4A256HrJe3 ul/pupjZlt6NdN50XBQsWNT6a62Eg+3f1GjvpAV+2rzA7A/wCxSa0A1sYFnzjyt7Ne6p sQlyk8jdvCQlaSllbG4aknwPPboGlgHXQi/ZlibOJee4EchxNfoHUOruhh7kZcS8sIqO oUTyjjFPfoDXwh1kx5YbN2Wm+/pND5veeYA61TUt9UTIVpwNoPYjNqJpIQgRBLbCcECz gUQQ== X-Gm-Message-State: AOJu0YyM5H1g2djMgFGgVX+govBkP5/jEGNyRiI5ztnGi3wB6f+4ihc+ Wfphhe6EIfOYPKeVEQmBID0jYDFBkO4x98z67nMGyJv9l3tiFXOvOkYgsDjH1dMFrJLu8kBJNZw = X-Google-Smtp-Source: AGHT+IH+CTgqyHz3vQUZN2WnVo1z4ITPVRfnPFGd9nCGgtkuSPz4iyzQc/0LwhxQHlLKfMa3Dwp0kQ== X-Received: by 2002:a05:651c:119b:b0:2f3:f358:8657 with SMTP id 38308e7fff4ca-2fcbe095cfbmr107047261fa.44.1730736710960; Mon, 04 Nov 2024 08:11:50 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.50 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:50 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Steve Baird Subject: [COMMITTED 31/38] ada: Initial implementation of Extended_Access aspect (FE portion only) Date: Mon, 4 Nov 2024 17:11:06 +0100 Message-ID: <20241104161116.1431659-31-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Steve Baird The Extended_Access aspect can be specified to be True for certain access-to-unconstrained-array-subtype types. Such extended access types can designate objects that a normal general access type (with the same designated subtype) cannot, such as a slice of an aliased array object or an object that is represented without contiguous bounds information. gcc/ada/ChangeLog: * aspects.ads: Add Aspect_Extended_Access to Aspect_Id enumeration. * par-prag.adb: Add Pragma_Extended_Access to list of pragmas that get no interesting processing in the parser. * sem_attr.adb: Relax legality checks on Access/Unchecked_Access attribute references if access type is Extended_Access. * sem_ch12.adb (Validate_Access_Type_Instance): For an instance of a generic with a formal access type, check that formal and actual agree with with respect to Extended_Access aspect. * sem_prag.adb (Analyze_Pragma): Add analysis code for pragma Extended_Access. Set Pragma_Extended_Access element in Sig_Flags aggregate. * sem_prag.ads: Set Pragma_Extended_Access element in Aspect_Specifying_Pragma aggregate. * sem_res.adb (Valid_Conversion): Disallow extended-to-not-extended access conversion. * sem_util.adb (Is_Extended_Access_Access_Type): Implement new function. (Is_Aliased_View): If (and only if) the new Boolean For_Extended parameter is True, then a slice of an aliased non-bitpacked array is aliased, a constrained nominal subtype does not force a result of False, and a dereference of an extended access value is aliased. The last point is somewhat subtle. This is how we prevent covert fat-to-nonfat type conversions via things like "Not_Extended_Type'(Extended_Ptr.all'Access)" or passing Extended_Ptr.all as an actual parameter corresponding to an explicitly aliased formal parameter. * sem_util.ads (Is_Extended_Access_Type): Declare new function. (Is_Aliased_View): Add new defaults-False parameter For_Extended. * snames.ads-tmpl: Declare Name_Extended_Access Name_Id constant and Pragma_Extended_Access Pragma_Id enumeration literal. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/aspects.ads | 5 +++ gcc/ada/par-prag.adb | 1 + gcc/ada/sem_attr.adb | 10 +++++- gcc/ada/sem_ch12.adb | 16 +++++++++ gcc/ada/sem_prag.adb | 74 ++++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_prag.ads | 1 + gcc/ada/sem_res.adb | 32 ++++++++++++++++++ gcc/ada/sem_util.adb | 57 +++++++++++++++++++++++++++++-- gcc/ada/sem_util.ads | 11 +++++- gcc/ada/snames.ads-tmpl | 2 ++ 10 files changed, 204 insertions(+), 5 deletions(-) diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 2a5e0f21601..ebf09602ea5 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -197,6 +197,7 @@ package Aspects is Aspect_Effective_Writes, -- GNAT Aspect_Exclusive_Functions, Aspect_Export, + Aspect_Extended_Access, -- GNAT Aspect_Extensions_Visible, -- GNAT Aspect_Favor_Top_Level, -- GNAT Aspect_First_Controlling_Parameter, -- GNAT @@ -293,6 +294,7 @@ package Aspects is Aspect_Effective_Reads => True, Aspect_Effective_Writes => True, Aspect_Exceptional_Cases => True, + Aspect_Extended_Access => True, Aspect_Extensions_Visible => True, Aspect_External_Initialization => True, Aspect_Favor_Top_Level => True, @@ -539,6 +541,7 @@ package Aspects is Aspect_Dynamic_Predicate => False, Aspect_Exceptional_Cases => False, Aspect_Exclusive_Functions => False, + Aspect_Extended_Access => True, Aspect_External_Initialization => False, Aspect_External_Name => False, Aspect_External_Tag => False, @@ -714,6 +717,7 @@ package Aspects is Aspect_Exceptional_Cases => Name_Exceptional_Cases, Aspect_Exclusive_Functions => Name_Exclusive_Functions, Aspect_Export => Name_Export, + Aspect_Extended_Access => Name_Extended_Access, Aspect_Extensions_Visible => Name_Extensions_Visible, Aspect_External_Initialization => Name_External_Initialization, Aspect_External_Name => Name_External_Name, @@ -1095,6 +1099,7 @@ package Aspects is Aspect_Atomic_Components => Rep_Aspect, Aspect_Bit_Order => Rep_Aspect, Aspect_Component_Size => Rep_Aspect, + Aspect_Extended_Access => Rep_Aspect, Aspect_Full_Access_Only => Rep_Aspect, Aspect_Machine_Radix => Rep_Aspect, Aspect_Object_Size => Rep_Aspect, diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 8b953b3e877..1a2a7b6b77b 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1442,6 +1442,7 @@ begin | Pragma_Export_Procedure | Pragma_Export_Valued_Procedure | Pragma_Extend_System + | Pragma_Extended_Access | Pragma_Extensions_Visible | Pragma_External | Pragma_External_Name_Casing diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 9ab197299ba..4e06ec54978 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11922,6 +11922,12 @@ package body Sem_Attr is then null; + -- Nominal subtype static matching requirement does not apply + -- for an extended access type. + + elsif Is_Extended_Access_Type (Typ) then + null; + else Error_Msg_F ("object subtype must statically match " @@ -12127,7 +12133,9 @@ package body Sem_Attr is and then not (Nkind (P) = N_Selected_Component and then Is_Overloadable (Entity (Selector_Name (P)))) - and then not Is_Aliased_View (Original_Node (P)) + and then not Is_Aliased_View + (Original_Node (P), + For_Extended => Is_Extended_Access_Type (Btyp)) and then not In_Instance and then not In_Inlined_Body and then Comes_From_Source (N) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3bc533a30de..3ef4e698e81 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -13974,6 +13974,22 @@ package body Sem_Ch12 is ("non null exclusion of actual and formal & do not match", Actual, Gen_T); end if; + + -- formal/actual extended access match required (regardless of + -- whether a formal extended access type is currently possible) + + if Is_Extended_Access_Type (Act_T) + /= Is_Extended_Access_Type (A_Gen_T) + then + Error_Msg_N + ("actual type must" & + String'(if Is_Extended_Access_Type (A_Gen_T) + then "" + else " not") & + " be extended access type", Actual); + + Abandon_Instantiation (Actual); + end if; end Validate_Access_Type_Instance; ---------------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9a3e7acf34f..eb11ceb7044 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -90,7 +90,7 @@ with Stylesw; use Stylesw; with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; -with Ttypes; +with Ttypes; use Ttypes; with Uintp; use Uintp; with Uname; use Uname; with Urealp; use Urealp; @@ -17459,6 +17459,77 @@ package body Sem_Prag is Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); end if; + --------------------- + -- Extended_Access -- + --------------------- + + -- pragma Extended_Access (first_subtype_LOCAL_NAME); + + when Pragma_Extended_Access => Extended_Access : declare + Assoc : constant Node_Id := Arg1; + Typ : Entity_Id; + Type_Id : Node_Id; + + begin + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + Type_Id := Get_Pragma_Arg (Assoc); + + if not Is_Entity_Name (Type_Id) + or else not Is_Type (Entity (Type_Id)) + then + Error_Pragma_Arg + ("argument for pragma% must be type or subtype", Arg1); + end if; + + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type + or else Rep_Item_Too_Early (Typ, N) + then + return; + else + Typ := Underlying_Type (Typ); + end if; + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Ghost_Pragma (N, Typ); + + if Ekind (Typ) = E_Access_Subtype then + Error_Pragma + ("pragma% not specifiable for subtype"); + elsif Ekind (Typ) /= E_General_Access_Type then + Error_Pragma + ("pragma% only specifiable for general access type"); + elsif Is_Derived_Type (Typ) then + Error_Pragma + ("pragma% not specifiable for derived type"); + else + declare + Designated : constant Entity_Id := Designated_Type (Typ); + begin + if not (Is_Array_Type (Designated)) + or else Is_Constrained (Designated) + then + Error_Pragma + ("pragma% only specifiable for access type" & + " having unconstrained array designated subtype"); + end if; + end; + end if; + + Check_First_Subtype (Arg1); + Check_Duplicate_Pragma (Typ); + + if Rep_Item_Too_Late (Typ, N) then + return; + end if; + end Extended_Access; + ------------------------ -- Extensions_Allowed -- ------------------------ @@ -32963,6 +33034,7 @@ package body Sem_Prag is Pragma_Export_Procedure => -1, Pragma_Export_Valued_Procedure => -1, Pragma_Extend_System => -1, + Pragma_Extended_Access => 0, Pragma_Extensions_Allowed => 0, Pragma_Extensions_Visible => 0, Pragma_External => -1, diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 48a16038f38..e26583d1111 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -62,6 +62,7 @@ package Sem_Prag is Pragma_Elaborate_Body => True, Pragma_Exceptional_Cases => True, Pragma_Export => True, + Pragma_Extended_Access => True, Pragma_Extensions_Visible => True, Pragma_Favor_Top_Level => True, Pragma_First_Controlling_Parameter => True, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index d28e724e882..658f9eb2b72 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -14428,6 +14428,37 @@ package body Sem_Res is return False; end if; + declare + Extended_Opnd : constant Boolean := + Is_Extended_Access_Type (Opnd_Type); + Extended_Target : constant Boolean := + Is_Extended_Access_Type (Target_Type); + begin + -- An extended access value may designate objects that are + -- impossible to reference using a non-extended type, so + -- prohibit conversions that would require being able to + -- do the impossible. + + if Extended_Opnd then + if not Extended_Target then + Conversion_Error_N + ("cannot convert extended access value" + & " to non-extended access type", + Operand); + return False; + end if; + + -- Detect bad conversion on copy back for a view conversion + + elsif Extended_Target and then Is_View_Conversion (N) then + Conversion_Error_N + ("cannot convert non-extended value" + & " to extended access type in view conversion", + Operand); + return False; + end if; + end; + -- Check the static accessibility rule of 4.6(17). Note that the -- check is not enforced when within an instance body, since the RM -- requires such cases to be caught at run time. @@ -14476,6 +14507,7 @@ package body Sem_Res is then Conversion_Error_N ("operand has deeper level than target", Operand); + return False; end if; -- Implicit conversions aren't allowed for objects of an diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5d3a4e68c84..1a512219e59 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12356,6 +12356,27 @@ package body Sem_Util is and then not Is_Record_Aggregate; end Is_Container_Aggregate; + ----------------------------- + -- Is_Extended_Access_Type -- + ----------------------------- + + function Is_Extended_Access_Type (Ent : Entity_Id) return Boolean is + Btype : constant Entity_Id := Available_View (Base_Type (Ent)); + begin + if Has_Aspect (Btype, Aspect_Extended_Access) then + declare + Aspect_Expr : constant Node_Id := + Expression (Find_Aspect (Btype, Aspect_Extended_Access)); + begin + return No (Aspect_Expr) or else Expr_Value (Aspect_Expr) /= 0; + end; + elsif Is_Derived_Type (Btype) then + return Is_Extended_Access_Type (Etype (Btype)); + else + return False; + end if; + end Is_Extended_Access_Type; + --------------------------------- -- Side_Effect_Free_Statements -- --------------------------------- @@ -15153,9 +15174,18 @@ package body Sem_Util is -- Is_Aliased_View -- --------------------- - function Is_Aliased_View (Obj : Node_Id) return Boolean is + function Is_Aliased_View + (Obj : Node_Id; For_Extended : Boolean := False) return Boolean + is E : Entity_Id; + -- Ensure that For_Extended parameter is propagated in recursive + -- calls by hiding the version that has the wrong default. + + function Is_Aliased_View + (Obj : Node_Id; For_SF : Boolean := For_Extended) return Boolean + renames Sem_Util.Is_Aliased_View; + begin if Is_Entity_Name (Obj) then E := Entity (Obj); @@ -15236,11 +15266,34 @@ package body Sem_Util is -- rewritten constructs that introduce artificial dereferences. elsif Nkind (Obj) = N_Explicit_Dereference then + -- If For_Extended is False then a dereference of an extended access + -- value is, by definition, not aliased. + -- This is to prevent covert illegal type conversion via either + -- Not_Extended_Type'(Extended_Ptr.all'Access) + -- or by passing Extended_Ptr.all as an actual parameter + -- corresponding to an explicitly aliased formal parameter + -- (which would allow the callee to evaluate Aliased_Param'Access). + + if Is_Extended_Access_Type (Etype (Prefix (Obj))) + and then not For_Extended + then + return False; + end if; + return not Is_Captured_Function_Call (Obj) and then not (Nkind (Parent (Obj)) = N_Object_Renaming_Declaration and then Is_Return_Object (Defining_Entity (Parent (Obj)))); + elsif Nkind (Obj) = N_Slice then + -- A slice of a bit-packed array is not considered aliased even + -- for an extended access type because even extended access types + -- don't support bit pointers. + + return For_Extended + and then Is_Aliased_View (Prefix (Obj)) + and then not Is_Bit_Packed_Array (Etype (Obj)); + else return False; end if; @@ -15668,7 +15721,7 @@ package body Sem_Util is Expression (Item_2)); end; - -- A confirming aspect for Implicit_Derenfence on a derived type + -- A confirming aspect for Implicit_Dereference on a derived type -- has already been checked in Analyze_Aspect_Implicit_Dereference, -- including the presence of renamed discriminants. diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index cefc8e8f688..289d601ec88 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1460,6 +1460,11 @@ package Sem_Util is function Is_Container_Aggregate (Exp : Node_Id) return Boolean; -- Is the given expression a container aggregate? + function Is_Extended_Access_Type (Ent : Entity_Id) return Boolean; + -- Ent is any entity. Returns True if Ent is a type (or a subtype thereof) + -- for which the Extended_Access aspect has been specified, either + -- explicitly or by inheritance. + function Is_Function_With_Side_Effects (Subp : Entity_Id) return Boolean; -- Return True if Subp is a function with side effects, ie. it has a -- (direct or inherited) pragma Side_Effects with static value True. @@ -1768,7 +1773,8 @@ package Sem_Util is function Is_Actual_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter in a subprogram or entry call - function Is_Aliased_View (Obj : Node_Id) return Boolean; + function Is_Aliased_View + (Obj : Node_Id; For_Extended : Boolean := False) return Boolean; -- Determine if Obj is an aliased view, i.e. the name of an object to which -- 'Access or 'Unchecked_Access can apply. Note that this routine uses the -- rules of the language, it does not take into account the restriction @@ -1776,6 +1782,9 @@ package Sem_Util is -- and Obj violates the restriction. The caller is responsible for calling -- Restrict.Check_No_Implicit_Aliasing if True is returned, but there is a -- requirement for obeying the restriction in the call context. + -- If For_Extended is True, then slightly different rules apply (as per + -- the definition of the Extended_Access aspect); for example, a slice + -- of an aliased array is considered to be aliased. function Is_Ancestor_Package (E1 : Entity_Id; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index b706896073f..3281b6f12f8 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -565,6 +565,7 @@ package Snames is Name_Export_Object : constant Name_Id := N + $; -- GNAT Name_Export_Procedure : constant Name_Id := N + $; -- GNAT Name_Export_Valued_Procedure : constant Name_Id := N + $; -- GNAT + Name_Extended_Access : constant Name_Id := N + $; -- GNAT Name_Extensions_Visible : constant Name_Id := N + $; -- GNAT Name_External : constant Name_Id := N + $; -- GNAT Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT @@ -1870,6 +1871,7 @@ package Snames is Pragma_Export_Object, Pragma_Export_Procedure, Pragma_Export_Valued_Procedure, + Pragma_Extended_Access, Pragma_Extensions_Visible, Pragma_External, Pragma_Finalize_Storage_Only, From patchwork Mon Nov 4 16:11:07 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: 2006319 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=Lh4Md+ya; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxV03TfDz1xxW for ; Tue, 5 Nov 2024 03:18:32 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 607893857001 for ; Mon, 4 Nov 2024 16:18:30 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32d.google.com (mail-wm1-x32d.google.com [IPv6:2a00:1450:4864:20::32d]) by sourceware.org (Postfix) with ESMTPS id 2BD913857374 for ; Mon, 4 Nov 2024 16:11:53 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2BD913857374 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 2BD913857374 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::32d ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736749; cv=none; b=DNRutIgh8vH1iUy8kI/wNBFrqKZ1PbRrnlmHUeZP4LOfIlIUfQ0nBGPnjKPTAlaRR3eeKsmBIJ+Q4G+XjW2y47KByXZxTSpjhTM09F/aJ/qcZZQvUukTusY+8x6R1Wipb/2AdYesOt6/FTrqNOMLFG2HB5lykwotV3S1M9rh7uA= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736749; c=relaxed/simple; bh=8Pfe/u9GfkRGVM4PvTLu7TlSxUfEA8Fz+WRQZS//lKQ=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=EQiTvYisluCnCqtsDTK0KTz36igL8qGhqpqB5by+g2YkaUWE7llaqDhyzGHkOO8u6UiHhAg/84s9jAfoXlSDNfoS9qSJf5MrnZIbKyi09fa+T66rdyQYJi8JcHZpWQav58FsPj0ShogOVO66XmI+woc+zZVlOQEkGT68d/35XbA= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32d.google.com with SMTP id 5b1f17b1804b1-43155afca99so32436955e9.1 for ; Mon, 04 Nov 2024 08:11:53 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736712; x=1731341512; 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=CanoitEuan7nZ7zXtvGLz59fFXX3oXIfY7Jtkfkywbs=; b=Lh4Md+yaZyq9cjRKGzsdx/sSv80i3BU0ULMQPy9MJqlVxqkqiUdZEzsKWpo7znQHzU gqJU3vwDbJet3wUCZUaVmwgTd7cH/vxkSEQzuPvOEvbiN3g0EyK3z6QZhrDDGAU7iqrv Yqbfl32lsxtIRUqGXmfLCFcL4aWWhOn/izKNZEq75BEBm8ilbD4B+1k82LRzVWjAhmOS lF7JW2nEpwYaTLOS0WwBU3Ca9uTMCcz8fsAYXHbER2stwslC9AJK7gKpuISSW0WuSoIU gcsjRiGNPROTP96reMFytJjAtC1cK0/mo6NVNwAq/7jeawVe7eoKOZHY9NL+TqieFiD9 hRCw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736712; x=1731341512; 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=CanoitEuan7nZ7zXtvGLz59fFXX3oXIfY7Jtkfkywbs=; b=W8akbq2joH+Wr3dvWmpgA28kWsYotYN0NCbpBbEGFNwRaEcNTXDJ9z/073mbypuGFy n3xBriHGKKPRECPoqGqR7IorbuyUvQrC4Lp0VVLJSRG7Qz4PVKGYVTSRRwMQPC6YV7E8 /904R++LWtWgK2cwMpw8U4N8BD1Wcp5QGg3jLkymbYrxYgU8t5OGk/ttk0i3X3HTR7fO jKyEb8m3wTC7KRzISj2VjyW94PqVMveiwdZHVr7J6KLjd0e2UM1POcEPHbkwWW0pg4U0 B+viU3ijg/iJwoYEw4EKbS8v8QL0I1CIB7IsO/wm9QJJsW7ETFtpgGCBVLd1dhX/AgmB Lqhw== X-Gm-Message-State: AOJu0YxBRO3wT1ODoASgb0hGf62fcBhp+yVj/gjztUNMP1JQpXPG9ADk XAWG2kGtqs6gzrpvweVY1E4GgleMv0UKdwr6aR3ErLxcxlSexB+9YKeGeDduViWpJE+K8DdvYYo = X-Google-Smtp-Source: AGHT+IFgrL7FEL2VOL3WvEsDUeddbsoCCYEyAQzlBGmWRiqmswNZVBX1k4sSsDy6V8hHiZTDYhRGjg== X-Received: by 2002:a5d:5f93:0:b0:371:6fc7:d45d with SMTP id ffacd0b85a97d-381c13069b6mr14556027f8f.2.1730736711772; Mon, 04 Nov 2024 08:11:51 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.51 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:51 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Nicolas Roche Subject: [COMMITTED 32/38] ada: Improve Unbounded_String performance Date: Mon, 4 Nov 2024 17:11:07 +0100 Message-ID: <20241104161116.1431659-32-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Nicolas Roche Improve performance of iteration using Element function. Improve performance of Append. gcc/ada/ChangeLog: * libgnat/a-strunb__shared.adb: Restructure code to inline only the most common cases. Remove whenever possible runtime checks. * libgnat/a-strunb__shared.ads: Add Inline => True to Append variants and Element. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-strunb__shared.adb | 165 ++++++++++++++++++++------- gcc/ada/libgnat/a-strunb__shared.ads | 18 ++- 2 files changed, 134 insertions(+), 49 deletions(-) diff --git a/gcc/ada/libgnat/a-strunb__shared.adb b/gcc/ada/libgnat/a-strunb__shared.adb index ef4f8c93bdb..2f0ae3a1c92 100644 --- a/gcc/ada/libgnat/a-strunb__shared.adb +++ b/gcc/ada/libgnat/a-strunb__shared.adb @@ -35,6 +35,23 @@ package body Ada.Strings.Unbounded is use Ada.Strings.Maps; + procedure Non_Inlined_Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String); + + procedure Non_Inlined_Append + (Source : in out Unbounded_String; + New_Item : String); + + procedure Non_Inlined_Append + (Source : in out Unbounded_String; + New_Item : Character); + -- Non_Inlined_Append are part of the respective Append method that + -- should not be inlined. The idea is that the code of Append is inlined. + -- In order to make inlining efficient it is better to have the inlined + -- code as small as possible. Thus most common cases are inlined and less + -- common cases are deferred in these functions. + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By @@ -542,10 +559,12 @@ package body Ada.Strings.Unbounded is (Source : in out Unbounded_String; New_Item : Unbounded_String) is + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + SR : constant Shared_String_Access := Source.Reference; NR : constant Shared_String_Access := New_Item.Reference; - DL : constant Natural := Sum (SR.Last, NR.Last); - DR : Shared_String_Access; begin -- Source is an empty string, reuse New_Item data @@ -562,19 +581,17 @@ package body Ada.Strings.Unbounded is -- Try to reuse existing shared string - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; + elsif System.Atomic_Counters.Is_One (SR.Counter) + and then NR.Last <= SR.Max_Length + and then SR.Max_Length - NR.Last >= SR.Last + then + SR.Data (SR.Last + 1 .. SR.Last + NR.Last) := NR.Data (1 .. NR.Last); + SR.Last := SR.Last + NR.Last; -- Otherwise, allocate new one and fill it else - DR := Allocate (DL, DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -582,31 +599,34 @@ package body Ada.Strings.Unbounded is (Source : in out Unbounded_String; New_Item : String) is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := Sum (SR.Last, New_Item'Length); - DR : Shared_String_Access; + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + New_Item_Length : constant Natural := New_Item'Length; + SR : constant Shared_String_Access := Source.Reference; begin - -- New_Item is an empty string, nothing to do if New_Item'Length = 0 then + -- New_Item is an empty string, nothing to do null; - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it + elsif System.Atomic_Counters.Is_One (SR.Counter) + -- The following test checks in fact that + -- SR.Max_Length >= SR.Last + New_Item_Length without causing + -- overflow. + and then New_Item_Length <= SR.Max_Length + and then SR.Max_Length - New_Item_Length >= SR.Last + then + -- Try to reuse existing shared string + SR.Data (SR.Last + 1 .. SR.Last + New_Item_Length) := New_Item; + SR.Last := SR.Last + New_Item_Length; else - DR := Allocate (DL, DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + -- Otherwise, allocate new one and fill it. Deferring the worst case + -- into a separate non-inlined function ensure that inlined Append + -- code size remains short and thus efficient. + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -614,26 +634,24 @@ package body Ada.Strings.Unbounded is (Source : in out Unbounded_String; New_Item : Character) is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := Sum (SR.Last, 1); - DR : Shared_String_Access; + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + SR : constant Shared_String_Access := Source.Reference; begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, DL) then + if System.Atomic_Counters.Is_One (SR.Counter) + and then SR.Max_Length > SR.Last + then + -- Try to reuse existing shared string SR.Data (SR.Last + 1) := New_Item; SR.Last := SR.Last + 1; - -- Otherwise, allocate new one and fill it - else - DR := Allocate (DL, DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + -- Otherwise, allocate new one and fill it. Deferring the worst case + -- into a separate non-inlined function ensure that inlined Append + -- code size remains short and thus efficient. + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -801,9 +819,10 @@ package body Ada.Strings.Unbounded is (Source : Unbounded_String; Index : Positive) return Character is + pragma Suppress (All_Checks); SR : constant Shared_String_Access := Source.Reference; begin - if Index <= SR.Last then + if Index <= SR.Last and then Index > 0 then return SR.Data (Index); else raise Index_Error; @@ -1215,6 +1234,66 @@ package body Ada.Strings.Unbounded is return Left * Right; end Mul; + ------------------------ + -- Non_Inlined_Append -- + ------------------------ + + procedure Non_Inlined_Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String) + is + SR : constant Shared_String_Access := Source.Reference; + NR : constant Shared_String_Access := New_Item.Reference; + DL : constant Natural := Sum (SR.Last, NR.Last); + DR : Shared_String_Access; + begin + DR := Allocate (DL, DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end Non_Inlined_Append; + + procedure Non_Inlined_Append + (Source : in out Unbounded_String; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := Sum (SR.Last, New_Item'Length); + DR : Shared_String_Access; + begin + DR := Allocate (DL, DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end Non_Inlined_Append; + + procedure Non_Inlined_Append + (Source : in out Unbounded_String; + New_Item : Character) + is + SR : constant Shared_String_Access := Source.Reference; + begin + if SR.Last = Natural'Last then + raise Constraint_Error; + else + declare + DL : constant Natural := SR.Last + 1; + DR : Shared_String_Access; + begin + DR := Allocate (DL, DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end; + end if; + end Non_Inlined_Append; + --------------- -- Overwrite -- --------------- diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads index fa97680a7fa..d81c66b9f0a 100644 --- a/gcc/ada/libgnat/a-strunb__shared.ads +++ b/gcc/ada/libgnat/a-strunb__shared.ads @@ -153,7 +153,8 @@ is Pre => Length (New_Item) <= Natural'Last - Length (Source), Post => To_String (Source) = To_String (Source)'Old & To_String (New_Item), - Global => null; + Global => null, + Inline => True; procedure Append (Source : in out Unbounded_String; @@ -161,7 +162,8 @@ is with Pre => New_Item'Length <= Natural'Last - Length (Source), Post => To_String (Source) = To_String (Source)'Old & New_Item, - Global => null; + Global => null, + Inline => True; procedure Append (Source : in out Unbounded_String; @@ -169,7 +171,8 @@ is with Pre => Length (Source) < Natural'Last, Post => To_String (Source) = To_String (Source)'Old & New_Item, - Global => null; + Global => null, + Inline => True; function "&" (Left : Unbounded_String; @@ -217,7 +220,8 @@ is with Pre => Index <= Length (Source), Post => Element'Result = To_String (Source) (Index), - Global => null; + Global => null, + Inline => True; procedure Replace_Element (Source : in out Unbounded_String; @@ -1578,11 +1582,13 @@ private type Shared_String_Access is access all Shared_String; - procedure Reference (Item : not null Shared_String_Access); + procedure Reference (Item : not null Shared_String_Access) + with Inline => True; -- Increment reference counter. -- Do nothing if Item points to Empty_Shared_String. - procedure Unreference (Item : not null Shared_String_Access); + procedure Unreference (Item : not null Shared_String_Access) + with Inline => True; -- Decrement reference counter, deallocate Item when counter goes to zero. -- Do nothing if Item points to Empty_Shared_String. From patchwork Mon Nov 4 16:11:08 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: 2006328 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=dGt6q4gT; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxXn4yX0z1xxN for ; Tue, 5 Nov 2024 03:20:57 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 6A21F3857723 for ; Mon, 4 Nov 2024 16:20:55 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42f.google.com (mail-wr1-x42f.google.com [IPv6:2a00:1450:4864:20::42f]) by sourceware.org (Postfix) with ESMTPS id F3B4E3858415 for ; Mon, 4 Nov 2024 16:11:53 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org F3B4E3858415 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 F3B4E3858415 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736759; cv=none; b=qac/37mbDMHn2tpEWjMAdzy2e1+MCGkXQMreepHfVdcYkH27t/eXVv+rNydUbLJuU6U8mc9pirQEueLOfUAObDZGbKUGOHHwqv3qSKgiUw1rg56wuj6GU/ZnAkF5/+X3A7B88Ru1ZjbDOs1AZPKo8uocV/AXlhFSaVkzjoYT7vI= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736759; c=relaxed/simple; bh=PlPUx/Z6xuu0R9KgJS7GMquYMIjVQd24Lb54d4ncXQQ=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=HJqAEyGCVNvzTTylLfTEd4ki5X0eXph4qhhZYf9QVMJl/wvcd+WLLyNWkd4ToewmQpwJC/wCrk+4G61XnnWmYX5vaCM4pfWhnC9zhCe8BKYSm9bY9vmQMu90pLaAUP6tz+SL2ZbhNIt4gtg992cqRiVN+POYWpNBdTF6I2IhvIk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42f.google.com with SMTP id ffacd0b85a97d-37d43a9bc03so2992003f8f.2 for ; Mon, 04 Nov 2024 08:11:53 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736713; x=1731341513; 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=PT0LaTErCUBpXm9E3bn4pEv7sa1jD7UeSC6bVzjxAx8=; b=dGt6q4gTettovtyUL57k5p/AcznjXSDAPH5QIXAP9gLJH2BPN7whncnlzRJBDqHaMp DuaX2eXMg47nVniwVBZsUpmCIipBwQw/ucZvxBxBH5/H5T5obDFWS+oyYK0kWG0dKIx+ wjTc362KiCAnC3Lfro4UgTerFRaY+ZzilwQiyOBpqX057FUJ5hN9ZlSAVYzcGALEgFO6 PZ049h0OBoDzvQNCKRMNEqj+fz0n5vXpNeDK0DQz+U4VcKX2UCXbBkZo2Li8fy3QgTxK +4wtHiIBG0ZcT3S+j7G5EwaIhYawwHH5mpXCud8g92R7hxiVWzz47+DYZsJ1kVVjP1Tw Ouqg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736713; x=1731341513; 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=PT0LaTErCUBpXm9E3bn4pEv7sa1jD7UeSC6bVzjxAx8=; b=EJncAxc4GauVZzcKYym9Pg9oPDwuZciZ+QnBKciunl9GP2Ikz/Fjfwr+5vhW9xBzdJ avotbqHddw4JAzLJa0jhyx7FGvm2joCb2rgq2UEauopeveo9DvL5DOzg1Aoh9Y6pGO/E 8aydusvL7hm0VWcXikhCraGTgJeENv1XN5/dOoY6Od10gsJHwOJyyE7/m8TrXe/VzsBE ROXMn6+lfNsvoCq3Zzrwc3/AzowS72D1mPgq81LE5VeD+2ArtQWtwreivxGN6GocnerJ Orq3SAQO8rLCxbj+PkuKdarAcyDwgg9wIboSi5oM0wieZW/CVew66fMf0O9BV1kXmPr5 6e3Q== X-Gm-Message-State: AOJu0YznpawxrGKlcCqfHdsEpax9Dzy7Om3l0H+VFfZsYGS+Fl0BU0vU SHvYbVGWqMhS+QTKmQ2LrnW4YdwppxBhK0t69HfCErKMbh2lPgILvIG0p2y1qE2u6MC7EWtD6NU = X-Google-Smtp-Source: AGHT+IGBa8wRW8Wj3MqhoNjE5bW1E4sYlqS5m921BN6W2hbDV32HvhDblGLG+PxXXn1od+FwhdccHw== X-Received: by 2002:a5d:6c68:0:b0:374:af19:7992 with SMTP id ffacd0b85a97d-381c7a47487mr8124488f8f.7.1730736712570; Mon, 04 Nov 2024 08:11:52 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.51 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:52 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Nicolas Roche Subject: [COMMITTED 33/38] ada: Improve performance of Unbounded_Wide_Wide_String Date: Mon, 4 Nov 2024 17:11:08 +0100 Message-ID: <20241104161116.1431659-33-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Nicolas Roche Improve performance of iteration using Element function. Improve performance of Append. gcc/ada/ChangeLog: * libgnat/a-stzunb__shared.adb: Restructure code to inline only the most common cases. Remove whenever possible runtime checks. * libgnat/a-stzunb__shared.ads: Add Inline => True to Append variants and Element. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-stzunb__shared.adb | 165 ++++++++++++++++++++------- gcc/ada/libgnat/a-stzunb__shared.ads | 12 +- 2 files changed, 130 insertions(+), 47 deletions(-) diff --git a/gcc/ada/libgnat/a-stzunb__shared.adb b/gcc/ada/libgnat/a-stzunb__shared.adb index 39dd7b94283..e5045c866b6 100644 --- a/gcc/ada/libgnat/a-stzunb__shared.adb +++ b/gcc/ada/libgnat/a-stzunb__shared.adb @@ -36,7 +36,24 @@ package body Ada.Strings.Wide_Wide_Unbounded is use Ada.Strings.Wide_Wide_Maps; - Growth_Factor : constant := 32; + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String); + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String); + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character); + -- Non_Inlined_Append are part of the respective Append method that + -- should not be inlined. The idea is that the code of Append is inlined. + -- In order to make inlining efficient it is better to have the inlined + -- code as small as possible. Thus most common cases are inlined and less + -- common cases are deferred in these functions. + + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By -- allocating extra space, we avoid the need to reallocate on every @@ -526,10 +543,12 @@ package body Ada.Strings.Wide_Wide_Unbounded is (Source : in out Unbounded_Wide_Wide_String; New_Item : Unbounded_Wide_Wide_String) is + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; - DR : Shared_Wide_Wide_String_Access; begin -- Source is an empty string, reuse New_Item data @@ -546,19 +565,17 @@ package body Ada.Strings.Wide_Wide_Unbounded is -- Try to reuse existent shared string - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; + elsif System.Atomic_Counters.Is_One (SR.Counter) + and then NR.Last <= SR.Max_Length + and then SR.Max_Length - NR.Last >= SR.Last + then + SR.Data (SR.Last + 1 .. SR.Last + NR.Last) := NR.Data (1 .. NR.Last); + SR.Last := SR.Last + NR.Last; -- Otherwise, allocate new one and fill it else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -566,31 +583,34 @@ package body Ada.Strings.Wide_Wide_Unbounded is (Source : in out Unbounded_Wide_Wide_String; New_Item : Wide_Wide_String) is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_Wide_String_Access; + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + New_Item_Length : constant Natural := New_Item'Length; + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; begin - -- New_Item is an empty string, nothing to do if New_Item'Length = 0 then + -- New_Item is an empty string, nothing to do null; - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it + elsif System.Atomic_Counters.Is_One (SR.Counter) + -- The following test checks in fact that + -- SR.Max_Length >= SR.Last + New_Item_Length without causing + -- overflow. + and then New_Item_Length <= SR.Max_Length + and then SR.Max_Length - New_Item_Length >= SR.Last + then + -- Try to reuse existing shared string + SR.Data (SR.Last + 1 .. SR.Last + New_Item_Length) := New_Item; + SR.Last := SR.Last + New_Item_Length; else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + -- Otherwise, allocate new one and fill it. Deferring the worst case + -- into a separate non-inlined function ensure that inlined Append + -- code size remains short and thus efficient. + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -598,26 +618,24 @@ package body Ada.Strings.Wide_Wide_Unbounded is (Source : in out Unbounded_Wide_Wide_String; New_Item : Wide_Wide_Character) is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; - DR : Shared_Wide_Wide_String_Access; + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last + 1) then + if System.Atomic_Counters.Is_One (SR.Counter) + and then SR.Max_Length > SR.Last + then + -- Try to reuse existing shared string SR.Data (SR.Last + 1) := New_Item; SR.Last := SR.Last + 1; - -- Otherwise, allocate new one and fill it - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + -- Otherwise, allocate new one and fill it. Deferring the worst case + -- into a separate non-inlined function ensure that inlined Append + -- code size remains short and thus efficient. + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -777,6 +795,7 @@ package body Ada.Strings.Wide_Wide_Unbounded is (Source : Unbounded_Wide_Wide_String; Index : Positive) return Wide_Wide_Character is + pragma Suppress (All_Checks); SR : constant Shared_Wide_Wide_String_Access := Source.Reference; begin if Index <= SR.Last then @@ -1184,6 +1203,66 @@ package body Ada.Strings.Wide_Wide_Unbounded is return Source.Reference.Last; end Length; + ------------------------ + -- Non_Inlined_Append -- + ------------------------ + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_Wide_String_Access; + begin + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end Non_Inlined_Append; + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + begin + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end Non_Inlined_Append; + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + if SR.Last = Natural'Last then + raise Constraint_Error; + else + declare + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + begin + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end; + end if; + end Non_Inlined_Append; + --------------- -- Overwrite -- --------------- diff --git a/gcc/ada/libgnat/a-stzunb__shared.ads b/gcc/ada/libgnat/a-stzunb__shared.ads index 5de03471fa7..1e7b9e12408 100644 --- a/gcc/ada/libgnat/a-stzunb__shared.ads +++ b/gcc/ada/libgnat/a-stzunb__shared.ads @@ -79,15 +79,18 @@ package Ada.Strings.Wide_Wide_Unbounded is procedure Append (Source : in out Unbounded_Wide_Wide_String; - New_Item : Unbounded_Wide_Wide_String); + New_Item : Unbounded_Wide_Wide_String) + with Inline => True; procedure Append (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_String); + New_Item : Wide_Wide_String) + with Inline => True; procedure Append (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_Character); + New_Item : Wide_Wide_Character) + with Inline => True; function "&" (Left : Unbounded_Wide_Wide_String; @@ -111,7 +114,8 @@ package Ada.Strings.Wide_Wide_Unbounded is function Element (Source : Unbounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character; + Index : Positive) return Wide_Wide_Character + with Inline => True; procedure Replace_Element (Source : in out Unbounded_Wide_Wide_String; From patchwork Mon Nov 4 16:11:09 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: 2006329 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=J2eUVmzO; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxYK4xFzz1xxN for ; Tue, 5 Nov 2024 03:21:25 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D23CD3857000 for ; Mon, 4 Nov 2024 16:21:23 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x329.google.com (mail-wm1-x329.google.com [IPv6:2a00:1450:4864:20::329]) by sourceware.org (Postfix) with ESMTPS id C405F3857000 for ; Mon, 4 Nov 2024 16:11:54 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org C405F3857000 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 C405F3857000 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::329 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736759; cv=none; b=cYoRFPR1k4GqlIg7IGksNuiHzBujRBo+SwO6xZlOSLXxlBQs1GcHTgWnLcp7mTReMYqSekSjZ1+9NsZ9M9xzLfNMxvCTeE5ZOXobNtuhVBWs+SyxszXvgvJtaBBKzxvAL3bwHL5xRuzOnV2yhertjkLLr2mEL/zNyTqlXAEhKGw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736759; c=relaxed/simple; bh=UrBZdkOZt+CQZoYslYXmeNwBJxFxwxjX/wktuIKh5Xc=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=TXCm//hyQFMax6rKQ1BfRx+LqkZgaxwjs6RRv07v2uyU+VFSsLgQHwpIlVJhWQpWdiKOK3lBMwqeVVTHjwrC6y/KTUM5I9bH5AbPPprQgJui/BeC8zi7JQh+JoxKntxaFP5ObJiKjQxdbKobtRMAbjxGKxp/v+rmvPcuCvwBCIA= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x329.google.com with SMTP id 5b1f17b1804b1-43158625112so38171645e9.3 for ; Mon, 04 Nov 2024 08:11:54 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736713; x=1731341513; 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=EBGDB6b5rEvSov1mRC7os/7pZYIek2iJwymyA/az2aQ=; b=J2eUVmzOVX2bOR3sSqyBn4Rkh1GYAEzsH/LzuublAXN8EmJNj0T9/IiFaZ2zEguOeY D3h39mT4s17oKVY+35ITQxvFKKAKWOH4XChMApQy+TdCLuSQ7HdB5t6HhYvDI5zKuN7o XRfR2OvYxEiv4OhggEhT6S8Zg1UZ0cM7deCmvC5ZUv152wAv7BCwweWb9YNSgQRPcLF5 EGwtnATWc/pow/HZJanvAs7mN4ytxItZnZxBQKiH1zz7jqoN7gKXm7RqBFDW6q9d7z9m j/DZiKo0FN7QW7pDXY2JCqHrtZwnmMsCgRCjlvAyqswCDrFRAMtLNzgoL4W4QK39EZL4 tVaw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736713; x=1731341513; 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=EBGDB6b5rEvSov1mRC7os/7pZYIek2iJwymyA/az2aQ=; b=eCEpq4rgJl/kKhBJTRwF2t6C3d3AUXKSnDzZNjFzkJ/pxezcPs95QgI7YpzeDpJcXA hHM3OL/oFxgiyJ7OVtFKcMgmd+n3EuHQjduWqGLT4riVnPBldJd3h/5o+RHrC6Y8SGD0 /1G1ASbyAQHE5Wiqq7HqUrD9hsfyKZp2ptVBEqrARAc1BRBL0QcI6T7ebl6BcempNkm0 H48wSz130brxgatU6XEqw0RgCgoO87kViIrZ14ot9qBwkKwnlkkYeTrRMzyoOjRIO6I4 Wd8E2DbJ/jO8p/9bkYiThy91EK/ule+TlIcA8ZUjeb45Hjp+3CKE+f0rhW9+Jc4UcgrS 4FPQ== X-Gm-Message-State: AOJu0YyHce+L5mtmkJe0gE8ECkj3QVGB3oaQ3qrndJk2wAat5o8D5fFG 0LOuVJ0IfnUlOg2H0Lff+IjiuBgONGBKtz0zg8D0luLXXIMoz9y37WRQ9BHPmkzOf+dk6A+9G10 = X-Google-Smtp-Source: AGHT+IERf2zgV8mcJbdRQeQ7WSwGA9o5Et1p/I+27m9paYpKJALcZ8h9CfYL34K9pVpR5De2pf9EWQ== X-Received: by 2002:a5d:64c7:0:b0:37d:415c:f27c with SMTP id ffacd0b85a97d-381c7aa4846mr9070014f8f.38.1730736713380; Mon, 04 Nov 2024 08:11:53 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.52 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:52 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Nicolas Roche Subject: [COMMITTED 34/38] ada: Improve Unbounded_Wide_String performance Date: Mon, 4 Nov 2024 17:11:09 +0100 Message-ID: <20241104161116.1431659-34-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Nicolas Roche Improve performance of iteration using Element function. Improve performance of Append. gcc/ada/ChangeLog: * libgnat/a-stwiun__shared.adb: Restructure code to inline only the most common cases. Remove whenever possible runtime checks. * libgnat/a-stwiun__shared.ads: Add Inline => True to Append variants and Element. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-stwiun__shared.adb | 164 ++++++++++++++++++++------- gcc/ada/libgnat/a-stwiun__shared.ads | 9 +- 2 files changed, 127 insertions(+), 46 deletions(-) diff --git a/gcc/ada/libgnat/a-stwiun__shared.adb b/gcc/ada/libgnat/a-stwiun__shared.adb index 26b4f8ec85f..d3f20f0af20 100644 --- a/gcc/ada/libgnat/a-stwiun__shared.adb +++ b/gcc/ada/libgnat/a-stwiun__shared.adb @@ -36,7 +36,24 @@ package body Ada.Strings.Wide_Unbounded is use Ada.Strings.Wide_Maps; - Growth_Factor : constant := 32; + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String); + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String); + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character); + -- Non_Inlined_Append are part of the respective Append method that + -- should not be inlined. The idea is that the code of Append is inlined. + -- In order to make inlining efficient it is better to have the inlined + -- code as small as possible. Thus most common cases are inlined and less + -- common cases are deferred in these functions. + + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By -- allocating extra space, we avoid the need to reallocate on every @@ -525,10 +542,12 @@ package body Ada.Strings.Wide_Unbounded is (Source : in out Unbounded_Wide_String; New_Item : Unbounded_Wide_String) is + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + SR : constant Shared_Wide_String_Access := Source.Reference; NR : constant Shared_Wide_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; - DR : Shared_Wide_String_Access; begin -- Source is an empty string, reuse New_Item data @@ -545,19 +564,17 @@ package body Ada.Strings.Wide_Unbounded is -- Try to reuse existent shared string - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; + elsif System.Atomic_Counters.Is_One (SR.Counter) + and then NR.Last <= SR.Max_Length + and then SR.Max_Length - NR.Last >= SR.Last + then + SR.Data (SR.Last + 1 .. SR.Last + NR.Last) := NR.Data (1 .. NR.Last); + SR.Last := SR.Last + NR.Last; -- Otherwise, allocate new one and fill it else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -565,31 +582,34 @@ package body Ada.Strings.Wide_Unbounded is (Source : in out Unbounded_Wide_String; New_Item : Wide_String) is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_String_Access; + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + New_Item_Length : constant Natural := New_Item'Length; + SR : constant Shared_Wide_String_Access := Source.Reference; begin - -- New_Item is an empty string, nothing to do if New_Item'Length = 0 then + -- New_Item is an empty string, nothing to do null; - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it + elsif System.Atomic_Counters.Is_One (SR.Counter) + -- The following test checks in fact that + -- SR.Max_Length >= SR.Last + New_Item_Length without causing + -- overflow. + and then New_Item_Length <= SR.Max_Length + and then SR.Max_Length - New_Item_Length >= SR.Last + then + -- Try to reuse existing shared string + SR.Data (SR.Last + 1 .. SR.Last + New_Item_Length) := New_Item; + SR.Last := SR.Last + New_Item_Length; else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + -- Otherwise, allocate new one and fill it. Deferring the worst case + -- into a separate non-inlined function ensure that inlined Append + -- code size remains short and thus efficient. + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -597,26 +617,24 @@ package body Ada.Strings.Wide_Unbounded is (Source : in out Unbounded_Wide_String; New_Item : Wide_Character) is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; - DR : Shared_Wide_String_Access; + pragma Suppress (All_Checks); + -- Suppress checks as they are redundant with the checks done in that + -- function. + SR : constant Shared_Wide_String_Access := Source.Reference; begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last + 1) then + if System.Atomic_Counters.Is_One (SR.Counter) + and then SR.Max_Length > SR.Last + then + -- Try to reuse existing shared string SR.Data (SR.Last + 1) := New_Item; SR.Last := SR.Last + 1; - -- Otherwise, allocate new one and fill it - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); + -- Otherwise, allocate new one and fill it. Deferring the worst case + -- into a separate non-inlined function ensure that inlined Append + -- code size remains short and thus efficient. + Non_Inlined_Append (Source, New_Item); end if; end Append; @@ -1178,6 +1196,66 @@ package body Ada.Strings.Wide_Unbounded is return Source.Reference.Last; end Length; + ------------------------ + -- Non_Inlined_Append -- + ------------------------ + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_String_Access; + begin + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end Non_Inlined_Append; + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + begin + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end Non_Inlined_Append; + + procedure Non_Inlined_Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + if SR.Last = Natural'Last then + raise Constraint_Error; + else + declare + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_String_Access; + begin + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end; + end if; + end Non_Inlined_Append; + --------------- -- Overwrite -- --------------- diff --git a/gcc/ada/libgnat/a-stwiun__shared.ads b/gcc/ada/libgnat/a-stwiun__shared.ads index 865970f052c..19ccebf7186 100644 --- a/gcc/ada/libgnat/a-stwiun__shared.ads +++ b/gcc/ada/libgnat/a-stwiun__shared.ads @@ -79,15 +79,18 @@ package Ada.Strings.Wide_Unbounded is procedure Append (Source : in out Unbounded_Wide_String; - New_Item : Unbounded_Wide_String); + New_Item : Unbounded_Wide_String) + with Inline => True; procedure Append (Source : in out Unbounded_Wide_String; - New_Item : Wide_String); + New_Item : Wide_String) + with Inline => True; procedure Append (Source : in out Unbounded_Wide_String; - New_Item : Wide_Character); + New_Item : Wide_Character) + with Inline => True; function "&" (Left : Unbounded_Wide_String; From patchwork Mon Nov 4 16:11:10 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: 2006320 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=FU7BLCCb; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxV35HP5z1xyD for ; Tue, 5 Nov 2024 03:18:35 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 964733857038 for ; Mon, 4 Nov 2024 16:18:33 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x434.google.com (mail-wr1-x434.google.com [IPv6:2a00:1450:4864:20::434]) by sourceware.org (Postfix) with ESMTPS id 272D73857BA9 for ; Mon, 4 Nov 2024 16:11:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 272D73857BA9 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 272D73857BA9 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::434 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736759; cv=none; b=v/i2tUyF1MvCQ4tFmEyj2wfnCI4jB4hWOoaAGGPSTMdr7ZiSoIYWxrJQZaU3SlZV2UmX0aXRrDs77rZcfg2ekEV8D4GDKiVYFNGc6SAHsQyw3PNWjLyyK8zk2/M5W09oT7e55NYUlF+XJG2EG5IX5QnTY2yTNW/aBZrRxKrPXS4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736759; c=relaxed/simple; bh=OrfXyw3M2nfErVjwknvKhu2QkESOWcGFCxiuIfH2D3c=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=A+Nwhf8awyFC56euuNzdpDYrzphMNXQtqoEtXRnXJYhk+VDew+utgC8sNFLjyYWszgJh13epV4kdD27168dv7OLwctO/GQX1e7LMVIVG7DDk5GF9KRdLo255PI37+5dY7Sfs8U9XJfMM67dO1kTd+Ja7HoylQ14xRr7OYZ5daxc= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x434.google.com with SMTP id ffacd0b85a97d-3807dd08cfcso3799485f8f.1 for ; Mon, 04 Nov 2024 08:11:57 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736716; x=1731341516; 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=O9IVVJdW6uSFz1xjqS70esd0hhoyJQSlHh6zZm8d5/M=; b=FU7BLCCbTHTargNFtXyjnW+yXsHQePHc67bXXiZsKCteQuycDslnmVOmeni0zxo57V OiOEHBKCLbOgXTNZzak6gFwpw15Pbc9xlbfj0vcdBpmphbc184qwYyboGWJA0QTfgthY bvhxRU1rfRYUmj+qaiLWMpqczTNI68n+EPgfRwiPI+em0xoanW9F0/y7+t+IW4ObW372 +JvAL3onr/ZyEqHUnP4EBOuXzaQYc/BQfLNKJeiH5htFM0ZphrnhoLqVA1sNbgrfNVu6 aDPWA6FGk7RLWSVnvs+CGUTBNE1ceucJMYPSlrcZ+Nlp+ClnN5JvYXsIQgn6LiGvP4dc 0KhQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736716; x=1731341516; 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=O9IVVJdW6uSFz1xjqS70esd0hhoyJQSlHh6zZm8d5/M=; b=szTLsn7d4gZKCn8TtLT/KUAEPiU+tT8IPEKjg2Rk4ZJLD379ri9vH/kVb8Q8Dh5SAn qYnitOCyX1FdQuv3v6VYDdtf3GugKGK8sW0rCyHk01vjaMOei66N/EnGvFAwO6CfWh5S Ra+1dNCjfv/6tJnZdnq0L9YlEpki0Ut1+zM3AdqXB0l3GF6FjKCnHyK+7l225gpvrhDs hdR15GbdHeji8TTlnXb9Yl+79wcHfTInIw3+7EEezPSfhWsemku0mLw9uTHv66j7YvGW RKIaMUWnCuIqegQZ0yUkQRmzGE1qEH1Xl15Uo5B+rSRfHa8QcuG4VtPiymhUhrTyeRG3 z2pA== X-Gm-Message-State: AOJu0YyUMfjqn/zg0aynIDmfeHeqZKLligqPzamK3S3W46LMS9PtlL3O QMNCs5Iqb8pHySMxDt9LgbEwWg0xP/kwxhy6jQFpO2dcsl9G0a+/QNkiZA26leuH4gR3d0aCPLA = X-Google-Smtp-Source: AGHT+IFR1NzvGDq1gTvOe5uM5rE9po7p00hHSLmBhBFRLUJJKs9Rrgyke2+D7923CQ8YU/v4ly0ZSg== X-Received: by 2002:a05:6000:1867:b0:37d:5318:bf0a with SMTP id ffacd0b85a97d-381c7a46489mr14245145f8f.1.1730736714451; Mon, 04 Nov 2024 08:11:54 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.53 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:53 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [COMMITTED 35/38] ada: Split Library_Unit using multiple wrappers Date: Mon, 4 Nov 2024 17:11:10 +0100 Message-ID: <20241104161116.1431659-35-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Bob Duff The Library_Unit field was used for all sorts of different purposes, which led to confusing code. This patch splits Library_Unit into much more specific wrapper subprograms that should be called instead of [Set_]Library_Unit. Predicates and pragmas Assert are used to catch misuses of these. We document the semantics, especially "surprising" cases (e.g. internally-generated with clauses can refer to package bodies). This change does not fix gigi, codepeer, spark, or llvm to use the new wrappers; so far, they are used only in the GNAT front end. gcc/ada/ChangeLog: * sinfo.ads (Library_Unit): Rewrite documentation. Note that the "??? not (always) true..." comment was not true; the Subunit_Parent never points to the spec. (N_Compilation_Unit): Improve documentation. The Aux_ node was not created to solve the mentioned problems; it was created because the size of nodes was limited. Misc doc improvements. * sinfo-utils.ads: Add new wrappers for Library_Unit field. Use subtypes with predicates for the parameters. (First_Real_Statement): Still used in codepeer. * sinfo-utils.adb: Add new wrappers for Library_Unit field, with suitable assertions. * sem_prag.adb: Use new field wrapper names. (Matching_Name): New name for Same_Name to avoid potential confusion with the other function with the same name (Sem_Util.Same_Name), which is also called in this same file. (Matching_Convention): Change Same_Convention to match Matching_Name. * sem_util.ads (Same_Name): Improve comments; the old comment implied that it works for all names, which was not true. * sem_util.adb: Use new field wrapper names. * gen_il-gen.adb: Rename N_Unit_Body to be N_Lib_Unit_Body. Plain "unit" is ambiguous in Ada (library unit, compilation unit, program unit, etc). Add new union types N_Lib_Unit_Declaration and N_Lib_Unit_Renaming_Declaration. * gen_il-gen-gen_nodes.adb (Compute_Ranges): Raise exception earlier (it is already raised later, in Verify_Type_Table). Add a comment explaining why it might be raised. * gen_il-types.ads: Rename N_Unit_Body to be N_Lib_Unit_Body, and add new N_Lib_Unit_Declaration and N_Lib_Unit_Renaming_Declaration. * einfo.ads: Fix obsolete comment (was left over from before the "variable-sized nodes"). * exp_ch7.adb: Use new field wrapper names. * exp_disp.adb: Use new field wrapper names. * exp_unst.adb: Use new field wrapper names. * exp_util.adb: Use new field wrapper names. * fe.h: Add new field wrapper names. These are currently not used in gigi, but this change prepares for using them in gigi. * inline.adb: Use new field wrapper names. * lib.adb: Use new field wrapper names. Comment improvements. * lib-load.adb: Use new field wrapper names. Minor cleanup. * lib-writ.adb: Use new field wrapper names. * live.adb: Use new field wrapper names. * par-load.adb: Use new field wrapper names. Comment improvements. Minor cleanup. * rtsfind.adb: Use new field wrapper names. * sem.adb: Use new field wrapper names. * sem_ch10.adb: Use new field wrapper names. Comment improvements. Minor cleanup. * sem_ch12.adb: Use new field wrapper names. * sem_ch7.adb: Use new field wrapper names. * sem_ch8.adb: Use new field wrapper names. * sem_elab.adb: Use new field wrapper names. Comment improvements. * errout.adb (Output_Source_Line): Fix blowup in some obscure cases, where List_Pragmas is not fully set up. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/einfo.ads | 15 +-- gcc/ada/errout.adb | 3 +- gcc/ada/exp_ch7.adb | 5 +- gcc/ada/exp_disp.adb | 4 +- gcc/ada/exp_unst.adb | 6 +- gcc/ada/exp_util.adb | 2 +- gcc/ada/fe.h | 10 ++ gcc/ada/gen_il-gen-gen_nodes.adb | 22 +++- gcc/ada/gen_il-gen.adb | 9 ++ gcc/ada/gen_il-types.ads | 4 +- gcc/ada/inline.adb | 8 +- gcc/ada/lib-load.adb | 8 +- gcc/ada/lib-writ.adb | 17 +-- gcc/ada/lib.adb | 22 ++-- gcc/ada/live.adb | 12 +- gcc/ada/par-load.adb | 35 ++++-- gcc/ada/rtsfind.adb | 10 +- gcc/ada/sem.adb | 38 +++--- gcc/ada/sem_ch10.adb | 194 ++++++++++++++++--------------- gcc/ada/sem_ch12.adb | 48 ++++---- gcc/ada/sem_ch7.adb | 4 +- gcc/ada/sem_ch8.adb | 5 +- gcc/ada/sem_elab.adb | 31 ++--- gcc/ada/sem_prag.adb | 31 +++-- gcc/ada/sem_util.adb | 22 ++-- gcc/ada/sem_util.ads | 4 +- gcc/ada/sinfo-utils.adb | 139 ++++++++++++++++++++++ gcc/ada/sinfo-utils.ads | 63 +++++++++- gcc/ada/sinfo.ads | 66 ++++------- 29 files changed, 542 insertions(+), 295 deletions(-) diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 2aae60afae5..f0ae45ccb59 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -251,15 +251,12 @@ package Einfo is -- kinds of entities. In the latter case the attribute should only be set or -- accessed if the Ekind field indicates an appropriate entity. --- There are two kinds of attributes that apply to entities, stored and --- synthesized. Stored attributes correspond to a field or flag in the entity --- itself. Such attributes are identified in the table below by giving the --- field or flag in the attribute that is used to hold the attribute value. --- Synthesized attributes are not stored directly, but are rather computed as --- needed from other attributes, or from information in the tree. These are --- marked "synthesized" in the table below. The stored attributes have both --- access functions and set procedures to set the corresponding values, while --- synthesized attributes have only access functions. +-- Attributes that apply to entities are either "stored" or "synthesized". +-- Stored attributes are stored as fields in the entity node, and have +-- automatically-generated access functions and Set_... procedures. +-- Synthesized attributes are marked "(synthesized)" in the documentation +-- below, and are computed as needed; these have only (hand-written) access +-- functions. -- Note: in the case of Node, Uint, or Elist fields, there are cases where the -- same physical field is used for different purposes in different entities, diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 81919a3c523..21c8adf5e4f 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -3552,7 +3552,8 @@ package body Errout is -- Deal with matching entry in List_Pragmas table if Full_List - and then List_Pragmas_Index <= List_Pragmas.Last + and then List_Pragmas_Index in + List_Pragmas.First .. List_Pragmas.Last and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc then case List_Pragmas.Table (List_Pragmas_Index).Ptyp is diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 640ad5c60b8..f40371347fd 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2672,9 +2672,10 @@ package body Exp_Ch7 is Process_Package_Body (Decl); elsif Nkind (Decl) = N_Package_Body_Stub - and then Present (Library_Unit (Decl)) + and then Present (Stub_Subunit (Decl)) then - Process_Package_Body (Proper_Body (Unit (Library_Unit (Decl)))); + Process_Package_Body + (Proper_Body (Unit (Stub_Subunit (Decl)))); end if; Decl := Prev; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index c3671810d64..f2501173516 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -417,10 +417,10 @@ package body Exp_Disp is Build_Dispatch_Tables (Declarations (D)); elsif Nkind (D) = N_Package_Body_Stub - and then Present (Library_Unit (D)) + and then Present (Stub_Subunit (D)) then Build_Dispatch_Tables - (Declarations (Proper_Body (Unit (Library_Unit (D))))); + (Declarations (Proper_Body (Unit (Stub_Subunit (D))))); -- Handle full type declarations and derivations of library level -- tagged types diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index fb48a64ac86..9b76cba275f 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -1176,7 +1176,7 @@ package body Exp_Unst is -- is a semantic descendant of the stub. when N_Body_Stub => - Visit (Library_Unit (N)); + Visit (Stub_Subunit (N)); -- A declaration of a wrapper package indicates a subprogram -- instance for which there is no explicit body. Enter the @@ -2354,7 +2354,7 @@ package body Exp_Unst is -- recursively in Visit_Node. elsif Nkind (N) in N_Body_Stub then - Do_Search (Library_Unit (N)); + Do_Search (Stub_Subunit (N)); -- Skip generic packages @@ -2385,7 +2385,7 @@ package body Exp_Unst is or else (Nkind (Unit (N)) = N_Subprogram_Body and then not Acts_As_Spec (N)) then - Do_Search (Library_Unit (N)); + Do_Search (Spec_Lib_Unit (N)); end if; Do_Search (N); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4029ea6263c..b400505db7b 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5006,7 +5006,7 @@ package body Exp_Util is -- declarations of the package spec. if Nkind (U) = N_Package_Body then - U := Unit (Library_Unit (Cunit (Current_Sem_Unit))); + U := Unit (Spec_Lib_Unit (Cunit (Current_Sem_Unit))); end if; if Nkind (U) = N_Package_Declaration then diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index e3e65fe18bd..bb40ca3e5cc 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -337,10 +337,20 @@ extern Entity_Id Storage_Model_Copy_To (Entity_Id); /* sinfo: */ +#define Spec_Lib_Unit sinfo__utils__spec_lib_unit +#define Body_Lib_Unit sinfo__utils__body_lib_unit +#define Subunit_Parent sinfo__utils__subunit_parent +#define Stub_Subunit sinfo__utils__stub_subunit +#define Withed_Lib_Unit sinfo__utils__withed_lib_unit #define End_Location sinfo__utils__end_location #define Set_Has_No_Elaboration_Code sinfo__nodes__set_has_no_elaboration_code #define Set_Present_Expr sinfo__nodes__set_present_expr +extern Node_Id Spec_Lib_Unit (Node_Id); +extern Node_Id Body_Lib_Unit (Node_Id); +extern Node_Id Subunit_Parent (Node_Id); +extern Node_Id Stub_Subunit (Node_Id); +extern Node_Id Withed_Lib_Unit (Node_Id); extern Source_Ptr End_Location (Node_Id); extern void Set_Has_No_Elaboration_Code (Node_Id, Boolean); extern void Set_Present_Expr (Node_Id, Uint); diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index a9c0fa42b0d..e0e0538c5f0 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -835,16 +835,16 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sm (Corresponding_Spec, Node_Id), Sm (Was_Originally_Stub, Flag))); - Ab (N_Unit_Body, N_Proper_Body); + Ab (N_Lib_Unit_Body, N_Proper_Body); - Cc (N_Package_Body, N_Unit_Body, + Cc (N_Package_Body, N_Lib_Unit_Body, (Sy (Defining_Unit_Name, Node_Id), Sy (Declarations, List_Id, Default_No_List), Sy (Handled_Statement_Sequence, Node_Id, Default_Empty), Sy (At_End_Proc, Node_Id, Default_Empty), Sy (Aspect_Specifications, List_Id, Default_No_List))); - Cc (N_Subprogram_Body, N_Unit_Body, + Cc (N_Subprogram_Body, N_Lib_Unit_Body, (Sy (Specification, Node_Id), Sy (Declarations, List_Id, Default_No_List), Sy (Handled_Statement_Sequence, Node_Id, Default_Empty), @@ -1792,4 +1792,20 @@ begin -- Gen_IL.Gen.Gen_Nodes N_Variant)); -- Nodes that can be alternatives in case contructs + Union (N_Lib_Unit_Declaration, + Children => + (N_Package_Declaration, + N_Subprogram_Declaration, + N_Generic_Declaration, + N_Generic_Instantiation)); + -- Nodes corresponding to the library_unit_declaration syntactic category + + Union (N_Lib_Unit_Renaming_Declaration, + Children => + (N_Package_Renaming_Declaration, + N_Subprogram_Renaming_Declaration, + N_Generic_Renaming_Declaration)); + -- Nodes corresponding to the library_unit_renaming_declaration syntactic + -- category. + end Gen_IL.Gen.Gen_Nodes; diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index 0f7abe7bf94..da7e96eaf19 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -734,6 +734,15 @@ package body Gen_IL.Gen is Type_Table (T).First := Type_Table (Children (1)).First; Type_Table (T).Last := Type_Table (Children (Last_Index (Children))).Last; + + -- We know that each abstract type has at least two + -- children. The concrete types must be ordered so + -- that each abstract type is a contiguous subrange. + + if Type_Table (T).First >= Type_Table (T).Last then + raise Illegal with + Image (T) & " children out of order"; + end if; end; when Between_Abstract_Entity_And_Concrete_Node_Types => diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads index f2a65957a09..4a739043faa 100644 --- a/gcc/ada/gen_il-types.ads +++ b/gcc/ada/gen_il-types.ads @@ -124,7 +124,9 @@ package Gen_IL.Types is N_Subexpr, N_Subprogram_Specification, N_Unary_Op, - N_Unit_Body, + N_Lib_Unit_Declaration, + N_Lib_Unit_Renaming_Declaration, + N_Lib_Unit_Body, -- End of abstract node types. diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 5f310abafda..9fa5642238e 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -498,7 +498,7 @@ package body Inline is -- package of the subprogram to find more calls to be inlined. if Comp = Cunit (Main_Unit) - or else Comp = Library_Unit (Cunit (Main_Unit)) + or else Comp = Spec_Or_Body_Lib_Unit (Cunit (Main_Unit)) then Add_Call (E); return Inline_Package; @@ -2897,7 +2897,7 @@ package body Inline is then Child_Spec := Defining_Entity - ((Unit (Library_Unit (Cunit (Main_Unit))))); + ((Unit (Spec_Lib_Unit (Cunit (Main_Unit))))); Comp := Parent (Unit_Declaration_Node (Body_Entity (P))); @@ -4712,11 +4712,11 @@ package body Inline is -- done in Analyze_Inlined_Bodies. while Nkind (Unit (Comp)) = N_Subunit loop - Comp := Library_Unit (Comp); + Comp := Subunit_Parent (Comp); end loop; return Comp = Cunit (Main_Unit) - or else Comp = Library_Unit (Cunit (Main_Unit)); + or else Comp = Spec_Or_Body_Lib_Unit (Cunit (Main_Unit)); end In_Main_Unit_Or_Subunit; ---------------- diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 06da3691d46..c8850647a4d 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -948,7 +948,7 @@ package body Lib.Load is -------------------------- procedure Make_Child_Decl_Unit (N : Node_Id) is - Unit_Decl : constant Node_Id := Library_Unit (N); + Unit_Decl : constant Node_Id := Spec_Lib_Unit (N); Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (N); begin @@ -988,14 +988,14 @@ package body Lib.Load is if In_Main then Units.Table (Units.Last) := Units.Table (Main_Unit); - Units.Table (Units.Last).Cunit := Library_Unit (N); + Units.Table (Units.Last).Cunit := Spec_Lib_Unit (N); Init_Unit_Name (Units.Last, Unit_Name (Main_Unit)); Units.Table (Main_Unit).Cunit := N; Units.Table (Main_Unit).Version := Source_Checksum (Sind); Init_Unit_Name (Main_Unit, Get_Body_Name - (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))))); + (Unit_Name (Get_Cunit_Unit_Number (Spec_Lib_Unit (N))))); else -- Duplicate information from instance unit, for the body. The unit @@ -1003,7 +1003,7 @@ package body Lib.Load is -- units table when first loaded as a declaration. Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N)); - Units.Table (Units.Last).Cunit := Library_Unit (N); + Units.Table (Units.Last).Cunit := Spec_Lib_Unit (N); end if; end Make_Instance_Unit; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 23de685de0f..e6bfbf1bb37 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -339,7 +339,7 @@ package body Lib.Writ is -- the unit anywhere else. if Nkind (Item) = N_With_Clause then - Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); + Unum := Get_Cunit_Unit_Number (Withed_Lib_Unit (Item)); With_Flags (Unum) := True; if not Limited_Present (Item) then @@ -594,9 +594,10 @@ package body Lib.Writ is if Ukind in N_Generic_Declaration or else - (Present (Library_Unit (Unode)) - and then - Nkind (Unit (Library_Unit (Unode))) in N_Generic_Declaration) + (Ukind in N_Lib_Unit_Body + and then Present (Spec_Lib_Unit (Unode)) + and then Nkind (Unit (Spec_Lib_Unit (Unode))) + in N_Generic_Declaration) then Write_Info_Str (" GE"); end if; @@ -638,7 +639,7 @@ package body Lib.Writ is -- it and which have context clauses of their own, since these -- with'ed units are part of its own elaboration dependencies. - if Nkind (Unit (Unode)) in N_Unit_Body then + if Nkind (Unit (Unode)) in N_Lib_Unit_Body then for S in Units.First .. Last_Unit loop -- We are only interested in subunits. For preproc. data and @@ -647,7 +648,7 @@ package body Lib.Writ is if Cunit (S) /= Empty and then Nkind (Unit (Cunit (S))) = N_Subunit then - Pnode := Library_Unit (Cunit (S)); + Pnode := Subunit_Parent (Cunit (S)); -- In gnatc mode, the errors in the subunits will not have -- been recorded, but the analysis of the subunit may have @@ -661,7 +662,7 @@ package body Lib.Writ is -- Find ultimate parent of the subunit while Nkind (Unit (Pnode)) = N_Subunit loop - Pnode := Library_Unit (Pnode); + Pnode := Subunit_Parent (Pnode); end loop; -- See if it belongs to current unit, and if so, include @@ -1169,7 +1170,7 @@ package body Lib.Writ is if Nkind (U) = N_Package_Body then U := Parent (Parent ( Alias (Related_Instance (Defining_Unit_Name - (Specification (Unit (Library_Unit (Parent (U))))))))); + (Specification (Unit (Spec_Lib_Unit (Parent (U))))))))); end if; S := Specification (U); diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 24255dac16e..9539a47ad35 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -36,6 +36,7 @@ with Opt; use Opt; with Output; use Output; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; with Sinput; use Sinput; with Stand; use Stand; with Stringt; use Stringt; @@ -481,12 +482,12 @@ package body Lib is -- earlier. if Nkind (Unit1) in N_Subprogram_Body | N_Package_Body then - if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then + if Spec_Lib_Unit (Cunit (Unum1)) = Cunit (Unum2) then return Yes_After; end if; elsif Nkind (Unit2) in N_Subprogram_Body | N_Package_Body then - if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then + if Spec_Lib_Unit (Cunit (Unum2)) = Cunit (Unum1) then return Yes_Before; end if; end if; @@ -779,10 +780,16 @@ package body Lib is end if; end loop; - -- If not in the table, must be a spec created for a main unit that is a - -- child subprogram body which we have not inserted into the table yet. + -- Not in the table. Empty N is some already-detected error; otherwise, + -- it must be a spec created for a main unit that is a child subprogram + -- body which we have not inserted into the table yet. - if N = Library_Unit (Cunit (Main_Unit)) then + if No (N) then + pragma Assert (Serious_Errors_Detected > 0); + return Main_Unit; + end if; + + if N = Spec_Lib_Unit (Cunit (Main_Unit)) then return Main_Unit; -- If it is anything else, something is seriously wrong, and we really @@ -1330,10 +1337,11 @@ package body Lib is if Nkind (Context_Item) = N_With_Clause and then not Limited_Present (Context_Item) then - pragma Assert (Present (Library_Unit (Context_Item))); + pragma Assert (Present (Withed_Lib_Unit (Context_Item))); Write_Unit_Name (Unit_Name - (Get_Cunit_Unit_Number (Library_Unit (Context_Item)))); + (Get_Cunit_Unit_Number + (Withed_Lib_Unit (Context_Item)))); if Is_Implicit_With (Context_Item) then Write_Str (" -- implicit"); diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb index 7707220e7f0..1001427c6e7 100644 --- a/gcc/ada/live.adb +++ b/gcc/ada/live.adb @@ -156,8 +156,8 @@ package body Live is Traverse (Spec_Of (N)); when N_Package_Body_Stub => - if Present (Library_Unit (N)) then - Traverse (Proper_Body (Unit (Library_Unit (N)))); + if Present (Subunit_Parent (N)) then + Traverse (Proper_Body (Unit (Stub_Subunit (N)))); end if; when N_Package_Body => @@ -252,8 +252,8 @@ package body Live is Traverse (Spec_Of (N)); when N_Package_Body_Stub => - if Present (Library_Unit (N)) then - Traverse (Proper_Body (Unit (Library_Unit (N)))); + if Present (Stub_Subunit (N)) then + Traverse (Proper_Body (Unit (Stub_Subunit (N)))); end if; when N_Package_Body => @@ -321,8 +321,8 @@ package body Live is end if; when N_Package_Body_Stub => - if Present (Library_Unit (N)) then - Traverse (Proper_Body (Unit (Library_Unit (N)))); + if Present (Stub_Subunit (N)) then + Traverse (Proper_Body (Unit (Stub_Subunit (N)))); end if; when N_Expanded_Name diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb index 45be02c1c72..dbb123eb7b7 100644 --- a/gcc/ada/par-load.adb +++ b/gcc/ada/par-load.adb @@ -258,8 +258,8 @@ begin -- have set our Fatal_Error flag to propagate this condition. if Unum /= No_Unit then - Set_Library_Unit (Curunit, Cunit (Unum)); - Set_Library_Unit (Cunit (Unum), Curunit); + Set_Spec_Lib_Unit (Curunit, Cunit (Unum)); + Set_Body_Lib_Unit (Cunit (Unum), Curunit); -- If this is a separate spec for the main unit, then we reset -- Main_Unit_Entity to point to the entity for this separate spec @@ -284,7 +284,7 @@ begin elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then Set_Acts_As_Spec (Curunit, True); - Set_Library_Unit (Curunit, Curunit); + Set_Spec_Lib_Unit (Curunit, Curunit); -- Otherwise we do have an error, repeat the load request for the spec -- with Required set True to generate an appropriate error message. @@ -341,7 +341,7 @@ begin Error_Node => Name (Unit (Curunit))); if Unum /= No_Unit then - Set_Library_Unit (Curunit, Cunit (Unum)); + Set_Subunit_Parent (Curunit, Cunit (Unum)); end if; end if; @@ -397,7 +397,7 @@ begin -- unit gets a fatal error, so we don't need to worry about that. if Unum /= No_Unit then - Set_Library_Unit (With_Node, Cunit (Unum)); + Set_Withed_Lib_Unit (With_Node, Cunit (Unum)); -- If the spec isn't found, then try finding the corresponding -- body, since it is possible that we have a subprogram body @@ -414,16 +414,29 @@ begin Renamings => True); -- If we got a subprogram body, then mark that we are using - -- the body as a spec in the file table, and set the spec - -- pointer in the N_With_Clause to point to the body entity. + -- the body as a spec in the file table, and set + -- Withed_Lib_Unit of the N_With_Clause to point to + -- the body entity. if Unum /= No_Unit and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body then With_Cunit := Cunit (Unum); - Set_Library_Unit (With_Node, With_Cunit); - Set_Acts_As_Spec (With_Cunit, True); - Set_Library_Unit (With_Cunit, With_Cunit); + Set_Withed_Lib_Unit (With_Node, With_Cunit); + + -- If we have errors, Acts_As_Spec and Spec_Lib_Unit might + -- not be set; set them for better error recovery. + + if Serious_Errors_Detected > 0 then + Set_Acts_As_Spec (With_Cunit, True); + Set_Spec_Lib_Unit (With_Cunit, With_Cunit); + + -- Otherwise, these field should already by set + + else + pragma Assert (Acts_As_Spec (With_Cunit)); + pragma Assert (Spec_Lib_Unit (With_Cunit) = With_Cunit); + end if; -- If we couldn't find the body, or if it wasn't a body spec -- then we are in trouble. We make one more call to Load to @@ -443,7 +456,7 @@ begin -- Here we create a dummy package unit for the missing unit Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name); - Set_Library_Unit (With_Node, Cunit (Unum)); + Set_Withed_Lib_Unit (With_Node, Cunit (Unum)); end if; end if; end if; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index f555b99c15d..01f1be23228 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -1310,11 +1310,11 @@ package body Rtsfind is (U, Defining_Unit_Name (Specification (LibUnit)))); Ghost_Mode := Saved_GM; - Set_Corresponding_Spec (Withn, U.Entity); - Set_First_Name (Withn); - Set_Is_Implicit_With (Withn); - Set_Library_Unit (Withn, Cunit (U.Unum)); - Set_Next_Implicit_With (Withn, U.First_Implicit_With); + Set_Corresponding_Spec (Withn, U.Entity); + Set_First_Name (Withn); + Set_Is_Implicit_With (Withn); + Set_Withed_Lib_Unit (Withn, Cunit (U.Unum)); + Set_Next_Implicit_With (Withn, U.First_Implicit_With); U.First_Implicit_With := Withn; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 915a1cc13a5..fd52e3aea39 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1530,7 +1530,7 @@ package body Sem is Curunit = Main_Unit or else (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body - and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit)); + and then Spec_Lib_Unit (Cunit (Main_Unit)) = Cunit (Curunit)); -- Configuration flags have special settings when compiling a predefined -- file as a main unit. This applies to its spec as well. @@ -1841,8 +1841,8 @@ package body Sem is while Present (CL) loop if Nkind (CL) = N_With_Clause - and then Library_Unit (CL) = Main_CU - and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) + and then Withed_Lib_Unit (CL) = Main_CU + and then not Done (Get_Cunit_Unit_Number (Withed_Lib_Unit (CL))) then return True; end if; @@ -2025,9 +2025,9 @@ package body Sem is if Nkind (Unit (Withed_Unit)) = N_Package_Body and then Is_Generic_Instance - (Defining_Entity (Unit (Library_Unit (Withed_Unit)))) + (Defining_Entity (Unit (Spec_Lib_Unit (Withed_Unit)))) then - Do_Withed_Unit (Library_Unit (Withed_Unit)); + Do_Withed_Unit (Spec_Lib_Unit (Withed_Unit)); end if; end Do_Withed_Unit; @@ -2062,7 +2062,7 @@ package body Sem is else Seen (Unit_Num) := True; - if CU = Library_Unit (Main_CU) then + if CU = Spec_Or_Body_Lib_Unit (Main_CU) then Process_Bodies_In_Context (CU); -- If main is a child unit, examine parent unit contexts @@ -2122,8 +2122,8 @@ package body Sem is Clause := First (Context_Items (Comp)); while Present (Clause) loop if Nkind (Clause) = N_With_Clause then - Spec := Library_Unit (Clause); - Body_CU := Library_Unit (Spec); + Spec := Withed_Lib_Unit (Clause); + Body_CU := Body_Lib_Unit (Spec); -- If we are processing the spec of the main unit, load bodies -- only if the with_clause indicates that it forced the loading @@ -2183,7 +2183,7 @@ package body Sem is and then Is_Generic_Instance (Defining_Entity (N)) then Append_List - (Context_Items (CU), Context_Items (Library_Unit (CU))); + (Context_Items (CU), Context_Items (Spec_Lib_Unit (CU))); end if; Next_Elmt (Cur); @@ -2233,11 +2233,11 @@ package body Sem is if CU = Main_CU and then Nkind (Original_Node (Unit (Main_CU))) in N_Generic_Instantiation - and then Present (Library_Unit (Main_CU)) + and then Present (Spec_Lib_Unit (Main_CU)) then Do_Unit_And_Dependents - (Library_Unit (Main_CU), - Unit (Library_Unit (Main_CU))); + (Spec_Lib_Unit (Main_CU), + Unit (Spec_Lib_Unit (Main_CU))); end if; -- It is a spec, process it, and the units it depends on, @@ -2257,7 +2257,7 @@ package body Sem is -- after all other specs. if Nkind (Unit (CU)) = N_Package_Declaration - and then Library_Unit (CU) = Main_CU + and then Body_Lib_Unit (CU) = Main_CU and then CU /= Main_CU then Spec_CU := CU; @@ -2316,7 +2316,7 @@ package body Sem is begin if Present (U) and then Nkind (Unit (U)) = N_Subunit then - Lib := Library_Unit (U); + Lib := Subunit_Parent (U); return Lib = Main_CU or else Is_Subunit_Of_Main (Lib); else return False; @@ -2346,7 +2346,7 @@ package body Sem is while Is_Child_Unit (Child) loop Parent_CU := Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); - Body_CU := Library_Unit (Parent_CU); + Body_CU := Body_Lib_Unit (Parent_CU); if Present (Body_CU) and then not Seen (Get_Cunit_Unit_Number (Body_CU)) @@ -2418,7 +2418,7 @@ package body Sem is -- and which have context clauses of their own, since these with'ed -- units are part of its own dependencies. - if Nkind (Unit (CU)) in N_Unit_Body then + if Nkind (Unit (CU)) in N_Lib_Unit_Body then for S in Main_Unit .. Last_Unit loop -- We are only interested in subunits. For preproc. data and def. @@ -2431,7 +2431,7 @@ package body Sem is Pnode : Node_Id; begin - Pnode := Library_Unit (Cunit (S)); + Pnode := Subunit_Parent (Cunit (S)); -- In -gnatc mode, the errors in the subunits will not have -- been recorded, but the analysis of the subunit may have @@ -2444,7 +2444,7 @@ package body Sem is -- Find ultimate parent of the subunit while Nkind (Unit (Pnode)) = N_Subunit loop - Pnode := Library_Unit (Pnode); + Pnode := Subunit_Parent (Pnode); end loop; -- See if it belongs to current unit, and if so, include its @@ -2476,7 +2476,7 @@ package body Sem is and then (Include_Limited or else not Limited_Present (Context_Item)) then - Lib_Unit := Library_Unit (Context_Item); + Lib_Unit := Withed_Lib_Unit (Context_Item); Action (Lib_Unit); end if; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 4e582440c40..8499178202b 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -706,12 +706,12 @@ package body Sem_Ch10 is Install_Parent_Policy_Pragmas (Parent_Spec (Lib_Unit)); elsif Nkind (Lib_Unit) = N_Package_Body then - Install_Parent_Policy_Pragmas (Library_Unit (N)); + Install_Parent_Policy_Pragmas (Spec_Lib_Unit (N)); elsif Nkind (Lib_Unit) = N_Subprogram_Body and then not Acts_As_Spec (N) then - Install_Parent_Policy_Pragmas (Library_Unit (N)); + Install_Parent_Policy_Pragmas (Spec_Lib_Unit (N)); end if; -- Search for check policy pragmas defined at the start of the @@ -768,12 +768,12 @@ package body Sem_Ch10 is Install_Parent_Policy_Pragmas (Parent_Spec (Lib_Unit)); elsif Nkind (Lib_Unit) = N_Package_Body then - Install_Parent_Policy_Pragmas (Library_Unit (Comp_Unit)); + Install_Parent_Policy_Pragmas (Spec_Lib_Unit (Comp_Unit)); elsif Nkind (Lib_Unit) = N_Subprogram_Body and then not Acts_As_Spec (Comp_Unit) then - Install_Parent_Policy_Pragmas (Library_Unit (Comp_Unit)); + Install_Parent_Policy_Pragmas (Spec_Lib_Unit (Comp_Unit)); end if; return Last_Policy_Pragma; @@ -823,7 +823,7 @@ package body Sem_Ch10 is -- Local variables Main_Cunit : constant Node_Id := Cunit (Main_Unit); - Lib_Unit : Node_Id := Library_Unit (N); + Lib_Unit : Node_Id := Other_Comp_Unit (N); Par_Spec_Name : Unit_Name_Type; Spec_Id : Entity_Id; Unum : Unit_Number_Type; @@ -979,7 +979,7 @@ package body Sem_Ch10 is -- If the subprogram body is a child unit, we must create a -- declaration for it, in order to properly load the parent(s). - -- After this, the original unit does not acts as a spec, because + -- After this, the original unit does not act as a spec, because -- there is an explicit one. If this unit appears in a context -- clause, then an implicit with on the parent will be added when -- installing the context. If this is the main unit, there is no @@ -1040,7 +1040,7 @@ package body Sem_Ch10 is Make_Compilation_Unit_Aux (Loc)); Set_Context_Items (N, Empty_List); - Set_Library_Unit (N, Lib_Unit); + Set_Spec_Lib_Unit (N, Lib_Unit); Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum)); Make_Child_Decl_Unit (N); @@ -1685,14 +1685,14 @@ package body Sem_Ch10 is -- Skip analyzing with clause if no unit; this happens for a with -- that references a non-existent unit. - if Present (Library_Unit (Item)) then + if Present (Withed_Lib_Unit (Item)) then Analyze (Item); end if; -- Do version update (skipped for implicit with) if not Is_Implicit_With (Item) then - Version_Update (N, Library_Unit (Item)); + Version_Update (N, Withed_Lib_Unit (Item)); end if; -- Skip pragmas. Configuration pragmas at the start were handled in @@ -1742,7 +1742,7 @@ package body Sem_Ch10 is -- limited with P.Q; -- package P.Q is ... - elsif Unit (Library_Unit (Item)) = Unit (N) then + elsif Unit (Withed_Lib_Unit (Item)) = Unit (N) then Error_Msg_N ("wrong use of limited-with clause", Item); -- Check wrong use of limited-with clause applied to some @@ -1750,8 +1750,9 @@ package body Sem_Ch10 is elsif Is_Child_Spec (Unit (N)) then declare - Lib_U : constant Entity_Id := Unit (Library_Unit (Item)); - P : Node_Id; + Lib_U : constant Entity_Id := + Unit (Withed_Lib_Unit (Item)); + P : Node_Id; begin P := Parent_Spec (Unit (N)); @@ -1787,16 +1788,16 @@ package body Sem_Ch10 is if Item /= It and then Nkind (It) = N_With_Clause and then not Limited_Present (It) - and then Nkind (Unit (Library_Unit (It))) in + and then Nkind (Unit (Withed_Lib_Unit (It))) in N_Package_Declaration | N_Package_Renaming_Declaration then - if Nkind (Unit (Library_Unit (It))) = + if Nkind (Unit (Withed_Lib_Unit (It))) = N_Package_Declaration then Unit_Name := Name (It); else - Unit_Name := Name (Unit (Library_Unit (It))); + Unit_Name := Name (Unit (Withed_Lib_Unit (It))); end if; -- Check if the named package (or some ancestor) @@ -1836,7 +1837,7 @@ package body Sem_Ch10 is -- Skip analyzing with clause if no unit, see above - if Present (Library_Unit (Item)) then + if Present (Withed_Lib_Unit (Item)) then Analyze (Item); end if; @@ -1844,7 +1845,7 @@ package body Sem_Ch10 is -- is a semantic dependency for recompilation purposes. if not Is_Implicit_With (Item) then - Version_Update (N, Library_Unit (Item)); + Version_Update (N, Withed_Lib_Unit (Item)); end if; -- Pragmas and use clauses and with clauses other than limited with's @@ -1972,7 +1973,7 @@ package body Sem_Ch10 is else Set_Corresponding_Stub (Unit (Comp_Unit), N); Analyze_Subunit (Comp_Unit); - Set_Library_Unit (N, Comp_Unit); + Set_Stub_Subunit (N, Comp_Unit); Set_Corresponding_Body (N, Defining_Entity (Unit (Comp_Unit))); end if; @@ -2007,14 +2008,14 @@ package body Sem_Ch10 is -- If the proper body is already linked to the stub node, the stub is -- in a generic unit and just needs analyzing. - if Present (Library_Unit (N)) then - Set_Corresponding_Stub (Unit (Library_Unit (N)), N); + if Present (Stub_Subunit (N)) then + Set_Corresponding_Stub (Unit (Stub_Subunit (N)), N); - -- If the subunit has severe errors, the spec of the enclosing - -- body may not be available, in which case do not try analysis. + -- If the subunit has errors, the spec of the enclosing body might + -- not be available, in which case do not try analysis. if Serious_Errors_Detected > 0 - and then No (Library_Unit (Library_Unit (N))) + and then No (Subunit_Parent (Stub_Subunit (N))) then return; end if; @@ -2026,10 +2027,10 @@ package body Sem_Ch10 is and then In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit)) then - SCO_Record_Raw (Get_Cunit_Unit_Number (Library_Unit (N))); + SCO_Record_Raw (Get_Cunit_Unit_Number (Stub_Subunit (N))); end if; - Analyze_Subunit (Library_Unit (N)); + Analyze_Subunit (Stub_Subunit (N)); -- Otherwise we must load the subunit and link to it @@ -2064,7 +2065,7 @@ package body Sem_Ch10 is Set_Corresponding_Stub (Unit (Cunit (Unum)), N); Analyze_Subunit (Cunit (Unum)); - Set_Library_Unit (N, Cunit (Unum)); + Set_Stub_Subunit (N, Cunit (Unum)); end if; end if; @@ -2106,10 +2107,10 @@ package body Sem_Ch10 is -- substitution of subunits, it makes sense to include it in the -- version identification. - if Present (Library_Unit (N)) then - Set_Corresponding_Stub (Unit (Library_Unit (N)), N); - Analyze_Subunit (Library_Unit (N)); - Version_Update (Cunit (Main_Unit), Library_Unit (N)); + if Present (Stub_Subunit (N)) then + Set_Corresponding_Stub (Unit (Stub_Subunit (N)), N); + Analyze_Subunit (Stub_Subunit (N)); + Version_Update (Cunit (Main_Unit), Stub_Subunit (N)); -- Otherwise we must load the subunit and link to it @@ -2163,7 +2164,7 @@ package body Sem_Ch10 is else Set_Corresponding_Stub (Unit (Comp_Unit), N); - Set_Library_Unit (N, Comp_Unit); + Set_Stub_Subunit (N, Comp_Unit); -- We update the version. Although we are not technically -- semantically dependent on the subunit, given our approach @@ -2382,7 +2383,7 @@ package body Sem_Ch10 is and then Limited_Present (Item) and then not Is_Implicit_With (Item) then - Semantics (Library_Unit (Item)); + Semantics (Withed_Lib_Unit (Item)); end if; Next (Item); @@ -2463,10 +2464,10 @@ package body Sem_Ch10 is -- SPARK mode. procedure Analyze_Subunit (N : Node_Id) is - Lib_Unit : constant Node_Id := Library_Unit (N); + Lib_Unit : constant Node_Id := Subunit_Parent (N); Par_Unit : constant Entity_Id := Current_Scope; - Lib_Spec : Node_Id := Library_Unit (Lib_Unit); + Lib_Spec : Node_Id := Other_Comp_Unit (Lib_Unit); Num_Scopes : Nat := 0; Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id; Enclosing_Child : Entity_Id := Empty; @@ -2606,7 +2607,7 @@ package body Sem_Ch10 is begin if Nkind (Unit (L)) = N_Subunit then - Re_Install_Parents (Library_Unit (L), Scope (Scop)); + Re_Install_Parents (Subunit_Parent (L), Scope (Scop)); end if; Install_Context (L, False); @@ -2739,7 +2740,7 @@ package body Sem_Ch10 is Remove_Context (Lib_Spec); while Nkind (Unit (Lib_Spec)) = N_Subunit loop - Lib_Spec := Library_Unit (Lib_Spec); + Lib_Spec := Subunit_Parent (Lib_Spec); Remove_Scope; Remove_Context (Lib_Spec); end loop; @@ -2750,7 +2751,7 @@ package body Sem_Ch10 is if Nkind (Unit (Lib_Spec)) in N_Package_Body | N_Subprogram_Body then - Remove_Context (Library_Unit (Lib_Spec)); + Remove_Context (Spec_Lib_Unit (Lib_Spec)); end if; end if; @@ -2935,13 +2936,12 @@ package body Sem_Ch10 is -- instantiation appears indirectly elsewhere in the context, it will -- have been analyzed already. - Unit_Kind : constant Node_Kind := - Nkind (Original_Node (Unit (Library_Unit (N)))); + U : constant Node_Id := Unit (Withed_Lib_Unit (N)); + Unit_Kind : constant Node_Kind := Nkind (Original_Node (U)); Nam : constant Node_Id := Name (N); E_Name : Entity_Id; Par_Name : Entity_Id; Pref : Node_Id; - U : constant Node_Id := Unit (Library_Unit (N)); Intunit : Boolean; -- Set True if the unit currently being compiled is an internal unit @@ -3034,7 +3034,8 @@ package body Sem_Ch10 is -- legality of subsequent (also useless) use clauses depend on the -- presence of the with clause. - if Library_Unit (N) = Library_Unit (Cunit (Current_Sem_Unit)) then + if Withed_Lib_Unit (N) = Spec_Or_Body_Lib_Unit (Cunit (Current_Sem_Unit)) + then Set_Is_Implicit_With (N); -- Self-referential withs are always useless, so warn @@ -3068,7 +3069,7 @@ package body Sem_Ch10 is -- Normal (non-self-referential) case else - Semantics (Library_Unit (N)); + Semantics (Withed_Lib_Unit (N)); end if; Intunit := Is_Internal_Unit (Current_Sem_Unit); @@ -3164,8 +3165,8 @@ package body Sem_Ch10 is -- visibility purposes we need the entity of its spec. elsif (Unit_Kind = N_Package_Instantiation - or else Nkind (Original_Node (Unit (Library_Unit (N)))) = - N_Package_Instantiation) + or else Nkind (Original_Node (Unit (Withed_Lib_Unit (N)))) = + N_Package_Instantiation) and then Nkind (U) = N_Package_Body then E_Name := Corresponding_Spec (U); @@ -3203,7 +3204,7 @@ package body Sem_Ch10 is elsif Unit_Kind = N_Subprogram_Body and then Nkind (Name (N)) = N_Selected_Component - and then not Acts_As_Spec (Library_Unit (N)) + and then not Acts_As_Spec (Withed_Lib_Unit (N)) then -- For a child unit that has no spec, one has been created and -- analyzed. The entity required is that of the spec. @@ -3228,10 +3229,11 @@ package body Sem_Ch10 is -- with_clause for the child unit (e.g. in separate subunits). if Unit_Kind = N_Subprogram_Declaration - and then Analyzed (Library_Unit (N)) - and then not Comes_From_Source (Library_Unit (N)) + and then Analyzed (Withed_Lib_Unit (N)) + and then not Comes_From_Source (Withed_Lib_Unit (N)) then - Set_Library_Unit (N, + Set_Library_Unit (N, Empty); -- overwritten by Set_Withed_Lib_Unit + Set_Withed_Lib_Unit (N, Cunit (Get_Source_Unit (Corresponding_Body (U)))); end if; end if; @@ -3349,7 +3351,7 @@ package body Sem_Ch10 is -- Propagate Fatal_Error setting from with'ed unit to current unit - case Fatal_Error (Get_Source_Unit (Library_Unit (N))) is + case Fatal_Error (Get_Source_Unit (Withed_Lib_Unit (N))) is -- Nothing to do if with'ed unit had no error @@ -3386,7 +3388,7 @@ package body Sem_Ch10 is begin if Nkind (Lib_Unit) in N_Package_Body | N_Subprogram_Body then - Curr_Unit := Defining_Entity (Unit (Library_Unit (N))); + Curr_Unit := Defining_Entity (Unit (Spec_Lib_Unit (N))); Par_Lib := Curr_Unit; elsif Nkind (Lib_Unit) = N_Subunit then @@ -3394,8 +3396,8 @@ package body Sem_Ch10 is -- The parent is itself a body. The parent entity is to be found in -- the corresponding spec. - Sub_Parent := Library_Unit (N); - Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent))); + Sub_Parent := Subunit_Parent (N); + Curr_Unit := Defining_Entity (Unit (Other_Comp_Unit (Sub_Parent))); -- If the parent itself is a subunit, Curr_Unit is the entity of the -- enclosing body, retrieve the spec entity which is the proper @@ -3675,7 +3677,7 @@ package body Sem_Ch10 is begin Set_Corresponding_Spec (Withn, Ent); Set_Is_Implicit_With (Withn); - Set_Library_Unit (Withn, Parent (Unit_Declaration_Node (Ent))); + Set_Withed_Lib_Unit (Withn, Parent (Unit_Declaration_Node (Ent))); Set_Parent_With (Withn); -- If the unit is a [generic] package or subprogram declaration @@ -3900,7 +3902,7 @@ package body Sem_Ch10 is begin Set_Corresponding_Spec (Withn, P_Name); Set_Is_Implicit_With (Withn); - Set_Library_Unit (Withn, P); + Set_Withed_Lib_Unit (Withn, P); Set_Parent_With (Withn); -- Node is placed at the beginning of the context items, so that @@ -4041,18 +4043,19 @@ package body Sem_Ch10 is elsif Nkind (Decl_Node) = N_Subprogram_Body and then not Acts_As_Spec (Parent (Decl_Node)) - and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node)))) + and then + Is_Child_Spec (Unit (Subunit_Parent (Parent (Decl_Node)))) then Implicit_With_On_Parent - (Unit (Library_Unit (Parent (Decl_Node))), N); + (Unit (Subunit_Parent (Parent (Decl_Node))), N); end if; -- Check license conditions unless this is a dummy unit - if Sloc (Library_Unit (Item)) /= No_Location then + if Sloc (Withed_Lib_Unit (Item)) /= No_Location then License_Check : declare Withu : constant Unit_Number_Type := - Get_Source_Unit (Library_Unit (Item)); + Get_Source_Unit (Withed_Lib_Unit (Item)); Withl : constant License_Type := License (Source_Index (Withu)); Unitl : constant License_Type := @@ -4147,18 +4150,18 @@ package body Sem_Ch10 is or else (Nkind (Lib_Unit) = N_Subprogram_Body and then not Acts_As_Spec (N)) then - Install_Context (Library_Unit (N), Chain); + Install_Context (Spec_Lib_Unit (N), Chain); -- Only install private with-clauses of a spec that comes from -- source, excluding specs created for a subprogram body that is -- a child unit. - if Comes_From_Source (Library_Unit (N)) then + if Comes_From_Source (Spec_Lib_Unit (N)) then Install_Private_With_Clauses - (Defining_Entity (Unit (Library_Unit (N)))); + (Defining_Entity (Unit (Spec_Lib_Unit (N)))); end if; - if Is_Child_Spec (Unit (Library_Unit (N))) then + if Is_Child_Spec (Unit (Spec_Lib_Unit (N))) then -- If the unit is the body of a public child unit, the private -- declarations of the parent must be made visible. If the child @@ -4174,7 +4177,7 @@ package body Sem_Ch10 is P_Name : Entity_Id; begin - Lib_Spec := Unit (Library_Unit (N)); + Lib_Spec := Unit (Spec_Lib_Unit (N)); while Is_Child_Spec (Lib_Spec) loop P := Unit (Parent_Spec (Lib_Spec)); P_Name := Defining_Entity (P); @@ -4194,7 +4197,7 @@ package body Sem_Ch10 is -- For a package body, children in context are immediately visible - Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N); + Install_Siblings (Defining_Entity (Unit (Spec_Lib_Unit (N))), N); end if; if Nkind (Lib_Unit) in N_Generic_Package_Declaration @@ -4269,7 +4272,7 @@ package body Sem_Ch10 is -- Protect the frontend against previous critical errors - case Nkind (Unit (Library_Unit (W))) is + case Nkind (Unit (Withed_Lib_Unit (W))) is when N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration | N_Package_Declaration @@ -4283,7 +4286,8 @@ package body Sem_Ch10 is -- Check "use + renamings" - WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W)))); + WEnt := + Defining_Unit_Name (Specification (Unit (Withed_Lib_Unit (W)))); Spec := Specification (Unit (P)); Item := First (Visible_Declarations (Spec)); @@ -4347,13 +4351,13 @@ package body Sem_Ch10 is begin -- Compilation unit of the parent of the withed library unit - Child_Parent := Library_Unit (Item); + Child_Parent := Withed_Lib_Unit (Item); -- If the child unit is a public child, then locate its nearest -- private ancestor, if any, then Child_Parent will then be set to -- the parent of that ancestor. - if not Private_Present (Library_Unit (Item)) then + if not Private_Present (Withed_Lib_Unit (Item)) then while Present (Child_Parent) and then not Private_Present (Child_Parent) loop @@ -4433,12 +4437,13 @@ package body Sem_Ch10 is begin -- A limited with_clause cannot appear in the same context_clause - -- as a nonlimited with_clause which mentions the same library. + -- as a nonlimited with_clause which mentions the same library + -- unit. Item := First (Context_Items (Comp_Unit)); while Present (Item) loop if Nkind (Item) = N_With_Clause - and then Library_Unit (Item) = Library_Unit (W) + and then Withed_Lib_Unit (Item) = Withed_Lib_Unit (W) then return True; end if; @@ -4488,7 +4493,7 @@ package body Sem_Ch10 is return; end if; - Set_Library_Unit (Withn, Cunit (Unum)); + Set_Withed_Lib_Unit (Withn, Cunit (Unum)); Set_Corresponding_Spec (Withn, Specification (Unit (Cunit (Unum)))); @@ -4542,11 +4547,11 @@ package body Sem_Ch10 is -- the private clause is installed before analyzing the private -- part of the current unit. - if Library_Unit (Item) /= Cunit (Current_Sem_Unit) + if Withed_Lib_Unit (Item) /= Cunit (Current_Sem_Unit) and then not Limited_View_Installed (Item) and then not Is_Ancestor_Unit - (Library_Unit (Item), Cunit (Current_Sem_Unit)) + (Withed_Lib_Unit (Item), Cunit (Current_Sem_Unit)) then if not Private_Present (Item) or else Private_Present (N) @@ -4785,7 +4790,7 @@ package body Sem_Ch10 is if Limited_Present (Item) then if not Limited_View_Installed (Item) and then - not Is_Ancestor_Unit (Library_Unit (Item), + not Is_Ancestor_Unit (Withed_Lib_Unit (Item), Cunit (Current_Sem_Unit)) then Install_Limited_With_Clause (Item); @@ -4960,7 +4965,7 @@ package body Sem_Ch10 is --------------------------------- procedure Install_Limited_With_Clause (N : Node_Id) is - P_Unit : constant Entity_Id := Unit (Library_Unit (N)); + P_Unit : constant Entity_Id := Unit (Withed_Lib_Unit (N)); E : Entity_Id; P : Entity_Id; Is_Child_Package : Boolean := False; @@ -5100,7 +5105,7 @@ package body Sem_Ch10 is and then Nkind (Decl) = N_Pragma loop if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then - Set_Body_Required (Library_Unit (N)); + Set_Body_Required (Withed_Lib_Unit (N)); return; end if; @@ -5196,7 +5201,7 @@ package body Sem_Ch10 is -- If no completion, this is a TAT, and a body is needed if No (Decl) then - Set_Body_Required (Library_Unit (N)); + Set_Body_Required (Withed_Lib_Unit (N)); return; end if; @@ -5228,7 +5233,7 @@ package body Sem_Ch10 is null; else - Set_Body_Required (Library_Unit (N)); + Set_Body_Required (Withed_Lib_Unit (N)); return; end if; @@ -5452,7 +5457,7 @@ package body Sem_Ch10 is if Is_Child_Unit (Defining_Entity - (Unit (Library_Unit (Cunit (Current_Sem_Unit))))) + (Unit (Spec_Lib_Unit (Cunit (Current_Sem_Unit))))) then return; end if; @@ -5822,7 +5827,7 @@ package body Sem_Ch10 is Set_Is_Visible_Lib_Unit (Related_Instance - (Defining_Entity (Unit (Library_Unit (With_Clause))))); + (Defining_Entity (Unit (Withed_Lib_Unit (With_Clause))))); end if; -- The parent unit may have been installed already, and may have @@ -5973,7 +5978,7 @@ package body Sem_Ch10 is E2 : Entity_Id; begin if Nkind (Unit (U2)) in N_Package_Body | N_Subprogram_Body then - E2 := Defining_Entity (Unit (Library_Unit (U2))); + E2 := Defining_Entity (Unit (Spec_Lib_Unit (U2))); return Is_Ancestor_Package (E1, E2); else return False; @@ -6051,17 +6056,17 @@ package body Sem_Ch10 is while Present (Item) loop if Nkind (Item) = N_With_Clause and then not Limited_Present (Item) - and then Nkind (Unit (Library_Unit (Item))) = + and then Nkind (Unit (Withed_Lib_Unit (Item))) = N_Package_Declaration then Decl := First (Visible_Declarations - (Specification (Unit (Library_Unit (Item))))); + (Specification (Unit (Withed_Lib_Unit (Item))))); while Present (Decl) loop if Nkind (Decl) = N_Package_Renaming_Declaration and then Entity (Name (Decl)) = P and then not Is_Limited_Withed_Unit - (Lib_Unit => Library_Unit (Item), + (Lib_Unit => Withed_Lib_Unit (Item), Pkg_Ent => Entity (Name (Decl))) then -- Generate the error message only if the current unit @@ -6097,11 +6102,10 @@ package body Sem_Ch10 is -- If it is a body not acting as spec, follow pointer to the -- corresponding spec, otherwise follow pointer to parent spec. - if Present (Library_Unit (Aux_Unit)) - and then Nkind (Unit (Aux_Unit)) in - N_Package_Body | N_Subprogram_Body + if Nkind (Unit (Aux_Unit)) in N_Package_Body | N_Subprogram_Body + and then Present (Spec_Lib_Unit (Aux_Unit)) then - if Aux_Unit = Library_Unit (Aux_Unit) then + if Aux_Unit = Spec_Lib_Unit (Aux_Unit) then -- Aux_Unit is a body that acts as a spec. Clause has -- already been flagged as illegal. @@ -6109,7 +6113,7 @@ package body Sem_Ch10 is return False; else - Aux_Unit := Library_Unit (Aux_Unit); + Aux_Unit := Spec_Lib_Unit (Aux_Unit); end if; else @@ -6186,7 +6190,7 @@ package body Sem_Ch10 is procedure Build_Limited_Views (N : Node_Id) is Unum : constant Unit_Number_Type := - Get_Source_Unit (Library_Unit (N)); + Get_Source_Unit (Withed_Lib_Unit (N)); Is_Analyzed : constant Boolean := Analyzed (Cunit (Unum)); Shadow_Pack : Entity_Id; @@ -6647,7 +6651,7 @@ package body Sem_Ch10 is -- declaration, not a subprogram declaration, generic declaration, -- generic instantiation, or package renaming declaration. - case Nkind (Unit (Library_Unit (N))) is + case Nkind (Unit (Withed_Lib_Unit (N))) is when N_Package_Declaration => null; @@ -6702,7 +6706,7 @@ package body Sem_Ch10 is -- Check if the chain is already built - Spec := Specification (Unit (Library_Unit (N))); + Spec := Specification (Unit (Withed_Lib_Unit (N))); if Limited_View_Installed (Spec) then return; @@ -6766,7 +6770,7 @@ package body Sem_Ch10 is while Present (CI) loop if Nkind (CI) = N_With_Clause and then not - No_Elab_Code_All (Get_Source_Unit (Library_Unit (CI))) + No_Elab_Code_All (Get_Source_Unit (Withed_Lib_Unit (CI))) -- In GNATprove mode, some runtime units are implicitly -- loaded to make their entities available for analysis. In @@ -6947,7 +6951,7 @@ package body Sem_Ch10 is and then not Is_Implicit_With (Item) then Set_Is_Immediately_Visible - (Defining_Entity (Unit (Library_Unit (Item))), False); + (Defining_Entity (Unit (Withed_Lib_Unit (Item))), False); end if; end if; @@ -6994,7 +6998,7 @@ package body Sem_Ch10 is -------------------------------- procedure Remove_Limited_With_Clause (N : Node_Id) is - Pack_Decl : constant Entity_Id := Unit (Library_Unit (N)); + Pack_Decl : constant Entity_Id := Unit (Withed_Lib_Unit (N)); begin pragma Assert (Limited_View_Installed (N)); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3ef4e698e81..f0c55aff6f4 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5786,7 +5786,7 @@ package body Sem_Ch12 is end if; if Ekind (Curr_Unit) = E_Package_Body then - Remove_Context (Library_Unit (Curr_Comp)); + Remove_Context (Spec_Lib_Unit (Curr_Comp)); end if; end if; @@ -6992,10 +6992,10 @@ package body Sem_Ch12 is Body_Cunit := Parent (N); - -- The two compilation unit nodes are linked by the Library_Unit field + -- Set spec/body links for the two compilation units - Set_Library_Unit (Decl_Cunit, Body_Cunit); - Set_Library_Unit (Body_Cunit, Decl_Cunit); + Set_Body_Lib_Unit (Decl_Cunit, Body_Cunit); + Set_Spec_Lib_Unit (Body_Cunit, Decl_Cunit); -- Preserve the private nature of the package if needed @@ -9175,11 +9175,11 @@ package body Sem_Ch12 is -- stub in the original generic unit with the subunit, in order -- to preserve non-local references within. - -- Only the proper body needs to be copied. Library_Unit and - -- context clause are simply inherited by the generic copy. - -- Note that the copy (which may be recursive if there are - -- nested subunits) must be done first, before attaching it to - -- the enclosing generic. + -- Only the proper body needs to be copied. The context clause + -- and Spec_Or_Body_Lib_Unit are simply inherited by the + -- generic copy. Note that the copy (which may be recursive + -- if there are nested subunits) must be done first, before + -- attaching it to the enclosing generic. New_Body := Copy_Generic_Node @@ -9198,7 +9198,7 @@ package body Sem_Ch12 is -- copy, which does not have stubs any longer. Set_Proper_Body (Unit (Subunit), New_Body); - Set_Library_Unit (New_N, Subunit); + Set_Stub_Subunit (New_N, Subunit); Inherit_Context (Unit (Subunit), N); end; @@ -9213,17 +9213,17 @@ package body Sem_Ch12 is <> null; - -- If the node is a compilation unit, it is the subunit of a stub, which - -- has been loaded already (see code below). In this case, the library - -- unit field of N points to the parent unit (which is a compilation - -- unit) and need not (and cannot) be copied. + -- If the node is a compilation unit, it is the subunit of a stub that + -- has already been loaded. The parent unit is a compilation unit and + -- need not (and cannot) be copied. - -- When the proper body of the stub is analyzed, the library_unit link - -- is used to establish the proper context (see sem_ch10). + -- When the proper body of the stub is analyzed, the Subunit_Parent + -- field is used to establish the proper context (see Sem_Ch10). -- The other fields of a compilation unit are copied as usual elsif Nkind (N) = N_Compilation_Unit then + pragma Assert (Unit (N) in N_Subunit_Id); -- This code can only be executed when not instantiating, because in -- the copy made for an instantiation, the compilation unit node has @@ -10155,7 +10155,7 @@ package body Sem_Ch12 is if Nkind (B) = N_Package_Body then Id := Corresponding_Spec (B); else pragma Assert (Nkind (B) = N_Package_Body_Stub); - Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); + Id := Corresponding_Spec (Proper_Body (Unit (Stub_Subunit (B)))); end if; Ensure_Freeze_Node (Id); @@ -10265,7 +10265,7 @@ package body Sem_Ch12 is begin if Nkind (Enc_N) = N_Package_Body_Stub then - Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_N))); + Enclosing_Body := Proper_Body (Unit (Stub_Subunit (Enc_N))); else Enclosing_Body := Enc_N; end if; @@ -10648,7 +10648,7 @@ package body Sem_Ch12 is Item := First (Context_Items (Parent (Gen_Decl))); while Present (Item) loop if Nkind (Item) = N_With_Clause then - Lib_Unit := Library_Unit (Item); + Lib_Unit := Withed_Lib_Unit (Item); -- Take care to prevent direct cyclic with's @@ -10660,7 +10660,7 @@ package body Sem_Ch12 is OK := True; while Present (Clause) loop if Nkind (Clause) = N_With_Clause - and then Library_Unit (Clause) = Lib_Unit + and then Withed_Lib_Unit (Clause) = Lib_Unit then OK := False; exit; @@ -10892,7 +10892,7 @@ package body Sem_Ch12 is not In_Same_Source_Unit (Generic_Parent (Par_Inst), Inst) then while Present (Decl) loop - if ((Nkind (Decl) in N_Unit_Body + if ((Nkind (Decl) in N_Lib_Unit_Body or else Nkind (Decl) in N_Body_Stub) and then Comes_From_Source (Decl)) @@ -15360,10 +15360,10 @@ package body Sem_Ch12 is return Current_Unit = Cunit (Main_Unit) - or else Current_Unit = Library_Unit (Cunit (Main_Unit)) + or else Current_Unit = Other_Comp_Unit (Cunit (Main_Unit)) or else (Present (Current_Unit) - and then Present (Library_Unit (Current_Unit)) - and then Is_In_Main_Unit (Library_Unit (Current_Unit))); + and then Present (Other_Comp_Unit (Current_Unit)) + and then Is_In_Main_Unit (Other_Comp_Unit (Current_Unit))); end Is_In_Main_Unit; ---------------------------- diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 07a88fee0ec..ff64744727a 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1406,7 +1406,7 @@ package body Sem_Ch7 is begin if Id = Cunit_Entity (Main_Unit) - or else Parent (Decl) = Library_Unit (Cunit (Main_Unit)) + or else Parent (Decl) = Other_Comp_Unit (Cunit (Main_Unit)) then Generate_Reference (Id, Scope (Id), 'k', False); @@ -1422,7 +1422,7 @@ package body Sem_Ch7 is begin if Nkind (Main_Spec) = N_Package_Body then - Main_Spec := Unit (Library_Unit (Cunit (Main_Unit))); + Main_Spec := Unit (Other_Comp_Unit (Cunit (Main_Unit))); end if; U := Parent_Spec (Main_Spec); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0c25c95c80e..2007db368ed 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -9998,7 +9998,8 @@ package body Sem_Ch8 is or else (Nkind (The_Unit) = N_Subprogram_Body and then not Acts_As_Spec (Cunit (Current_Sem_Unit)))) then - With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit))); + With_Sys := + Find_System (Spec_Or_Body_Lib_Unit (Cunit (Current_Sem_Unit))); end if; if No (With_Sys) and then Present (N) then @@ -10055,7 +10056,7 @@ package body Sem_Ch8 is Set_Corresponding_Spec (Withn, System_Aux_Id); Set_First_Name (Withn); Set_Is_Implicit_With (Withn); - Set_Library_Unit (Withn, Cunit (Unum)); + Set_Withed_Lib_Unit (Withn, Cunit (Unum)); Insert_After (With_Sys, Withn); Mark_Rewrite_Insertion (Withn); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 23cbe1ac50d..a0431a2cc44 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -8461,9 +8461,9 @@ package body Sem_Elab is Set_Context_Items (Main_Cunit, Items); end if; - -- Locate the with clause for the unit. Note that there may not be a - -- clause if the unit is visible through a subunit-body, body-spec, - -- or spec-parent relationship. + -- Locate the with clause for the unit. Note that there might not be + -- a with clause if the unit is visible through a subunit-body, + -- body-spec, or spec-parent relationship. Clause := Find_With_Clause @@ -8475,16 +8475,16 @@ package body Sem_Elab is -- Note that adding implicit with clauses is safe because analysis, -- resolution, and expansion have already taken place and it is not - -- possible to interfere with visibility. + -- possible to interfere with visibility. Note that this implicit + -- with clause can point at (for example) a package body, which + -- is not the case for normal with clauses. if No (Clause) then Clause := Make_With_Clause (Loc, Name => New_Occurrence_Of (Unit_Id, Loc)); - Set_Is_Implicit_With (Clause); - Set_Library_Unit (Clause, Unit_Cunit); - + Set_Withed_Lib_Unit (Clause, Unit_Cunit); Append_To (Items, Clause); end if; @@ -9887,7 +9887,7 @@ package body Sem_Elab is elsif Nkind (Item) = N_Package_Body_Stub and then Chars (Defining_Entity (Item)) = Spec_Nam then - Lib_Unit := Library_Unit (Item); + Lib_Unit := Stub_Subunit (Item); -- The corresponding subunit was previously loaded @@ -16374,6 +16374,8 @@ package body Sem_Elab is -- This procedure is called when the elaborate indication must be -- applied to a unit not in the context of the referencing unit. The -- unit gets added to the context as an implicit with. + -- Note that we can be with-ing (for example) a package body, which + -- is not the case for normal with clauses. function In_Withs_Of (UEs : Entity_Id) return Boolean; -- UEs is the spec entity of a unit. If the unit to be marked is @@ -16394,7 +16396,7 @@ package body Sem_Elab is begin Set_Is_Implicit_With (CW); - Set_Library_Unit (CW, Library_Unit (Itm)); + Set_Withed_Lib_Unit (CW, Withed_Lib_Unit (Itm)); -- Set elaborate all desirable on copy and then append the copy to -- the list of body with's and we are done. @@ -16417,7 +16419,7 @@ package body Sem_Elab is while Present (Itm) loop if Nkind (Itm) = N_With_Clause then Ent := - Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + Cunit_Entity (Get_Cunit_Unit_Number (Withed_Lib_Unit (Itm))); if U = Ent then return True; @@ -16465,7 +16467,8 @@ package body Sem_Elab is Itm := First (CI); while Present (Itm) loop if Nkind (Itm) = N_With_Clause then - Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + Ent := + Cunit_Entity (Get_Cunit_Unit_Number (Withed_Lib_Unit (Itm))); -- If we find it, then mark elaborate all desirable and return @@ -19055,8 +19058,8 @@ package body Sem_Elab is elsif Nkind (Nod) = N_Package_Body_Stub and then Chars (Defining_Identifier (Nod)) = Chars (E) then - if Present (Library_Unit (Nod)) then - return Unit (Library_Unit (Nod)); + if Present (Stub_Subunit (Nod)) then + return Unit (Stub_Subunit (Nod)); else return Load_Package_Body (Get_Unit_Name (Nod)); @@ -19756,7 +19759,7 @@ package body Sem_Elab is -- in each N_Compilation_Unit node, but that would involve -- rearranging N_Compilation_Unit_Aux to make room. - Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); + Helper (Get_Cunit_Unit_Number (Withed_Lib_Unit (Item))); if Result then return; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index eb11ceb7044..d877251110e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5651,8 +5651,7 @@ package body Sem_Prag is then Set_Has_Pragma_Unreferenced (Cunit_Entity - (Get_Source_Unit - (Library_Unit (Citem)))); + (Get_Source_Unit (Withed_Lib_Unit (Citem)))); Set_Elab_Unit_Name (Arg_Expr, Name (Citem)); exit; end if; @@ -8308,21 +8307,21 @@ package body Sem_Prag is Decl : Node_Id; Err : Boolean; - function Same_Convention (Decl : Node_Id) return Boolean; + function Matching_Convention (Decl : Node_Id) return Boolean; -- Decl is a pragma node. This function returns True if this -- pragma has a first argument that is an identifier with a -- Chars field corresponding to the Convention_Id C. - function Same_Name (Decl : Node_Id) return Boolean; + function Matching_Name (Decl : Node_Id) return Boolean; -- Decl is a pragma node. This function returns True if this -- pragma has a second argument that is an identifier with a -- Chars field that matches the Chars of the current subprogram. - --------------------- - -- Same_Convention -- - --------------------- + ------------------------- + -- Matching_Convention -- + ------------------------- - function Same_Convention (Decl : Node_Id) return Boolean is + function Matching_Convention (Decl : Node_Id) return Boolean is Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Decl)); @@ -8341,13 +8340,13 @@ package body Sem_Prag is end if; return False; - end Same_Convention; + end Matching_Convention; - --------------- - -- Same_Name -- - --------------- + ------------------- + -- Matching_Name -- + ------------------- - function Same_Name (Decl : Node_Id) return Boolean is + function Matching_Name (Decl : Node_Id) return Boolean is Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Decl)); Arg2 : Node_Id; @@ -8374,7 +8373,7 @@ package body Sem_Prag is end; return False; - end Same_Name; + end Matching_Name; -- Start of processing for Diagnose_Multiple_Pragmas @@ -8400,7 +8399,7 @@ package body Sem_Prag is -- Look for pragma with same name as us if Nkind (Decl) = N_Pragma - and then Same_Name (Decl) + and then Matching_Name (Decl) then -- Give error if same as our pragma or Export/Convention @@ -8421,7 +8420,7 @@ package body Sem_Prag is -- they specify the same convention. If so, all OK, -- and set special flags to stop other messages - if Same_Convention (Decl) then + if Matching_Convention (Decl) then Set_Import_Interface_Present (N); Set_Import_Interface_Present (Decl); Err := False; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1a512219e59..794bdedc490 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7506,7 +7506,7 @@ package body Sem_Util is while Present (Encl_Unit) and then Nkind (Unit (Encl_Unit)) = N_Subunit loop - Encl_Unit := Library_Unit (Encl_Unit); + Encl_Unit := Subunit_Parent (Encl_Unit); end loop; pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit); @@ -10059,7 +10059,7 @@ package body Sem_Util is function Get_Body_From_Stub (N : Node_Id) return Node_Id is begin - return Proper_Body (Unit (Library_Unit (N))); + return Proper_Body (Unit (Stub_Subunit (N))); end Get_Body_From_Stub; --------------------- @@ -20170,7 +20170,7 @@ package body Sem_Util is return Is_RCI_Pkg_Decl_Cunit (Cunit) or else (Nkind (Unit (Cunit)) = N_Package_Body - and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); + and then Is_RCI_Pkg_Decl_Cunit (Spec_Lib_Unit (Cunit))); end Is_RCI_Pkg_Spec_Or_Body; ----------------------------------------- @@ -27020,13 +27020,13 @@ package body Sem_Util is K2 : constant Node_Kind := Nkind (N2); begin - if (K1 = N_Identifier or else K1 = N_Defining_Identifier) - and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) + if K1 in N_Identifier | N_Defining_Identifier + and then K2 in N_Identifier | N_Defining_Identifier then return Chars (N1) = Chars (N2); - elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) - and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) + elsif K1 in N_Selected_Component | N_Expanded_Name + and then K2 in N_Selected_Component | N_Expanded_Name then return Same_Name (Selector_Name (N1), Selector_Name (N2)) and then Same_Name (Prefix (N1), Prefix (N2)); @@ -29046,7 +29046,7 @@ package body Sem_Util is Clause := First (Context_Items (Comp_Unit)); while Present (Clause) loop if Nkind (Clause) = N_With_Clause then - if Library_Unit (Clause) = U then + if Withed_Lib_Unit (Clause) = U then return True; -- The with_clause may denote a renaming of the unit we are @@ -29084,7 +29084,7 @@ package body Sem_Util is (Nkind (Unit (Curr)) = N_Subprogram_Body and then not Acts_As_Spec (Unit (Curr))) then - if Unit_In_Context (Library_Unit (Curr)) then + if Unit_In_Context (Spec_Lib_Unit (Curr)) then return True; end if; end if; @@ -29092,10 +29092,10 @@ package body Sem_Util is -- If the spec is a child unit, examine the parents if Is_Child_Unit (Curr_Entity) then - if Nkind (Unit (Curr)) in N_Unit_Body then + if Nkind (Unit (Curr)) in N_Lib_Unit_Body then return Unit_In_Parent_Context - (Parent_Spec (Unit (Library_Unit (Curr)))); + (Parent_Spec (Unit (Spec_Lib_Unit (Curr)))); else return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 289d601ec88..2f1d2574d37 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -3065,8 +3065,8 @@ package Sem_Util is -- capture actual value information, but we can capture conditional tests. function Same_Name (N1, N2 : Node_Id) return Boolean; - -- Determine if two (possibly expanded) names are the same name. This is - -- a purely syntactic test, and N1 and N2 need not be analyzed. + -- True if two identifiers or expanded names are the same name. This + -- is a purely syntactic test, and N1 and N2 need not be analyzed. function Same_Object (Node1, Node2 : Node_Id) return Boolean; -- Determine if Node1 and Node2 are known to designate the same object. diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index 23485aa2877..666024284ba 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -31,6 +31,145 @@ with Sinput; use Sinput; package body Sinfo.Utils is + function Spec_Lib_Unit + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id + is + pragma Assert (Unit (N) in N_Lib_Unit_Body_Id); + begin + return Val : constant Opt_N_Compilation_Unit_Id := + Spec_Or_Body_Lib_Unit (N) + do + pragma Assert + (if Present (Val) then + Unit (Val) in N_Lib_Unit_Declaration_Id + | N_Lib_Unit_Renaming_Declaration_Id -- only in case of error + or else (N = Val + and then Unit (N) in N_Subprogram_Body_Id + and then Acts_As_Spec (N))); + end return; + end Spec_Lib_Unit; + + procedure Set_Spec_Lib_Unit (N, Val : N_Compilation_Unit_Id) is + pragma Assert (Unit (N) in N_Lib_Unit_Body_Id); + pragma Assert + (Unit (Val) in N_Lib_Unit_Declaration_Id + | N_Lib_Unit_Renaming_Declaration_Id -- only in case of error + or else (N = Val + and then Unit (N) in N_Subprogram_Body_Id + and then Acts_As_Spec (N))); + begin + Set_Library_Unit (N, Val); + end Set_Spec_Lib_Unit; + + function Body_Lib_Unit + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id + is + pragma Assert + (Unit (N) in N_Lib_Unit_Declaration_Id + | N_Lib_Unit_Renaming_Declaration_Id); -- only in case of error + begin + return Val : constant Opt_N_Compilation_Unit_Id := + Spec_Or_Body_Lib_Unit (N) + do + pragma Assert + (if Present (Val) then Unit (Val) in N_Lib_Unit_Body_Id); + end return; + end Body_Lib_Unit; + + procedure Set_Body_Lib_Unit (N, Val : N_Compilation_Unit_Id) is + pragma Assert + (Unit (N) in N_Lib_Unit_Declaration_Id + | N_Lib_Unit_Renaming_Declaration_Id); -- only in case of error + pragma Assert (Unit (Val) in N_Lib_Unit_Body_Id); + begin + Set_Library_Unit (N, Val); + end Set_Body_Lib_Unit; + + function Spec_Or_Body_Lib_Unit + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id + is + pragma Assert + (Unit (N) in + N_Lib_Unit_Declaration_Id | N_Lib_Unit_Body_Id + | N_Lib_Unit_Renaming_Declaration_Id); + begin + return Other_Comp_Unit (N); + end Spec_Or_Body_Lib_Unit; + + function Subunit_Parent + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id + is + pragma Assert (Unit (N) in N_Subunit_Id); + begin + return Val : constant Opt_N_Compilation_Unit_Id := Other_Comp_Unit (N) do + pragma Assert + (if Present (Val) then + Unit (Val) in N_Lib_Unit_Body_Id | N_Subunit_Id); + end return; + end Subunit_Parent; + + procedure Set_Subunit_Parent (N, Val : N_Compilation_Unit_Id) is + pragma Assert (Unit (N) in N_Subunit_Id); + pragma Assert (Unit (Val) in N_Lib_Unit_Body_Id | N_Subunit_Id); + begin + Set_Library_Unit (N, Val); + end Set_Subunit_Parent; + + function Other_Comp_Unit + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id + is + pragma Assert (N in N_Compilation_Unit_Id); + Val : constant Opt_N_Compilation_Unit_Id := Library_Unit (N); + begin + if Unit (N) in N_Subunit_Id then + pragma Assert + (if Present (Val) then + Unit (Val) in N_Lib_Unit_Body_Id | N_Subunit_Id); + end if; + + return Library_Unit (N); + end Other_Comp_Unit; + + function Stub_Subunit + (N : N_Body_Stub_Id) return Opt_N_Compilation_Unit_Id is + begin + return Val : constant Opt_N_Compilation_Unit_Id := Library_Unit (N) do + pragma Assert (if Present (Val) then Unit (Val) in N_Subunit_Id); + end return; + end Stub_Subunit; + + procedure Set_Stub_Subunit + (N : N_Body_Stub_Id; Val : N_Compilation_Unit_Id) + is + pragma Assert (Unit (Val) in N_Subunit_Id); + begin + Set_Library_Unit (N, Val); + end Set_Stub_Subunit; + + function Withed_Lib_Unit + (N : N_With_Clause_Id) return Opt_N_Compilation_Unit_Id is + begin + return Val : constant Opt_N_Compilation_Unit_Id := Library_Unit (N) do + pragma Assert + (if Present (Val) then + Unit (Val) in N_Lib_Unit_Declaration_Id + | N_Lib_Unit_Renaming_Declaration_Id + | N_Package_Body_Id | N_Subprogram_Body_Id + | N_Null_Statement_Id); -- for ignored ghost code + end return; + end Withed_Lib_Unit; + + procedure Set_Withed_Lib_Unit + (N : N_With_Clause_Id; Val : N_Compilation_Unit_Id) + is + pragma Assert + (Unit (Val) in N_Lib_Unit_Declaration_Id + | N_Lib_Unit_Renaming_Declaration_Id + | N_Package_Body_Id | N_Subprogram_Body_Id); + begin + Set_Library_Unit (N, Val); + end Set_Withed_Lib_Unit; + --------------- -- Debugging -- --------------- diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads index 9acb620848c..ebb96992802 100644 --- a/gcc/ada/sinfo-utils.ads +++ b/gcc/ada/sinfo-utils.ads @@ -27,6 +27,65 @@ with Sinfo.Nodes; use Sinfo.Nodes; package Sinfo.Utils is + -- We would like to get rid of the Library_Unit field, and replace it with + -- Other_Comp_Unit (on N_Compilation_Unit), Withed_Lib_Unit (on + -- N_With_Clause), and Subunit (on N_Body_Stub). Or we could split + -- Other_Comp_Unit into Spec_Lib_Unit, Body_Lib_Unit, Subunit_Parent. + -- However, gnat-llvm, codepeer, and spark are still using Library_Unit. + -- Therefore, we use the wrappers below. + -- + -- The call site should always know whether it has an N_Compilation_Unit, + -- N_Body_Stub, or N_With_Clause. In the N_Compilation_Unit case, it should + -- also know whether it's looking for the spec of a body, the body of a + -- spec, or the parent of a subunit. Spec_Or_Body_Lib_Unit and + -- Other_Comp_Unit should be avoided when possible; these are for the + -- N_Compilation_Unit cases where the call site does NOT know what it's + -- looking for. + + function Spec_Lib_Unit + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id; + procedure Set_Spec_Lib_Unit (N, Val : N_Compilation_Unit_Id); + -- The spec compilation unit of a body compilation unit. + -- It can be an acts-as-spec subprogram body; in that case + -- Spec_Lib_Unit points to itself. + + function Body_Lib_Unit + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id; + procedure Set_Body_Lib_Unit (N, Val : N_Compilation_Unit_Id); + -- The body compilation unit of a spec compilation unit. + -- Empty if not present. + + function Spec_Or_Body_Lib_Unit + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id; + -- Same as Spec_Lib_Unit or Body_Lib_Unit, depending on whether + -- N is a body or spec. Used when we know N is a library unit + -- (not a subunit), but we don't know whether it's the spec + -- or the body. + + function Subunit_Parent + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id; + procedure Set_Subunit_Parent (N, Val : N_Compilation_Unit_Id); + -- The parent body of a subunit + + function Other_Comp_Unit + (N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id; + -- Same as Spec_Lib_Unit, Body_Lib_Unit, or Subunit_Parent, + -- as appropriate. Used when we don't know whether N is a + -- a library unit spec, library unit body, or subunit. + + function Stub_Subunit (N : N_Body_Stub_Id) return Opt_N_Compilation_Unit_Id; + procedure Set_Stub_Subunit + (N : N_Body_Stub_Id; Val : N_Compilation_Unit_Id); + -- Subunit corresponding to a stub + + function Withed_Lib_Unit + (N : N_With_Clause_Id) return Opt_N_Compilation_Unit_Id; + procedure Set_Withed_Lib_Unit + (N : N_With_Clause_Id; Val : N_Compilation_Unit_Id); + -- The compilation unit that a with clause refers to. + -- Note that the Sem_Elab creates with clauses that point to bodies + -- (including non-Acts_As_Spec bodies). + ------------------------------- -- Parent-related operations -- ------------------------------- @@ -54,9 +113,9 @@ package Sinfo.Utils is -- Miscellaneous Tree Access Subprograms -- ------------------------------------------- - function First_Real_Statement -- ???? + function First_Real_Statement -- ??? (Ignored : N_Handled_Sequence_Of_Statements_Id) return Node_Id is (Empty); - -- The First_Real_Statement field is going away, but it is referenced in + -- The First_Real_Statement field has been removed, but it is referenced in -- codepeer and gnat-llvm. This is a temporary version, always returning -- Empty, to ease the transition. diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 8b4c2e31959..47fd73a599a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1923,34 +1923,18 @@ package Sinfo is -- handler. -- Library_Unit - -- In a stub node, Library_Unit points to the compilation unit node of - -- the corresponding subunit. + -- Direct use of this field should be avoided; use the wrappers in + -- Sinfo.Utils instead. -- - -- In a with clause node, Library_Unit points to the spec of the with'ed - -- unit. + -- This field is used to store the following: -- - -- In a compilation unit node, the usage depends on the unit type: + -- In N_Compilation_Unit: Spec_Lib_Unit, Body_Lib_Unit, Subunit_Parent. -- - -- For a library unit body, Library_Unit points to the compilation unit - -- node of the corresponding spec, unless it's a subprogram body with - -- Acts_As_Spec set, in which case it points to itself. + -- In N_Body_Stub: Stub_Subunit. -- - -- For a spec, Library_Unit points to the compilation unit node of the - -- corresponding body, if present. The body will be present if the spec - -- is or contains generics that we needed to instantiate. Similarly, the - -- body will be present if we needed it for inlining purposes. Thus, if - -- we have a spec/body pair, both of which are present, they point to - -- each other via Library_Unit. + -- In N_With_Clause: Withed_Lib_Unit -- - -- For a subunit, Library_Unit points to the compilation unit node of - -- the parent body. - -- ??? not (always) true, in (at least some, maybe all?) cases it points - -- to the corresponding spec for the parent body. - -- - -- Note that this field is not used to hold the parent pointer for child - -- unit (which might in any case need to use it for some other purpose as - -- described above). Instead for a child unit, implicit with's are - -- generated for all parents. + -- See Sinfo.Utils for details. -- Local_Raise_Statements -- This field is present in exception handler nodes. It is set to @@ -6553,7 +6537,7 @@ package Sinfo is -- | CONTEXT_CLAUSE SUBUNIT -- The N_Compilation_Unit node itself represents the above syntax. - -- However, there are two additional items not reflected in the above + -- However, there are additional items not reflected in the above -- syntax. First we have the global declarations that are added by the -- code generator. These are outer level declarations (so they cannot -- be represented as being inside the units). An example is the wrapper @@ -6566,19 +6550,15 @@ package Sinfo is -- of elaboration of the library unit (notably the statement that sets -- the Boolean flag indicating that elaboration is complete). - -- The third item not reflected in the syntax is pragmas that appear - -- after the compilation unit. As always pragmas are a problem since - -- they are not part of the formal syntax, but can be stuck into the - -- source following a set of ad hoc rules, and we have to find an ad - -- hoc way of sticking them into the tree. For pragmas that appear - -- before the library unit, we just consider them to be part of the - -- context clause, and pragmas can appear in the Context_Items list - -- of the compilation unit. However, pragmas can also appear after - -- the library item. + -- Pragmas that appear after the compilation unit are not reflected + -- in the syntax. (Pragmas that appear before the library unit, are + -- considered part of the context clause. Pragmas can also appear in + -- the Context_Items list of the compilation unit.) - -- To deal with all these problems, we create an auxiliary node for - -- a compilation unit, referenced from the N_Compilation_Unit node, - -- that contains these items. + -- ???For historical reasons, the above information is stored in a + -- separate N_Compilation_Unit_Aux node associated with each + -- N_Compilation_Unit node. This information could be moved into + -- N_Compilation_Unit at this point. -- N_Compilation_Unit -- Sloc points to first token of defining unit name @@ -6595,6 +6575,10 @@ package Sinfo is -- Context_Pending -- Has_No_Elaboration_Code + -- Note: The Unit field can be any of N_Lib_Unit_Declaration, + -- N_Lib_Unit_Body, N_Lib_Unit_Renaming_Declaration, N_Subunit, + -- or (in the case of ignored ghost code) N_Null_Statement. + -- N_Compilation_Unit_Aux -- Sloc is a copy of the Sloc from the N_Compilation_Unit node -- Declarations (set to No_List if no global declarations) @@ -6689,7 +6673,7 @@ package Sinfo is -- Private_Present set if with_clause has private keyword -- Limited_Present set if LIMITED is present -- Next_Implicit_With - -- Library_Unit + -- Library_Unit (i.e. Withed_Lib_Unit) -- Corresponding_Spec -- First_Name (set to True if first name or only one name) -- Last_Name (set to True if last name or only one name) @@ -6748,7 +6732,7 @@ package Sinfo is -- Sloc points to FUNCTION or PROCEDURE -- Specification -- Corresponding_Spec_Of_Stub - -- Library_Unit points to the subunit + -- Library_Unit (i.e. Stub_Subunit) -- Corresponding_Body ------------------------------- @@ -6763,7 +6747,7 @@ package Sinfo is -- Sloc points to PACKAGE -- Defining_Identifier -- Corresponding_Spec_Of_Stub - -- Library_Unit points to the subunit + -- Library_Unit (i.e. Stub_Subunit) -- Corresponding_Body ---------------------------- @@ -6778,7 +6762,7 @@ package Sinfo is -- Sloc points to TASK -- Defining_Identifier -- Corresponding_Spec_Of_Stub - -- Library_Unit points to the subunit + -- Library_Unit (i.e. Stub_Subunit) -- Corresponding_Body -- At_End_Proc (set to Empty if no clean up procedure) @@ -6796,7 +6780,7 @@ package Sinfo is -- Sloc points to PROTECTED -- Defining_Identifier -- Corresponding_Spec_Of_Stub - -- Library_Unit points to the subunit + -- Library_Unit (i.e. Stub_Subunit) -- Corresponding_Body --------------------- From patchwork Mon Nov 4 16:11:11 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: 2006315 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=X9qL2eyg; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxT212xkz1xxW for ; Tue, 5 Nov 2024 03:17:42 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 1C46E385AC27 for ; Mon, 4 Nov 2024 16:17:38 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x334.google.com (mail-wm1-x334.google.com [IPv6:2a00:1450:4864:20::334]) by sourceware.org (Postfix) with ESMTPS id 8FF5D3857734 for ; Mon, 4 Nov 2024 16:11:56 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 8FF5D3857734 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 8FF5D3857734 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::334 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736758; cv=none; b=OiHGAOSCEQ+orepNC7qS6xaXCMRRalteYVyQ33AhQzEUDQwJv35AW4BFD8ClugkRfqUoW0d8LIt8bzWC7PLoCUw/+Dr6lta6C3SV9Eb6yuLqIgy1fvfca9Kai54o1A40WHtkkOqCZm3cLDBFjVRz8QpYeE0fNUjVjm9J4KZaRZQ= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736758; c=relaxed/simple; bh=bKgpzzI4r0XmlqyijGe7SqQShxpjLn5bCpOBZJ47W1E=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=nPqBkDdbhf42GBZsIPsiJA6lTaeOC4ceB3ItIOKdfRyPnCSoje3P3uv3SXq61VX8yyYv0aYsy0Fg78WIm6aeJ2/E0VoRus4UPIbdWOZYPZsoXWVuKnp3Z4REplZ/iNguS9U136+Gw9w50f5UcMCdh/SQkvPcv51SDgRXzs7tG6E= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x334.google.com with SMTP id 5b1f17b1804b1-4314c4cb752so38981715e9.2 for ; Mon, 04 Nov 2024 08:11:56 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736715; x=1731341515; 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=4dqJFXBalrScX9h1zX7pIzFK5lJytTTUGqIWNucz/NM=; b=X9qL2eyg+GhUDzNMyqAV7aSVGOI4zp/OHeSknTOUZJQQBnnXn9YQzNerkzqTLN7Iqa BPYhiaSjia71T9+DMj1hIPhYJuq/49aHeVL2mYH9dPCNazJkzDQNUUh5QtYaW7H3TLEl U+6m3P4TXcqykdFPxdJuA/VkWdhHnv1YPymC3mfXY1YY7n4r6y+ZI4klJMFnAytyBvmp 7jdDy5opBA5xTQo6RHFS7RZfR3c6zNUAJUR15+jBQi/43EuItOVVOjVgFM6WFGs5rBHG NO/HZ3JulyzxPnAOpYURl+U08lKOr1dupMKohgfn3uwtkeWj+WaqFjZ5tYm8D3jJZXtM XqkQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736715; x=1731341515; 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=4dqJFXBalrScX9h1zX7pIzFK5lJytTTUGqIWNucz/NM=; b=NpjaDzxS140Zrbq8Vnll30JQfB7+IMYJwGDP83YPef9R3u2PJFLLPpADVKAR+bK7+p Yr/UKiLKWluKcclP3jqFimfxERgBUQQyTE5wQQnWPGn94I4XnaWlCm5yHef+eSoRpCso svhFi9/LLi0QoQlD3uhWNxu0tm2hHd9hnLTAecUsTB4woyyR2ODILG6kusb3GhPqJuJd AQKYwOvOS6YBEc0n3rt2jkq19h1QPCzECigxISjGMAjeEc6sVOgoGEcSz80vHHpEInMD 2HHsv93VCnfGzhK6AtezZ3vtpmaSRGvPJJtezu7ify387lxstuWj78lOGc5Hfd9Jz12x Wv0w== X-Gm-Message-State: AOJu0Yzxqbtte0uPZ91qTE55/7sFvyjJ7z6nwq7Y6iR+7xqz91hKAuEl oNyd22elgw5SkJ0Wufz64FZTqOImOXcODTWunUbJKjR+rhxE3OlPtN/4M2Hd2VKjTcsDqr9NStM = X-Google-Smtp-Source: AGHT+IHZTbeQcQvp8vDXza/7vXGGVF4xZIEprN8Bm0ZgoZFuI2LbBWDOrLLpCS2xlznUYGBToryMdA== X-Received: by 2002:a05:6000:1867:b0:37d:4d80:34ae with SMTP id ffacd0b85a97d-381be7adff4mr14251641f8f.4.1730736715248; Mon, 04 Nov 2024 08:11:55 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.54 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:54 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 36/38] ada: Fix ancient typo in process_decls Date: Mon, 4 Nov 2024 17:11:11 +0100 Message-ID: <20241104161116.1431659-36-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou It has gone unnoticed for decades because it changes nothing in practice. gcc/ada/ChangeLog: * gcc-interface/trans.cc (process_decls): Remove tests on Nkind that contain a typo and would be redundant if written correctly. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/trans.cc | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 5f8a18eebb7..a27804b91b8 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -9765,9 +9765,7 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, { /* For package specs, we recurse inside the declarations, thus taking the two pass approach inside the boundary. */ - if (Nkind (gnat_decl) == N_Package_Declaration - && (Nkind (Specification (gnat_decl) - == N_Package_Specification))) + if (Nkind (gnat_decl) == N_Package_Declaration) process_decls (Visible_Declarations (Specification (gnat_decl)), Private_Declarations (Specification (gnat_decl)), true, false); @@ -9853,9 +9851,7 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, || Nkind (gnat_decl) == N_Protected_Body_Stub) add_stmt (gnat_to_gnu (gnat_decl)); - else if (Nkind (gnat_decl) == N_Package_Declaration - && (Nkind (Specification (gnat_decl) - == N_Package_Specification))) + else if (Nkind (gnat_decl) == N_Package_Declaration) process_decls (Visible_Declarations (Specification (gnat_decl)), Private_Declarations (Specification (gnat_decl)), false, true); From patchwork Mon Nov 4 16:11:12 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: 2006324 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=QPGXrKPc; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxWT6Ph1z1xyH for ; Tue, 5 Nov 2024 03:19:49 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 1E9F6385AC2D for ; Mon, 4 Nov 2024 16:19:48 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x334.google.com (mail-wm1-x334.google.com [IPv6:2a00:1450:4864:20::334]) by sourceware.org (Postfix) with ESMTPS id C52F83857BA7 for ; Mon, 4 Nov 2024 16:11:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org C52F83857BA7 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 C52F83857BA7 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::334 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736762; cv=none; b=tXtu2n7WBaFxvOSKTAwr9E3ZgvlxMmEvcP8Ezo/h5mLIBbJjtprPkuQbNdhpQVZWh80pEWWqTOP6FwDvgMp5FBsxnbp+A77ub37/l/EhTwvkvgxOcbziv3yr3T4JJ+DjY5RVV6qr49mzwENejjjVtgKRGg84w0pVjo1YUzxEvXo= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736762; c=relaxed/simple; bh=pZhMGFd+UzFHHQaHueDqtUYffU/ITw0LxR2u+3FLDq8=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=ef5seRuU8iMHMYWfnL5FAhfeGl+8PaFzTBkg/iiISgwb/3ewbxGDcLhEyVOMZlhrccQcf5JV/n8A2VD/3QgpCvWkcaupTe5IMC6nZwKyvbIt7kFWh1nDqTHkO6GoJqTfaZQmv6n3mrD2GwEUef0w90MytOu6BU1oo2Bk8wuLGZM= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x334.google.com with SMTP id 5b1f17b1804b1-43158625112so38172505e9.3 for ; Mon, 04 Nov 2024 08:11:58 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736717; x=1731341517; 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=xnS3A1SP0bqHaysLf0xwuSebc/nLId85nChLPbijowk=; b=QPGXrKPcgWoesS8AWMc725zqkHUHJUm0Q0F5XB5chuJHEflaeV0ctp1vvy9vX1wMFH mJoVVX/41leR5P1jH3QiGW1dvjhCooxX4scmfOZYo1yBqaCRbwCW5rclFbrXQChes3sA tAvgxDKRFhDTjNVjn5QzxREbQYrr5/cH8FqoKK1mIiQgh9vrAGXMvZ6vK1f7MHhi4jaX llX/N5ch7bzhOy5WDsIFPMXCIM3btcdxA1rJsncHTpjM9l4S86rt/heVUs8wXdiOJNRF bfdC4b28VjFz7KCO1GsAjvuDUwvuvJjojxLd4Rebm7+4vty6y5sCp7JxWq5QFY/zmUd0 FqJA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736717; x=1731341517; 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=xnS3A1SP0bqHaysLf0xwuSebc/nLId85nChLPbijowk=; b=NM91lkzYnEyRPrrwPZs3cuULqkbImSmmAhK61+uxmmVq7Lj/9Xt0Hg5ynnxzhfY4io qa20iNP9Yg+YprpnH34Yeu/lz/3alG3P8Cz0DU474MGlNcLSPgP50isYNQY7389msGSj d3l1o0btn7UL7fInS+w/xoiyoKjHmCXrKGia/BN4yhwBSQRhiIkFOABdYn6lkaCcX+jU oicJY2xpiQ7EBxQ5nzMMw1lSLMLbl7FVUzW0YvLTzrg9pIW8H5JoXe9UfaUCqiYBl4L8 syyh8clVAJWWPEFwlYz6ZCuDt/Y4b0gNmk4BSf4kizgfA6KAwrPJqaJapeSzdnm4LC/n 55BA== X-Gm-Message-State: AOJu0YxQ8RqflK3Octrbk145p2XM07750W4InksGs53fRv5xhMLa/WW/ cwMGLKzrAo3+iKVSMEcfCQ6aaZTaFfMFva4lQt6gIDfUxxeIHNvbKquHF0LGOpgVmWWF6sOlKng = X-Google-Smtp-Source: AGHT+IEFYclonp5JSUswl+62xGzaczxzR1VYf64ipsX4DSn56y6d3gUaMIgQ5eDI+b0lLuSHTClzOQ== X-Received: by 2002:a05:6000:1f8e:b0:37d:3301:9891 with SMTP id ffacd0b85a97d-381c7a4c0e6mr8403077f8f.17.1730736715970; Mon, 04 Nov 2024 08:11:55 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.55 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:55 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 37/38] ada: Remove special case for the size of a string literal subtype Date: Mon, 4 Nov 2024 17:11:12 +0100 Message-ID: <20241104161116.1431659-37-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek Apparently we no longer need to ignore string literal subtypes case when validating size of a type entity. Code cleanup; behavior appears to be unaffected. gcc/ada/ChangeLog: * gcc-interface/decl.cc (gnat_to_gnu_entity): Remove special case for string literal subtypes. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/decl.cc | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 3404b747ddf..f5188ddc8bc 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -4457,12 +4457,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) process_attributes (&gnu_type, &attr_list, false, gnat_entity); /* See if a size was specified, by means of either an Object_Size or - a regular Size clause, and validate it if so. - - ??? Don't set the size for a String_Literal since it is either - confirming or we don't handle it properly (if the low bound is - non-constant). */ - if (!gnu_size && kind != E_String_Literal_Subtype) + a regular Size clause, and validate it if so. */ + if (!gnu_size) { const char *size_s = "size for %s too small{, minimum allowed is ^}"; const char *type_s = is_by_ref ? "by-reference type &" : "&"; From patchwork Mon Nov 4 16:11:13 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: 2006326 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=VmrfdMKX; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XhxXG0DX8z1xxN for ; Tue, 5 Nov 2024 03:20:30 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 188A2385770E for ; Mon, 4 Nov 2024 16:20:28 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x336.google.com (mail-wm1-x336.google.com [IPv6:2a00:1450:4864:20::336]) by sourceware.org (Postfix) with ESMTPS id 2B4943857BA3 for ; Mon, 4 Nov 2024 16:11:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2B4943857BA3 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 2B4943857BA3 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::336 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736759; cv=none; b=Y4jfLItXkmBwyVQH5wy9Op5tYQ5TEqrtbw0+a3t8tTgqiyp5fzB+J8yVgDZS9B5opWOhWsOkuDyK45epI2ABIDWsJhc7GnAxIuxLdTIE1xZVk2Bi+m9hAC/kwF+Az0aNmWNXRZcAEgxXhbA8cjrAB1hk64582HcRG8cY8iibT+g= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1730736759; c=relaxed/simple; bh=HAgieF/B51HEkruAILAwBX3DlRcQqGp5rM0LFf3VxOs=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=CmN4MIjQ/5fgbie+70KNtjqcqbqAKs0FH/cp0XNbgrXtiEpupWJBmfjmjFYs5biQBunXFGPL60yK4r1RP78S99x0eB2t4WvOTIISvUig3UjnSlYRDxl9KZhl8qp4tmRdUY956+oyL+h1FtVqr6uiy4D1T18JyLyM+48NuImA75o= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x336.google.com with SMTP id 5b1f17b1804b1-431481433bdso38964395e9.3 for ; Mon, 04 Nov 2024 08:11:58 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1730736717; x=1731341517; 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=8PkqtSv3ugXeCEnotK8I4VfPYn2JK25YhkvfvDHMVhU=; b=VmrfdMKX2vi9+F+XFO17mZhokIPH/Cmh96UaH2eecgMaApQWrh20IO4wF5BJ9luWMm OfLHiAPiAjReZuF4fRRkaQADzCWeyGEjOdgjS50AkCCwkUX3pKVFsect7oMP0gbzkKZ+ p+qaD/8mAbCYEldxom+/xtPNW7e1iRZRFb/2iBzi1DbI9M3e/NOZWAH7lZca7xLu5LtM AvCzKYL+3R4p+oXlEDFn+oCqbatbUYFVo4Y/EXF3Nl+RjF6TCncIpf6CyCBArnAXAjCW sz1kb0PGFrem8pj+wpk0D39/leSIIAFpjLwqb+Sm032+isinvAy6c3vXZDI5HF4dkaaE MPpg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1730736717; x=1731341517; 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=8PkqtSv3ugXeCEnotK8I4VfPYn2JK25YhkvfvDHMVhU=; b=V+g7cDUq5juSaqTxC44P7o4Jz1Rbd5c/iDCQXTx/t7NKYcly7VLlgu6F5ZoPhedfFA CZOIkY9ZgSfb4Ar2r6n9QpYnJwxaeEcRLsKhyXR2PfKPZoOFApaQsOzxBjgjJ1daj0js HMm28fk3RbVmbX17ZDFi2xkn63fdsijhbrijED3lFcrzB3HwoC4NbJZwVYCtC+b4Ma5+ 6Yy/RcsBvJ3HtfiGqgXrtEmXBLvhpeI3RFF6kWHWzJNUDeuBjSMM4UOFe49cZ8WHZEqY QvCQkJJGCB2SynWI7B3dZRLJtJU1K6zHYnrHYTyXXT6Izd03hplrEsuctLKxUoANdniN mb/w== X-Gm-Message-State: AOJu0YxiwXuW9kkVT8H8Pb6OvQNRziYpPmp5W3BRl1AlOU3ehpAxKrkW WPnho10fWK+RC8NY5rndCg/bVOai/yRXLTxxLJl393Khu9QMC3Zp34x/lZJRgUDCbu0nyb9quL0 = X-Google-Smtp-Source: AGHT+IEveFtrvTN57K1qYwwjpq7RkWEmOJ3sluaTpb4W60GN7J+/fLcqGnXGv4x0CgpTYhNwAbVpqg== X-Received: by 2002:a5d:47a2:0:b0:37d:4ef1:1820 with SMTP id ffacd0b85a97d-381bea1c0bemr13389873f8f.40.1730736716684; Mon, 04 Nov 2024 08:11:56 -0800 (PST) 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-381c10e747csm13574463f8f.64.2024.11.04.08.11.56 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Nov 2024 08:11:56 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 38/38] ada: Move special case for null string literal from frontend to backend Date: Mon, 4 Nov 2024 17:11:13 +0100 Message-ID: <20241104161116.1431659-38-poulhies@adacore.com> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20241104161116.1431659-1-poulhies@adacore.com> References: <20241104161116.1431659-1-poulhies@adacore.com> MIME-Version: 1.0 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~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek Previously the lower bound of string literals indexed by non-static integer types was artificially set to 1 in the frontend. This was to avoid an overflow in calculation of a null string size by the GCC backend, which was causing an excessively large binary object file. However, setting the lower bound to 1 was problematic for GNATprove, which could not easily retrieve the lower bound of string literals. This patch avoids the overflow in GCC by recognizing null string literal subtypes in Gigi. gcc/ada/ChangeLog: * gcc-interface/decl.cc (gnat_to_gnu_entity): Recognize null string literal subtypes and set their bounds to 1 .. 0. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/decl.cc | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index f5188ddc8bc..32e476c6993 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -3110,14 +3110,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) tree gnu_string_index_type = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_string_array_type)))); + + /* For a null string literal we set the bounds to 1 .. 0, to + avoid a possible overflow when calculating the upper bound + as LOWER_BOUND + LENGTH - 1. */ + const bool is_null_string + = String_Literal_Length (gnat_entity) == Uint_0; tree gnu_lower_bound - = convert (gnu_string_index_type, + = is_null_string ? + build_int_cst (gnu_string_index_type, 1) : + convert (gnu_string_index_type, gnat_to_gnu (String_Literal_Low_Bound (gnat_entity))); tree gnu_length = UI_To_gnu (String_Literal_Length (gnat_entity), gnu_string_index_type); tree gnu_upper_bound - = build_binary_op (PLUS_EXPR, gnu_string_index_type, + = is_null_string ? + build_int_cst (gnu_string_index_type, 0) : + build_binary_op (PLUS_EXPR, gnu_string_index_type, gnu_lower_bound, int_const_binop (MINUS_EXPR, gnu_length, convert (gnu_string_index_type,